From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- interp/constrarg.ml | 71 ++ interp/constrarg.mli | 74 ++ interp/constrexpr_ops.ml | 345 ++++++++ interp/constrexpr_ops.mli | 81 ++ interp/constrextern.ml | 858 ++++++++++--------- interp/constrextern.mli | 51 +- interp/constrintern.ml | 1794 ++++++++++++++++++++++----------------- interp/constrintern.mli | 152 ++-- interp/coqlib.ml | 256 +++--- interp/coqlib.mli | 61 +- interp/dumpglob.ml | 207 ++--- interp/dumpglob.mli | 39 +- interp/genarg.ml | 281 ------ interp/genarg.mli | 320 ------- interp/genintern.ml | 57 ++ interp/genintern.mli | 42 + interp/implicit_quantifiers.ml | 172 ++-- interp/implicit_quantifiers.mli | 47 +- interp/interp.mllib | 8 +- interp/modintern.ml | 200 ++--- interp/modintern.mli | 31 +- interp/notation.ml | 579 ++++++++----- interp/notation.mli | 66 +- interp/notation_ops.ml | 856 +++++++++++++++++++ interp/notation_ops.mli | 61 ++ interp/ppextend.ml | 6 +- interp/ppextend.mli | 3 +- interp/reserve.ml | 121 +-- interp/reserve.mli | 12 +- interp/smartlocate.ml | 43 +- interp/smartlocate.mli | 24 +- interp/stdarg.ml | 30 + interp/stdarg.mli | 21 + interp/syntax_def.ml | 34 +- interp/syntax_def.mli | 12 +- interp/topconstr.ml | 1153 ++----------------------- interp/topconstr.mli | 257 +----- 37 files changed, 4329 insertions(+), 4096 deletions(-) create mode 100644 interp/constrarg.ml create mode 100644 interp/constrarg.mli create mode 100644 interp/constrexpr_ops.ml create mode 100644 interp/constrexpr_ops.mli delete mode 100644 interp/genarg.ml delete mode 100644 interp/genarg.mli create mode 100644 interp/genintern.ml create mode 100644 interp/genintern.mli create mode 100644 interp/notation_ops.ml create mode 100644 interp/notation_ops.mli create mode 100644 interp/stdarg.ml create mode 100644 interp/stdarg.mli (limited to 'interp') diff --git a/interp/constrarg.ml b/interp/constrarg.ml new file mode 100644 index 00000000..3f232c36 --- /dev/null +++ b/interp/constrarg.ml @@ -0,0 +1,71 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* f c + | ByNotation (loc,s,_) -> loc + +let unsafe_of_type (t : argument_type) : ('a, 'b, 'c) Genarg.genarg_type = + Obj.magic t + +let wit_int_or_var = unsafe_of_type IntOrVarArgType + +let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = + Genarg.make0 None "intropattern" + +let wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type = + Genarg.make0 None "tactic" + +let wit_ident = unsafe_of_type IdentArgType + +let wit_var = unsafe_of_type VarArgType + +let wit_ref = Genarg.make0 None "ref" + +let wit_quant_hyp = unsafe_of_type QuantHypArgType + +let wit_genarg = unsafe_of_type GenArgType + +let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = + Genarg.make0 None "sort" + +let wit_constr = unsafe_of_type ConstrArgType + +let wit_constr_may_eval = unsafe_of_type ConstrMayEvalArgType + +let wit_uconstr = Genarg.make0 None "uconstr" + +let wit_open_constr = unsafe_of_type OpenConstrArgType + +let wit_constr_with_bindings = unsafe_of_type ConstrWithBindingsArgType + +let wit_bindings = unsafe_of_type BindingsArgType + +let wit_red_expr = unsafe_of_type RedExprArgType + +let wit_clause_dft_concl = + Genarg.make0 None "clause_dft_concl" + +(** Register location *) + +let () = + register_name0 wit_ref "Constrarg.wit_ref"; + register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; + register_name0 wit_tactic "Constrarg.wit_tactic"; + register_name0 wit_sort "Constrarg.wit_sort"; + register_name0 wit_uconstr "Constrarg.wit_uconstr"; + register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; diff --git a/interp/constrarg.mli b/interp/constrarg.mli new file mode 100644 index 00000000..74c6bd31 --- /dev/null +++ b/interp/constrarg.mli @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Loc.t) -> 'a or_by_notation -> Loc.t + +(** {5 Additional generic arguments} *) + +val wit_int_or_var : int or_var uniform_genarg_type + +val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type + +val wit_ident : Id.t uniform_genarg_type + +val wit_var : (Id.t located, Id.t located, Id.t) genarg_type + +val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type + +val wit_quant_hyp : quantified_hypothesis uniform_genarg_type + +val wit_genarg : (raw_generic_argument, glob_generic_argument, typed_generic_argument) genarg_type + +val wit_sort : (glob_sort, glob_sort, sorts) genarg_type + +val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_constr_may_eval : + ((constr_expr,reference or_by_notation,constr_expr) may_eval, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) may_eval, + constr) genarg_type + +val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type + +val wit_open_constr : + (open_constr_expr, open_glob_constr, Evd.open_constr) genarg_type + +val wit_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings Evd.sigma) genarg_type + +val wit_bindings : + (constr_expr bindings, + glob_constr_and_expr bindings, + constr bindings Evd.sigma) genarg_type + +val wit_red_expr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type + +val wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type + +val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml new file mode 100644 index 00000000..2d48ea4d --- /dev/null +++ b/interp/constrexpr_ops.ml @@ -0,0 +1,345 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true +| Implicit, Implicit -> true +| _ -> false + +let abstraction_kind_eq ak1 ak2 = match ak1, ak2 with +| AbsLambda, AbsLambda -> true +| AbsPi, AbsPi -> true +| _ -> false + +let binder_kind_eq b1 b2 = match b1, b2 with +| Default bk1, Default bk2 -> binding_kind_eq bk1 bk2 +| Generalized (bk1, ck1, b1), Generalized (bk2, ck2, b2) -> + binding_kind_eq bk1 bk2 && binding_kind_eq ck1 ck2 && + (if b1 then b2 else not b2) +| _ -> false + +let default_binder_kind = Default Explicit + +let names_of_local_assums bl = + List.flatten (List.map (function LocalRawAssum(l,_,_)->l|_->[]) bl) + +let names_of_local_binders bl = + List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]) bl) + +(**********************************************************************) +(* Functions on constr_expr *) + +let prim_token_eq t1 t2 = match t1, t2 with +| Numeral i1, Numeral i2 -> Bigint.equal i1 i2 +| String s1, String s2 -> String.equal s1 s2 +| _ -> false + +let explicitation_eq ex1 ex2 = match ex1, ex2 with +| ExplByPos (i1, id1), ExplByPos (i2, id2) -> + Int.equal i1 i2 && Option.equal Id.equal id1 id2 +| ExplByName id1, ExplByName id2 -> + Id.equal id1 id2 +| _ -> false + +let eq_located f (_, x) (_, y) = f x y + +let rec cases_pattern_expr_eq p1 p2 = + if p1 == p2 then true + else match p1, p2 with + | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) -> + Id.equal i1 i2 && cases_pattern_expr_eq a1 a2 + | CPatCstr(_,c1,a1,b1), CPatCstr(_,c2,a2,b2) -> + eq_reference c1 c2 && + List.equal cases_pattern_expr_eq a1 a2 && + List.equal cases_pattern_expr_eq b1 b2 + | CPatAtom(_,r1), CPatAtom(_,r2) -> + Option.equal eq_reference r1 r2 + | CPatOr (_, a1), CPatOr (_, a2) -> + List.equal cases_pattern_expr_eq a1 a2 + | CPatNotation (_, n1, s1, l1), CPatNotation (_, n2, s2, l2) -> + String.equal n1 n2 && + cases_pattern_notation_substitution_eq s1 s2 && + List.equal cases_pattern_expr_eq l1 l2 + | CPatPrim(_,i1), CPatPrim(_,i2) -> + prim_token_eq i1 i2 + | CPatRecord (_, l1), CPatRecord (_, l2) -> + let equal (r1, e1) (r2, e2) = + eq_reference r1 r2 && cases_pattern_expr_eq e1 e2 + in + List.equal equal l1 l2 + | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) -> + String.equal s1 s2 && cases_pattern_expr_eq e1 e2 + | _ -> false + +and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) = + List.equal cases_pattern_expr_eq s1 s2 && + List.equal (List.equal cases_pattern_expr_eq) n1 n2 + +let eq_universes u1 u2 = + match u1, u2 with + | None, None -> true + | Some l, Some l' -> l = l' + | _, _ -> false + +let rec constr_expr_eq e1 e2 = + if e1 == e2 then true + else match e1, e2 with + | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 + | CFix(_,id1,fl1), CFix(_,id2,fl2) -> + eq_located Id.equal id1 id2 && + List.equal fix_expr_eq fl1 fl2 + | CCoFix(_,id1,fl1), CCoFix(_,id2,fl2) -> + eq_located Id.equal id1 id2 && + List.equal cofix_expr_eq fl1 fl2 + | CProdN(_,bl1,a1), CProdN(_,bl2,a2) -> + List.equal binder_expr_eq bl1 bl2 && + constr_expr_eq a1 a2 + | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) -> + List.equal binder_expr_eq bl1 bl2 && + constr_expr_eq a1 a2 + | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) -> + Name.equal na1 na2 && + constr_expr_eq a1 a2 && + constr_expr_eq b1 b2 + | CAppExpl(_,(proj1,r1,_),al1), CAppExpl(_,(proj2,r2,_),al2) -> + Option.equal Int.equal proj1 proj2 && + eq_reference r1 r2 && + List.equal constr_expr_eq al1 al2 + | CApp(_,(proj1,e1),al1), CApp(_,(proj2,e2),al2) -> + Option.equal Int.equal proj1 proj2 && + constr_expr_eq e1 e2 && + List.equal args_eq al1 al2 + | CRecord (_, e1, l1), CRecord (_, e2, l2) -> + let field_eq (r1, e1) (r2, e2) = + eq_reference r1 r2 && constr_expr_eq e1 e2 + in + Option.equal constr_expr_eq e1 e2 && + List.equal field_eq l1 l2 + | CCases(_,_,r1,a1,brl1), CCases(_,_,r2,a2,brl2) -> + (** Don't care about the case_style *) + Option.equal constr_expr_eq r1 r2 && + List.equal case_expr_eq a1 a2 && + List.equal branch_expr_eq brl1 brl2 + | CLetTuple (_, n1, (m1, e1), t1, b1), CLetTuple (_, n2, (m2, e2), t2, b2) -> + List.equal (eq_located Name.equal) n1 n2 && + Option.equal (eq_located Name.equal) m1 m2 && + Option.equal constr_expr_eq e1 e2 && + constr_expr_eq t1 t2 && + constr_expr_eq b1 b2 + | CIf (_, e1, (n1, r1), t1, f1), CIf (_, e2, (n2, r2), t2, f2) -> + constr_expr_eq e1 e2 && + Option.equal (eq_located Name.equal) n1 n2 && + Option.equal constr_expr_eq r1 r2 && + constr_expr_eq t1 t2 && + constr_expr_eq f1 f2 + | CHole _, CHole _ -> true + | CPatVar(_,i1), CPatVar(_,i2) -> + Id.equal i1 i2 + | CEvar (_, id1, c1), CEvar (_, id2, c2) -> + Id.equal id1 id2 && List.equal instance_eq c1 c2 + | CSort(_,s1), CSort(_,s2) -> + Miscops.glob_sort_eq s1 s2 + | CCast(_,a1,(CastConv b1|CastVM b1)), CCast(_,a2,(CastConv b2|CastVM b2)) -> + constr_expr_eq a1 a2 && + constr_expr_eq b1 b2 + | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> + constr_expr_eq a1 a2 + | CNotation(_, n1, s1), CNotation(_, n2, s2) -> + String.equal n1 n2 && + constr_notation_substitution_eq s1 s2 + | CPrim(_,i1), CPrim(_,i2) -> + prim_token_eq i1 i2 + | CGeneralization (_, bk1, ak1, e1), CGeneralization (_, bk2, ak2, e2) -> + binding_kind_eq bk1 bk2 && + Option.equal abstraction_kind_eq ak1 ak2 && + constr_expr_eq e1 e2 + | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) -> + String.equal s1 s2 && + constr_expr_eq e1 e2 + | _ -> false + +and args_eq (a1,e1) (a2,e2) = + Option.equal (eq_located explicitation_eq) e1 e2 && + constr_expr_eq a1 a2 + +and case_expr_eq (e1, (n1, p1)) (e2, (n2, p2)) = + constr_expr_eq e1 e2 && + Option.equal (eq_located Name.equal) n1 n2 && + Option.equal cases_pattern_expr_eq p1 p2 + +and branch_expr_eq (_, p1, e1) (_, p2, e2) = + List.equal (eq_located (List.equal cases_pattern_expr_eq)) p1 p2 && + constr_expr_eq e1 e2 + +and binder_expr_eq ((n1, _, e1) : binder_expr) (n2, _, e2) = + (** Don't care about the [binder_kind] *) + List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 + +and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) = + (eq_located Id.equal id1 id2) && + Option.equal (eq_located Id.equal) j1 j2 && + recursion_order_expr_eq r1 r2 && + List.equal local_binder_eq bl1 bl2 && + constr_expr_eq a1 a2 && + constr_expr_eq b1 b2 + +and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = + (eq_located Id.equal id1 id2) && + List.equal local_binder_eq bl1 bl2 && + constr_expr_eq a1 a2 && + constr_expr_eq b1 b2 + +and recursion_order_expr_eq r1 r2 = match r1, r2 with +| CStructRec, CStructRec -> true +| CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 +| CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> + constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 +| _ -> false + +and local_binder_eq l1 l2 = match l1, l2 with +| LocalRawDef (n1, e1), LocalRawDef (n2, e2) -> + eq_located Name.equal n1 n2 && constr_expr_eq e1 e2 +| LocalRawAssum (n1, _, e1), LocalRawAssum (n2, _, e2) -> + (** Don't care about the [binder_kind] *) + List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 +| _ -> false + +and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = + List.equal constr_expr_eq e1 e2 && + List.equal (List.equal constr_expr_eq) el1 el2 && + List.equal (List.equal local_binder_eq) bl1 bl2 + +and instance_eq (x1,c1) (x2,c2) = + Id.equal x1 x2 && constr_expr_eq c1 c2 + +let constr_loc = function + | CRef (Ident (loc,_),_) -> loc + | CRef (Qualid (loc,_),_) -> loc + | CFix (loc,_,_) -> loc + | CCoFix (loc,_,_) -> loc + | CProdN (loc,_,_) -> loc + | CLambdaN (loc,_,_) -> loc + | CLetIn (loc,_,_,_) -> loc + | CAppExpl (loc,_,_) -> loc + | CApp (loc,_,_) -> loc + | CRecord (loc,_,_) -> loc + | CCases (loc,_,_,_,_) -> loc + | CLetTuple (loc,_,_,_,_) -> loc + | CIf (loc,_,_,_,_) -> loc + | CHole (loc,_,_,_) -> loc + | CPatVar (loc,_) -> loc + | CEvar (loc,_,_) -> loc + | CSort (loc,_) -> loc + | CCast (loc,_,_) -> loc + | CNotation (loc,_,_) -> loc + | CGeneralization (loc,_,_,_) -> loc + | CPrim (loc,_) -> loc + | CDelimiters (loc,_,_) -> loc + +let cases_pattern_expr_loc = function + | CPatAlias (loc,_,_) -> loc + | CPatCstr (loc,_,_,_) -> loc + | CPatAtom (loc,_) -> loc + | CPatOr (loc,_) -> loc + | CPatNotation (loc,_,_,_) -> loc + | CPatRecord (loc, _) -> loc + | CPatPrim (loc,_) -> loc + | CPatDelimiters (loc,_,_) -> loc + +let raw_cases_pattern_expr_loc = function + | RCPatAlias (loc,_,_) -> loc + | RCPatCstr (loc,_,_,_) -> loc + | RCPatAtom (loc,_) -> loc + | RCPatOr (loc,_) -> loc + +let local_binder_loc = function + | LocalRawAssum ((loc,_)::_,_,t) + | LocalRawDef ((loc,_),t) -> Loc.merge loc (constr_loc t) + | LocalRawAssum ([],_,_) -> assert false + +let local_binders_loc bll = match bll with + | [] -> Loc.ghost + | h :: l -> + Loc.merge (local_binder_loc h) (local_binder_loc (List.last bll)) + +(** Pseudo-constructors *) + +let mkIdentC id = CRef (Ident (Loc.ghost, id),None) +let mkRefC r = CRef (r,None) +let mkCastC (a,k) = CCast (Loc.ghost,a,k) +let mkLambdaC (idl,bk,a,b) = CLambdaN (Loc.ghost,[idl,bk,a],b) +let mkLetInC (id,a,b) = CLetIn (Loc.ghost,id,a,b) +let mkProdC (idl,bk,a,b) = CProdN (Loc.ghost,[idl,bk,a],b) + +let mkAppC (f,l) = + let l = List.map (fun x -> (x,None)) l in + match f with + | CApp (_,g,l') -> CApp (Loc.ghost, g, l' @ l) + | _ -> CApp (Loc.ghost, (None, f), l) + +let rec mkCProdN loc bll c = + match bll with + | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> + CProdN (loc,[idl,bk,t],mkCProdN (Loc.merge loc1 loc) bll c) + | LocalRawDef ((loc1,_) as id,b) :: bll -> + CLetIn (loc,id,b,mkCProdN (Loc.merge loc1 loc) bll c) + | [] -> c + | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c + +let rec mkCLambdaN loc bll c = + match bll with + | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> + CLambdaN (loc,[idl,bk,t],mkCLambdaN (Loc.merge loc1 loc) bll c) + | LocalRawDef ((loc1,_) as id,b) :: bll -> + CLetIn (loc,id,b,mkCLambdaN (Loc.merge loc1 loc) bll c) + | [] -> c + | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c + +let rec abstract_constr_expr c = function + | [] -> c + | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl) + | LocalRawAssum (idl,bk,t)::bl -> + List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl + (abstract_constr_expr c bl) + +let rec prod_constr_expr c = function + | [] -> c + | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl) + | LocalRawAssum (idl,bk,t)::bl -> + List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl + (prod_constr_expr c bl) + +let coerce_reference_to_id = function + | Ident (_,id) -> id + | Qualid (loc,_) -> + Errors.user_err_loc (loc, "coerce_reference_to_id", + str "This expression should be a simple identifier.") + +let coerce_to_id = function + | CRef (Ident (loc,id),_) -> (loc,id) + | a -> Errors.user_err_loc + (constr_loc a,"coerce_to_id", + str "This expression should be a simple identifier.") + +let coerce_to_name = function + | CRef (Ident (loc,id),_) -> (loc,Name id) + | CHole (loc,_,_,_) -> (loc,Anonymous) + | a -> Errors.user_err_loc + (constr_loc a,"coerce_to_name", + str "This expression should be a name.") diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli new file mode 100644 index 00000000..10c84b8d --- /dev/null +++ b/interp/constrexpr_ops.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* explicitation -> bool +(** Equality on [explicitation]. *) + +val constr_expr_eq : constr_expr -> constr_expr -> bool +(** Equality on [constr_expr]. This is a syntactical one, which is oblivious to + some parsing details, including locations. *) + +val local_binder_eq : local_binder -> local_binder -> bool +(** Equality on [local_binder]. Same properties as [constr_expr_eq]. *) + +val binding_kind_eq : Decl_kinds.binding_kind -> Decl_kinds.binding_kind -> bool +(** Equality on [binding_kind] *) + +val binder_kind_eq : binder_kind -> binder_kind -> bool +(** Equality on [binder_kind] *) + +(** {6 Retrieving locations} *) + +val constr_loc : constr_expr -> Loc.t +val cases_pattern_expr_loc : cases_pattern_expr -> Loc.t +val raw_cases_pattern_expr_loc : raw_cases_pattern_expr -> Loc.t +val local_binders_loc : local_binder list -> Loc.t + +(** {6 Constructors}*) + +val mkIdentC : Id.t -> constr_expr +val mkRefC : reference -> constr_expr +val mkAppC : constr_expr * constr_expr list -> constr_expr +val mkCastC : constr_expr * constr_expr cast_type -> constr_expr +val mkLambdaC : Name.t located list * binder_kind * constr_expr * constr_expr -> constr_expr +val mkLetInC : Name.t located * constr_expr * constr_expr -> constr_expr +val mkProdC : Name.t located list * binder_kind * constr_expr * constr_expr -> constr_expr + +val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr +val prod_constr_expr : constr_expr -> local_binder list -> constr_expr + +val mkCLambdaN : Loc.t -> local_binder list -> constr_expr -> constr_expr +(** Same as [abstract_constr_expr], with location *) + +val mkCProdN : Loc.t -> local_binder list -> constr_expr -> constr_expr +(** Same as [prod_constr_expr], with location *) + +(** {6 Destructors}*) + +val coerce_reference_to_id : reference -> Id.t +(** FIXME: nothing to do here *) + +val coerce_to_id : constr_expr -> Id.t located +(** Destruct terms of the form [CRef (Ident _)]. *) + +val coerce_to_name : constr_expr -> Name.t located +(** Destruct terms of the form [CRef (Ident _)] or [CHole _]. *) + +(** {6 Binder manipulation} *) + +val default_binder_kind : binder_kind + +val names_of_local_binders : local_binder list -> Name.t located list +(** Retrieve a list of binding names from a list of binders. *) + +val names_of_local_assums : local_binder list -> Name.t located list +(** Same as [names_of_local_binders], but does not take the [let] bindings into + account. *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 911d3741..58e1eb1d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* e - | Some sc -> CDelimiters (dummy_loc,sc,e) + | Some sc -> CDelimiters (Loc.ghost,sc,e) let insert_pat_delimiters loc p = function | None -> p @@ -134,8 +141,7 @@ let insert_pat_alias loc p = function (**********************************************************************) (* conversion of references *) -let extern_evar loc n l = - if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None) +let extern_evar loc n l = CEvar (loc,n,l) (** We allow customization of the global_reference printer. For instance, in the debugger the tables of global references @@ -151,124 +157,44 @@ let get_extern_reference () = !my_extern_reference let extern_reference loc vars l = !my_extern_reference loc vars l -let in_debugger = ref false - - -(************************************************************************) -(* Equality up to location (useful for translator v8) *) - -let rec check_same_pattern p1 p2 = - match p1, p2 with - | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) when i1=i2 -> - check_same_pattern a1 a2 - | CPatCstr(_,c1,a1), CPatCstr(_,c2,a2) when c1=c2 -> - List.iter2 check_same_pattern a1 a2 - | CPatCstrExpl(_,c1,a1), CPatCstrExpl(_,c2,a2) when c1=c2 -> - List.iter2 check_same_pattern a1 a2 - | CPatAtom(_,r1), CPatAtom(_,r2) when r1=r2 -> () - | CPatPrim(_,i1), CPatPrim(_,i2) when i1=i2 -> () - | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) when s1=s2 -> - check_same_pattern e1 e2 - | _ -> failwith "not same pattern" - -let check_same_ref r1 r2 = - match r1,r2 with - | Qualid(_,q1), Qualid(_,q2) when q1=q2 -> () - | Ident(_,i1), Ident(_,i2) when i1=i2 -> () - | _ -> failwith "not same ref" - -let rec check_same_type ty1 ty2 = - match ty1, ty2 with - | CRef r1, CRef r2 -> check_same_ref r1 r2 - | CFix(_,(_,id1),fl1), CFix(_,(_,id2),fl2) when id1=id2 -> - List.iter2 (fun (id1,i1,bl1,a1,b1) (id2,i2,bl2,a2,b2) -> - if id1<>id2 || i1<>i2 then failwith "not same fix"; - check_same_fix_binder bl1 bl2; - check_same_type a1 a2; - check_same_type b1 b2) - fl1 fl2 - | CCoFix(_,(_,id1),fl1), CCoFix(_,(_,id2),fl2) when id1=id2 -> - List.iter2 (fun (id1,bl1,a1,b1) (id2,bl2,a2,b2) -> - if id1<>id2 then failwith "not same fix"; - check_same_fix_binder bl1 bl2; - check_same_type a1 a2; - check_same_type b1 b2) - fl1 fl2 - | CArrow(_,a1,b1), CArrow(_,a2,b2) -> - check_same_type a1 a2; - check_same_type b1 b2 - | CProdN(_,bl1,a1), CProdN(_,bl2,a2) -> - List.iter2 check_same_binder bl1 bl2; - check_same_type a1 a2 - | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) -> - List.iter2 check_same_binder bl1 bl2; - check_same_type a1 a2 - | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) when na1=na2 -> - check_same_type a1 a2; - check_same_type b1 b2 - | CAppExpl(_,(proj1,r1),al1), CAppExpl(_,(proj2,r2),al2) when proj1=proj2 -> - check_same_ref r1 r2; - List.iter2 check_same_type al1 al2 - | CApp(_,(_,e1),al1), CApp(_,(_,e2),al2) -> - check_same_type e1 e2; - List.iter2 (fun (a1,e1) (a2,e2) -> - if e1<>e2 then failwith "not same expl"; - check_same_type a1 a2) al1 al2 - | CCases(_,_,_,a1,brl1), CCases(_,_,_,a2,brl2) -> - List.iter2 (fun (tm1,_) (tm2,_) -> check_same_type tm1 tm2) a1 a2; - List.iter2 (fun (_,pl1,r1) (_,pl2,r2) -> - List.iter2 (located_iter2 (List.iter2 check_same_pattern)) pl1 pl2; - check_same_type r1 r2) brl1 brl2 - | CHole _, CHole _ -> () - | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> () - | CSort(_,s1), CSort(_,s2) when s1=s2 -> () - | CCast(_,a1,CastConv (_,b1)), CCast(_,a2, CastConv(_,b2)) -> - check_same_type a1 a2; - check_same_type b1 b2 - | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> - check_same_type a1 a2 - | CNotation(_,n1,(e1,el1,bl1)), CNotation(_,n2,(e2,el2,bl2)) when n1=n2 -> - List.iter2 check_same_type e1 e2; - List.iter2 (List.iter2 check_same_type) el1 el2; - List.iter2 check_same_fix_binder bl1 bl2 - | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> () - | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 -> - check_same_type e1 e2 - | _ when ty1=ty2 -> () - | _ -> failwith "not same type" - -and check_same_binder (nal1,_,e1) (nal2,_,e2) = - List.iter2 (fun (_,na1) (_,na2) -> - if na1<>na2 then failwith "not same name") nal1 nal2; - check_same_type e1 e2 - -and check_same_fix_binder bl1 bl2 = - List.iter2 (fun b1 b2 -> - match b1,b2 with - LocalRawAssum(nal1,k,ty1), LocalRawAssum(nal2,k',ty2) -> - check_same_binder (nal1,k,ty1) (nal2,k',ty2) - | LocalRawDef(na1,def1), LocalRawDef(na2,def2) -> - check_same_binder ([na1],default_binder_kind,def1) ([na2],default_binder_kind,def2) - | _ -> failwith "not same binder") bl1 bl2 - -let is_same_type c d = - try let () = check_same_type c d in true - with Failure _ | Invalid_argument _ -> false - (**********************************************************************) (* mapping patterns to cases_pattern_expr *) +let add_patt_for_params ind l = + if !Flags.in_debugger then l else + Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CPatAtom (Loc.ghost,None)) l + +let drop_implicits_in_patt cst nb_expl args = + let impl_st = (implicits_of_global cst) in + let impl_data = extract_impargs_data impl_st in + let rec impls_fit l = function + |[],t -> Some (List.rev_append l t) + |_,[] -> None + |h::t,CPatAtom(_,None)::tt when is_status_implicit h -> impls_fit l (t,tt) + |h::_,_ when is_status_implicit h -> None + |_::t,hh::tt -> impls_fit (hh::l) (t,tt) + in let rec aux = function + |[] -> None + |(_,imps)::t -> match impls_fit [] (imps,args) with + |None -> aux t + |x -> x + in + if Int.equal nb_expl 0 then aux impl_data + else + let imps = List.skipn_at_least nb_expl (select_stronger_impargs impl_st) in + impls_fit [] (imps,args) + let has_curly_brackets ntn = - String.length ntn >= 6 & (String.sub ntn 0 6 = "{ _ } " or - String.sub ntn (String.length ntn - 6) 6 = " { _ }" or - string_string_contains ~where:ntn ~what:" { _ } ") + String.length ntn >= 6 && (String.is_sub "{ _ } " ntn 0 || + String.is_sub " { _ }" ntn (String.length ntn - 6) || + String.string_contains ~where:ntn ~what:" { _ } ") let rec wildcards ntn n = - if n = String.length ntn then [] - else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l + if Int.equal n (String.length ntn) then [] + else let l = spaces ntn (n+1) in if ntn.[n] == '_' then n::l else l and spaces ntn n = - if n = String.length ntn then [] - else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1) + if Int.equal n (String.length ntn) then [] + else if ntn.[n] == ' ' then wildcards ntn (n+1) else spaces ntn (n+1) let expand_curly_brackets loc mknot ntn l = let ntn' = ref ntn in @@ -278,7 +204,7 @@ let expand_curly_brackets loc mknot ntn l = | a::l -> let a' = let p = List.nth (wildcards !ntn' 0) i - 2 in - if p>=0 & p+5 <= String.length !ntn' & String.sub !ntn' p 5 = "{ _ }" + if p>=0 && p+5 <= String.length !ntn' && String.is_sub "{ _ }" !ntn' p then begin ntn' := String.sub !ntn' 0 p ^ "_" ^ @@ -304,128 +230,199 @@ let make_notation_gen loc ntn mknot mkprim destprim l = match decompose_notation_key ntn, l with | [Terminal "-"; Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) - with e when Errors.noncritical e -> mknot (loc,ntn,[])) + with Failure _ -> mknot (loc,ntn,[])) | [Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.of_string x)) - with e when Errors.noncritical e -> mknot (loc,ntn,[])) + with Failure _ -> mknot (loc,ntn,[])) | _ -> mknot (loc,ntn,l) let make_notation loc ntn (terms,termlists,binders as subst) = - if termlists <> [] or binders <> [] then CNotation (loc,ntn,subst) else - make_notation_gen loc ntn - (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[]))) - (fun (loc,p) -> CPrim (loc,p)) - destPrim terms + if not (List.is_empty termlists) || not (List.is_empty binders) then + CNotation (loc,ntn,subst) + else + make_notation_gen loc ntn + (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[]))) + (fun (loc,p) -> CPrim (loc,p)) + destPrim terms -let make_pat_notation loc ntn (terms,termlists as subst) = - if termlists <> [] then CPatNotation (loc,ntn,subst) else +let make_pat_notation loc ntn (terms,termlists as subst) args = + if not (List.is_empty termlists) then CPatNotation (loc,ntn,subst,args) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[]))) + (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[]),args)) (fun (loc,p) -> CPatPrim (loc,p)) destPatPrim terms let mkPat loc qid l = (* Normally irrelevant test with v8 syntax, but let's do it anyway *) - if l = [] then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,l) + if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,[],l) + +let pattern_printable_in_both_syntax (ind,_ as c) = + let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in + let nb_params = Inductiveops.inductive_nparams ind in + List.exists (fun (_,impls) -> + (List.length impls >= nb_params) && + let params,args = Util.List.chop nb_params impls in + (List.for_all is_status_implicit params)&&(List.for_all (fun x -> not (is_status_implicit x)) args) + ) impl_st (* Better to use extern_glob_constr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = + (* pboutill: There are letins in pat which is incompatible with notations and + not explicit application. *) + match pat with + | PatCstr(loc,cstrsp,args,na) + when !Flags.in_debugger||Inductiveops.constructor_has_local_defs cstrsp -> + let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in + let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) + | _ -> try - if !Flags.raw_print or !print_no_symbol then raise No_match; + if !Flags.raw_print || !print_no_symbol then raise No_match; let (na,sc,p) = uninterp_prim_token_cases_pattern pat in match availability_of_prim_token p sc scopes with - | None -> raise No_match - | Some key -> - let loc = cases_pattern_loc pat in - insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na - with No_match -> - try - if !Flags.raw_print or !print_no_symbol then raise No_match; - extern_symbol_pattern scopes vars pat - (uninterp_cases_pattern_notations pat) + | None -> raise No_match + | Some key -> + let loc = cases_pattern_loc pat in + insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na with No_match -> - match pat with - | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) - | PatVar (loc,Anonymous) -> CPatAtom (loc, None) - | PatCstr(loc,cstrsp,args,na) -> - let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - let p = - try - if !in_debugger || !Flags.raw_print then raise Exit; - let projs = Recordops.lookup_projections (fst cstrsp) in - let rec ip projs args acc = - match projs with - | [] -> acc - | None :: q -> ip q args acc - | Some c :: q -> - match args with - | [] -> raise No_match - | CPatAtom(_, None) :: tail -> ip q tail acc - (* we don't want to have 'x = _' in our patterns *) - | head :: tail -> ip q tail - ((extern_reference loc Idset.empty (ConstRef c), head) :: acc) + try + if !Flags.raw_print || !print_no_symbol then raise No_match; + extern_symbol_pattern scopes vars pat + (uninterp_cases_pattern_notations pat) + with No_match -> + match pat with + | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) + | PatVar (loc,Anonymous) -> CPatAtom (loc, None) + | PatCstr(loc,cstrsp,args,na) -> + let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + let p = + try + if !Flags.raw_print then raise Exit; + let projs = Recordops.lookup_projections (fst cstrsp) in + let rec ip projs args acc = + match projs with + | [] -> acc + | None :: q -> ip q args acc + | Some c :: q -> + match args with + | [] -> raise No_match + | CPatAtom(_, None) :: tail -> ip q tail acc + (* we don't want to have 'x = _' in our patterns *) + | head :: tail -> ip q tail + ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) + in + CPatRecord(loc, List.rev (ip projs args [])) + with + Not_found | No_match | Exit -> + let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in + if !Topconstr.oldfashion_patterns then + if pattern_printable_in_both_syntax cstrsp + then CPatCstr (loc, c, [], args) + else CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) + else + let full_args = add_patt_for_params (fst cstrsp) args in + match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with + |Some true_args -> CPatCstr (loc, c, [], true_args) + |None -> CPatCstr (loc, c, full_args, []) + in insert_pat_alias loc p na +and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) + (tmp_scope, scopes as allscopes) vars = + function + | NotationRule (sc,ntn) -> + begin + match availability_of_notation (sc,ntn) allscopes with + (* Uninterpretation is not allowed in current context *) + | None -> raise No_match + (* Uninterpretation is allowed in current context *) + | Some (scopt,key) -> + let scopes' = Option.List.cons scopt scopes in + let l = + List.map (fun (c,(scopt,scl)) -> + extern_cases_pattern_in_scope (scopt,scl@scopes') vars c) + subst in + let ll = + List.map (fun (c,(scopt,scl)) -> + let subscope = (scopt,scl@scopes') in + List.map (extern_cases_pattern_in_scope subscope vars) c) + substlist in + let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in + let l2' = if !Topconstr.oldfashion_patterns || not (List.is_empty ll) then l2 + else + match drop_implicits_in_patt gr nb_to_drop l2 with + |Some true_args -> true_args + |None -> raise No_match in - CPatRecord(loc, List.rev (ip projs args [])) - with - Not_found | No_match | Exit -> - CPatCstr (loc, extern_reference loc vars (ConstructRef cstrsp), args) in - insert_pat_alias loc p na - + insert_pat_delimiters loc + (make_pat_notation loc ntn (l,ll) l2') key + end + | SynDefRule kn -> + let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in + let l1 = + List.rev_map (fun (c,(scopt,scl)) -> + extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) + subst in + let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in + let l2' = if !Topconstr.oldfashion_patterns then l2 + else + match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with + |Some true_args -> true_args + |None -> raise No_match + in + assert (List.is_empty substlist); + mkPat loc qid (List.rev_append l1 l2') and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try - match t,n with - | PatCstr (loc,(ind,_),l,na), n when (n = Some 0 or n = None or - n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams) - && (match keyrule with SynDefRule _ -> true | _ -> false) -> - (* Abbreviation for the constructor name only *) - (match keyrule with - | NotationRule _ -> assert false - | SynDefRule kn -> - let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in - let l = List.map (extern_cases_pattern_in_scope allscopes vars) l in - insert_pat_alias loc (mkPat loc qid l) na) - | PatCstr (_,f,l,_), Some n when List.length l > n -> - raise No_match - | PatCstr (loc,_,_,na),_ -> - (* Try matching ... *) - let subst,substlist = match_aconstr_cases_pattern t pat in - (* Try availability of interpretation ... *) - let p = match keyrule with - | NotationRule (sc,ntn) -> - (match availability_of_notation (sc,ntn) allscopes with - (* Uninterpretation is not allowed in current context *) - | None -> raise No_match - (* Uninterpretation is allowed in current context *) - | Some (scopt,key) -> - let scopes' = Option.List.cons scopt scopes in - let l = - List.map (fun (c,(scopt,scl)) -> - extern_cases_pattern_in_scope (scopt,scl@scopes') vars c) - subst in - let ll = - List.map (fun (c,(scopt,scl)) -> - let subscope = (scopt,scl@scopes') in - List.map (extern_cases_pattern_in_scope subscope vars) c) - substlist in - insert_pat_delimiters loc - (make_pat_notation loc ntn (l,ll)) key) - | SynDefRule kn -> - let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in - let l = - List.map (fun (c,(scopt,scl)) -> - extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) - subst in - assert (substlist = []); - mkPat loc qid l in - insert_pat_alias loc p na - | PatVar (loc,Anonymous),_ -> CPatAtom (loc, None) - | PatVar (loc,Name id),_ -> CPatAtom (loc, Some (Ident (loc,id))) + if List.mem keyrule !print_non_active_notations then raise No_match; + match t with + | PatCstr (loc,cstr,_,na) -> + let p = apply_notation_to_pattern loc (ConstructRef cstr) + (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in + insert_pat_alias loc p na + | PatVar (loc,Anonymous) -> CPatAtom (loc, None) + | PatVar (loc,Name id) -> CPatAtom (loc, Some (Ident (loc,id))) with No_match -> extern_symbol_pattern allscopes vars t rules +let rec extern_symbol_ind_pattern allscopes vars ind args = function + | [] -> raise No_match + | (keyrule,pat,n as _rule)::rules -> + try + if List.mem keyrule !print_non_active_notations then raise No_match; + apply_notation_to_pattern Loc.ghost (IndRef ind) + (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule + with + No_match -> extern_symbol_ind_pattern allscopes vars ind args rules + +let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = + (* pboutill: There are letins in pat which is incompatible with notations and + not explicit application. *) + if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then + let c = extern_reference Loc.ghost vars (IndRef ind) in + let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + CPatCstr (Loc.ghost, c, add_patt_for_params ind args, []) + else + try + if !Flags.raw_print || !print_no_symbol then raise No_match; + let (sc,p) = uninterp_prim_token_ind_pattern ind args in + match availability_of_prim_token p sc scopes with + | None -> raise No_match + | Some key -> + insert_pat_delimiters Loc.ghost (CPatPrim(Loc.ghost,p)) key + with No_match -> + try + if !Flags.raw_print || !print_no_symbol then raise No_match; + extern_symbol_ind_pattern scopes vars ind args + (uninterp_ind_pattern_notations ind) + with No_match -> + let c = extern_reference Loc.ghost vars (IndRef ind) in + let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + match drop_implicits_in_patt (IndRef ind) 0 args with + |Some true_args -> CPatCstr (Loc.ghost, c, [], true_args) + |None -> CPatCstr (Loc.ghost, c, args, []) + let extern_cases_pattern vars p = extern_cases_pattern_in_scope (None,[]) vars p @@ -438,20 +435,32 @@ let occur_name na aty = | Anonymous -> false let is_projection nargs = function - | Some r when not !Flags.raw_print & !print_projections -> - (try - let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then Some n else None - with Not_found -> None) + | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> + (try + let n = Recordops.find_projection_nparams r + 1 in + if n <= nargs then None + else Some n + with Not_found -> None) | _ -> None - -let is_hole = function CHole _ -> true | _ -> false + +let is_hole = function CHole _ | CEvar _ -> true | _ -> false let is_significant_implicit a = not (is_hole a) let is_needed_for_correct_partial_application tail imp = - tail = [] & not (maximal_insertion_of imp) + List.is_empty tail && not (maximal_insertion_of imp) + +exception Expl + +let params_implicit n impl = + let rec aux n impl = + if n == 0 then true + else match impl with + | [] -> false + | imp :: impl when is_status_implicit imp -> aux (pred n) impl + | _ -> false + in aux n impl (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) @@ -462,55 +471,70 @@ let explicitize loc inctx impl (cf,f) args = | a::args, imp::impl when is_status_implicit imp -> let tail = exprec (q+1) (args,impl) in let visible = - !Flags.raw_print or - (!print_implicits & !print_implicits_explicit_args) or - (is_needed_for_correct_partial_application tail imp) or - (!print_implicits_defensive & - is_significant_implicit a & + !Flags.raw_print || + (!print_implicits && !print_implicits_explicit_args) || + (is_needed_for_correct_partial_application tail imp) || + (!print_implicits_defensive && + is_significant_implicit a && not (is_inferable_implicit inctx n imp)) in if visible then - (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail + (a,Some (Loc.ghost, ExplByName (name_of_implicit imp))) :: tail else tail | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl) | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) - | [], _ -> [] in - match is_projection (List.length args) cf with - | Some i as ip -> - if impl <> [] & is_status_implicit (List.nth impl (i-1)) then - let f' = match f with CRef f -> f | _ -> assert false in - CAppExpl (loc,(ip,f'),args) - else - let (args1,args2) = list_chop i args in - let (impl1,impl2) = if impl=[] then [],[] else list_chop i impl in - let args1 = exprec 1 (args1,impl1) in - let args2 = exprec (i+1) (args2,impl2) in - CApp (loc,(Some (List.length args1),f),args1@args2) + | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> + (* The non-explicit application cannot be parsed back with the same type *) + raise Expl + | [], _ -> [] + in + let ip = is_projection (List.length args) cf in + let expl () = + match ip with + | Some i -> + if not (List.is_empty impl) && is_status_implicit (List.nth impl (i-1)) then + raise Expl + else + let (args1,args2) = List.chop i args in + let (impl1,impl2) = if List.is_empty impl then [],[] else List.chop i impl in + let args1 = exprec 1 (args1,impl1) in + let args2 = exprec (i+1) (args2,impl2) in + let ip = Some (List.length args1) in + CApp (loc,(ip,f),args1@args2) | None -> - let args = exprec 1 (args,impl) in - if args = [] then f else CApp (loc, (None, f), args) - -let extern_global loc impl f = - if not !Constrintern.parsing_explicit && - impl <> [] && List.for_all is_status_implicit impl + let args = exprec 1 (args,impl) in + if List.is_empty args then f else CApp (loc, (None, f), args) + in + try expl () + with Expl -> + let f',us = match f with CRef (f,us) -> f,us | _ -> assert false in + let ip = if !print_projections then ip else None in + CAppExpl (loc, (ip, f', us), args) + +let is_start_implicit = function + | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp + | [] -> false + +let extern_global loc impl f us = + if not !Constrintern.parsing_explicit && is_start_implicit impl then - CAppExpl (loc, (None, f), []) - else - CRef f - -let extern_app loc inctx impl (cf,f) args = - if args = [] (* maybe caused by a hidden coercion *) then - extern_global loc impl f + CAppExpl (loc, (None, f, us), []) else - if not !Constrintern.parsing_explicit && - ((!Flags.raw_print or - (!print_implicits & not !print_implicits_explicit_args)) & + CRef (f,us) + +let extern_app loc inctx impl (cf,f) us args = + if List.is_empty args then + (* If coming from a notation "Notation a := @b" *) + CAppExpl (loc, (None, f, us), []) + else if not !Constrintern.parsing_explicit && + ((!Flags.raw_print || + (!print_implicits && not !print_implicits_explicit_args)) && List.exists is_status_implicit impl) then - CAppExpl (loc, (is_projection (List.length args) cf, f), args) + CAppExpl (loc, (is_projection (List.length args) cf,f,us), args) else - explicitize loc inctx impl (cf,CRef f) args + explicitize loc inctx impl (cf,CRef (f,us)) args let rec extern_args extern scopes env args subscopes = match args with @@ -521,15 +545,19 @@ let rec extern_args extern scopes env args subscopes = | scopt::subscopes -> (scopt,scopes), subscopes in extern argscopes env a :: extern_args extern scopes env args subscopes -let rec remove_coercions inctx = function - | GApp (loc,GRef (_,r),args) as c - when not (!Flags.raw_print or !print_coercions) - -> + +let match_coercion_app = function + | GApp (loc,GRef (_,r,_),args) -> Some (loc, r, 0, args) + | _ -> None + +let rec remove_coercions inctx c = + match match_coercion_app c with + | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in (try match Classops.hide_coercion r with - | Some n when n < nargs && (inctx or n+1 < nargs) -> + | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> (* We skip a coercion *) - let l = list_skipn n args in + let l = List.skipn (n - pars) args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in (* Recursively remove the head coercions *) let a' = remove_coercions true a in @@ -541,10 +569,10 @@ let rec remove_coercions inctx = function been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) - if l = [] then a' else GApp (loc,a',l) + if List.is_empty l then a' else GApp (loc,a',l) | _ -> c with Not_found -> c) - | c -> c + | _ -> c let rec flatten_application = function | GApp (loc,GApp(_,a,l'),l) -> flatten_application (GApp (loc,a,l'@l)) @@ -574,38 +602,44 @@ let extern_optimal_prim_token scopes r r' = (* mapping glob_constr to constr_expr *) let extern_glob_sort = function - | GProp _ as s -> s - | GType (Some _) as s when !print_universes -> s - | GType _ -> GType None + | GProp -> GProp + | GSet -> GSet + | GType _ as s when !print_universes -> s + | GType _ -> GType [] +let extern_universes = function + | Some _ as l when !print_universes -> l + | _ -> None + let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try - if !Flags.raw_print or !print_no_symbol then raise No_match; + if !Flags.raw_print || !print_no_symbol then raise No_match; extern_optimal_prim_token scopes r r' with No_match -> try let r'' = flatten_application r' in - if !Flags.raw_print or !print_no_symbol then raise No_match; + if !Flags.raw_print || !print_no_symbol then raise No_match; extern_symbol scopes vars r'' (uninterp_notations r'') with No_match -> match r' with - | GRef (loc,ref) -> + | GRef (loc,ref,us) -> extern_global loc (select_stronger_impargs (implicits_of_global ref)) - (extern_reference loc vars ref) + (extern_reference loc vars ref) (extern_universes us) - | GVar (loc,id) -> CRef (Ident (loc,id)) + | GVar (loc,id) -> CRef (Ident (loc,id),None) - | GEvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None) + | GEvar (loc,n,[]) when !print_meta_as_hole -> CHole (loc, None, Misctypes.IntroAnonymous, None) | GEvar (loc,n,l) -> - extern_evar loc n (Option.map (List.map (extern false scopes vars)) l) + extern_evar loc n (List.map (on_snd (extern false scopes vars)) l) - | GPatVar (loc,n) -> - if !print_meta_as_hole then CHole (loc, None) else CPatVar (loc,n) + | GPatVar (loc,(b,n)) -> + if !print_meta_as_hole then CHole (loc, None, Misctypes.IntroAnonymous, None) else + if b then CPatVar (loc,n) else CEvar (loc,n,[]) | GApp (loc,f,args) -> (match f with - | GRef (rloc,ref) -> + | GRef (rloc,ref,us) -> let subscopes = find_arguments_scope ref in let args = extern_args (extern true) (snd scopes) vars args subscopes in @@ -623,7 +657,7 @@ let rec extern inctx scopes vars r = let projs = struc.Recordops.s_PROJ in let locals = struc.Recordops.s_PROJKIND in let rec cut args n = - if n = 0 then args + if Int.equal n 0 then args else match args with | [] -> raise No_match @@ -635,7 +669,7 @@ let rec extern inctx scopes vars r = | None :: q -> raise No_match | Some c :: q -> match locs with - | [] -> anomaly "projections corruption [Constrextern.extern]" + | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern]") | (_, false) :: locs' -> (* we don't want to print locals *) ip q locs' args acc @@ -644,92 +678,93 @@ let rec extern inctx scopes vars r = | [] -> raise No_match (* we give up since the constructor is not complete *) | head :: tail -> ip q locs' tail - ((extern_reference loc Idset.empty (ConstRef c), head) :: acc) + ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) in CRecord (loc, None, List.rev (ip projs locals args [])) with | Not_found | No_match | Exit -> extern_app loc inctx (select_stronger_impargs (implicits_of_global ref)) - (Some ref,extern_reference rloc vars ref) args + (Some ref,extern_reference rloc vars ref) (extern_universes us) args end + | _ -> - explicitize loc inctx [] (None,sub_extern false scopes vars f) - (List.map (sub_extern true scopes vars) args)) - - | GProd (loc,Anonymous,_,t,c) -> - (* Anonymous product are never factorized *) - CArrow (loc,extern_typ scopes vars t, extern_typ scopes vars c) + explicitize loc inctx [] (None,sub_extern false scopes vars f) + (List.map (sub_extern true scopes vars) args)) | GLetIn (loc,na,t,c) -> CLetIn (loc,(loc,na),sub_extern false scopes vars t, extern inctx scopes (add_vname vars na) c) | GProd (loc,na,bk,t,c) -> - let t = extern_typ scopes vars (anonymize_if_reserved na t) in + let t = extern_typ scopes vars t in let (idl,c) = factorize_prod scopes (add_vname vars na) na bk t c in - CProdN (loc,[(dummy_loc,na)::idl,Default bk,t],c) + CProdN (loc,[(Loc.ghost,na)::idl,Default bk,t],c) | GLambda (loc,na,bk,t,c) -> - let t = extern_typ scopes vars (anonymize_if_reserved na t) in + let t = extern_typ scopes vars t in let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) na bk t c in - CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c) + CLambdaN (loc,[(Loc.ghost,na)::idl,Default bk,t],c) | GCases (loc,sty,rtntypopt,tml,eqns) -> - let vars' = - List.fold_right (name_fold Idset.add) - (cases_predicate_names tml) vars in - let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in - let tml = List.map (fun (tm,(na,x)) -> - let na' = match na,tm with - Anonymous, GVar (_,id) when - rtntypopt<>None & occur_glob_constr id (Option.get rtntypopt) - -> Some (dummy_loc,Anonymous) - | Anonymous, _ -> None - | Name id, GVar (_,id') when id=id' -> None - | Name _, _ -> Some (dummy_loc,na) in - (sub_extern false scopes vars tm, - (na',Option.map (fun (loc,ind,n,nal) -> - let params = list_tabulate - (fun _ -> GHole (dummy_loc,Evd.InternalHole)) n in - let args = List.map (function - | Anonymous -> GHole (dummy_loc,Evd.InternalHole) - | Name id -> GVar (dummy_loc,id)) nal in - let t = GApp (dummy_loc,GRef (dummy_loc,IndRef ind),params@args) in - (extern_typ scopes vars t)) x))) tml in - let eqns = List.map (extern_eqn inctx scopes vars) eqns in - CCases (loc,sty,rtntypopt',tml,eqns) + let vars' = + List.fold_right (name_fold Id.Set.add) + (cases_predicate_names tml) vars in + let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in + let tml = List.map (fun (tm,(na,x)) -> + let na' = match na,tm with + | Anonymous, GVar (_, id) -> + begin match rtntypopt with + | None -> None + | Some ntn -> + if occur_glob_constr id ntn then + Some (Loc.ghost, Anonymous) + else None + end + | Anonymous, _ -> None + | Name id, GVar (_,id') when Id.equal id id' -> None + | Name _, _ -> Some (Loc.ghost,na) in + (sub_extern false scopes vars tm, + (na',Option.map (fun (loc,ind,nal) -> + let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in + let fullargs = + if !Flags.in_debugger then args else + Notation_ops.add_patterns_for_params ind args in + extern_ind_pattern_in_scope scopes vars ind fullargs + ) x))) tml in + let eqns = List.map (extern_eqn inctx scopes vars) eqns in + CCases (loc,sty,rtntypopt',tml,eqns) | GLetTuple (loc,nal,(na,typopt),tm,b) -> - CLetTuple (loc,List.map (fun na -> (dummy_loc,na)) nal, - (Option.map (fun _ -> (dummy_loc,na)) typopt, + CLetTuple (loc,List.map (fun na -> (Loc.ghost,na)) nal, + (Option.map (fun _ -> (Loc.ghost,na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern false scopes vars tm, extern inctx scopes (List.fold_left add_vname vars nal) b) | GIf (loc,c,(na,typopt),b1,b2) -> CIf (loc,sub_extern false scopes vars c, - (Option.map (fun _ -> (dummy_loc,na)) typopt, + (Option.map (fun _ -> (Loc.ghost,na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) | GRec (loc,fk,idv,blv,tyv,bv) -> - let vars' = Array.fold_right Idset.add idv vars in + let vars' = Array.fold_right Id.Set.add idv vars in (match fk with | GFix (nv,n) -> let listdecl = Array.mapi (fun i fi -> let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let (assums,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (name_fold Idset.add) ids vars in - let vars1 = List.fold_right (name_fold Idset.add) ids vars' in + let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in + let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in let n = match fst nv.(i) with | None -> None - | Some x -> Some (dummy_loc, out_name (List.nth assums x)) + | Some x -> Some (Loc.ghost, out_name (List.nth assums x)) in let ro = extern_recursion_order scopes vars (snd nv.(i)) in - ((dummy_loc, fi), (n, ro), bl, extern_typ scopes vars0 ty, + ((Loc.ghost, fi), (n, ro), bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv in CFix (loc,(loc,idv.(n)),Array.to_list listdecl) @@ -737,21 +772,20 @@ let rec extern inctx scopes vars r = let listdecl = Array.mapi (fun i fi -> let (_,ids,bl) = extern_local_binder scopes vars blv.(i) in - let vars0 = List.fold_right (name_fold Idset.add) ids vars in - let vars1 = List.fold_right (name_fold Idset.add) ids vars' in - ((dummy_loc, fi),bl,extern_typ scopes vars0 tyv.(i), + let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in + let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in + ((Loc.ghost, fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern false scopes vars1 bv.(i))) idv in CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl)) | GSort (loc,s) -> CSort (loc,extern_glob_sort s) - | GHole (loc,e) -> CHole (loc, Some e) + | GHole (loc,e,naming,_) -> CHole (loc, Some e, naming, None) (** TODO: extern tactics. *) - | GCast (loc,c, CastConv (k,t)) -> - CCast (loc,sub_extern true scopes vars c, CastConv (k,extern_typ scopes vars t)) - | GCast (loc,c, CastCoerce) -> - CCast (loc,sub_extern true scopes vars c, CastCoerce) + | GCast (loc,c, c') -> + CCast (loc,sub_extern true scopes vars c, + Miscops.map_cast_type (extern_typ scopes vars) c') and extern_typ (_,scopes) = extern true (Some Notation.type_scope,scopes) @@ -762,8 +796,8 @@ and factorize_prod scopes vars na bk aty c = let c = extern_typ scopes vars c in match na, c with | Name id, CProdN (loc,[nal,Default bk',ty],c) - when bk = bk' && is_same_type aty ty - & not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> + when binding_kind_eq bk bk' && constr_expr_eq aty ty + && not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> nal,c | _ -> [],c @@ -772,8 +806,8 @@ and factorize_lambda inctx scopes vars na bk aty c = let c = sub_extern inctx scopes vars c in match c with | CLambdaN (loc,[nal,Default bk',ty],c) - when bk = bk' && is_same_type aty ty - & not (occur_name na ty) (* avoid na in ty escapes scope *) -> + when binding_kind_eq bk bk' && constr_expr_eq aty ty + && not (occur_name na ty) (* avoid na in ty escapes scope *) -> nal,c | _ -> [],c @@ -782,22 +816,22 @@ and extern_local_binder scopes vars = function [] -> ([],[],[]) | (na,bk,Some bd,ty)::l -> let (assums,ids,l) = - extern_local_binder scopes (name_fold Idset.add na vars) l in + extern_local_binder scopes (name_fold Id.Set.add na vars) l in (assums,na::ids, - LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l) + LocalRawDef((Loc.ghost,na), extern false scopes vars bd) :: l) | (na,bk,None,ty)::l -> - let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in - (match extern_local_binder scopes (name_fold Idset.add na vars) l with + let ty = extern_typ scopes vars ty in + (match extern_local_binder scopes (name_fold Id.Set.add na vars) l with (assums,ids,LocalRawAssum(nal,k,ty')::l) - when is_same_type ty ty' & + when constr_expr_eq ty ty' && match na with Name id -> not (occur_var_constr_expr id ty') | _ -> true -> (na::assums,na::ids, - LocalRawAssum((dummy_loc,na)::nal,k,ty')::l) + LocalRawAssum((Loc.ghost,na)::nal,k,ty')::l) | (assums,ids,l) -> (na::assums,na::ids, - LocalRawAssum([(dummy_loc,na)],Default bk,ty) :: l)) + LocalRawAssum([(Loc.ghost,na)],Default bk,ty) :: l)) and extern_eqn inctx scopes vars (loc,ids,pl,c) = (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], @@ -806,42 +840,42 @@ and extern_eqn inctx scopes vars (loc,ids,pl,c) = and extern_symbol (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> - let loc = Glob_term.loc_of_glob_constr t in + let loc = Glob_ops.loc_of_glob_constr t in try + if List.mem keyrule !print_non_active_notations then raise No_match; (* Adjusts to the number of arguments expected by the notation *) let (t,args,argsscopes,argsimpls) = match t,n with | GApp (_,f,args), Some n when List.length args >= n -> - let args1, args2 = list_chop n args in + let args1, args2 = List.chop n args in let subscopes, impls = match f with - | GRef (_,ref) -> + | GRef (_,ref,us) -> let subscopes = - try list_skipn n (find_arguments_scope ref) - with e when Errors.noncritical e -> [] in + try List.skipn n (find_arguments_scope ref) + with Failure _ -> [] in let impls = let impls = select_impargs_size (List.length args) (implicits_of_global ref) in - try list_skipn n impls - with e when Errors.noncritical e -> [] in + try List.skipn n impls with Failure _ -> [] in subscopes,impls | _ -> [], [] in - (if n = 0 then f else GApp (dummy_loc,f,args1)), + (if Int.equal n 0 then f else GApp (Loc.ghost,f,args1)), args2, subscopes, impls - | GApp (_,(GRef (_,ref) as f),args), None -> + | GApp (_,(GRef (_,ref,us) as f),args), None -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls - | GRef _, Some 0 -> GApp (dummy_loc,t,[]), [], [], [] + | GRef (_,ref,us), Some 0 -> GApp (Loc.ghost,t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) let terms,termlists,binders = - match_aconstr !print_universes t pat in + match_notation_constr !print_universes t pat in (* Try availability of interpretation ... *) let e = match keyrule with @@ -871,9 +905,9 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> extern true (scopt,scl@scopes) vars c, None) terms in - let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in - if l = [] then a else CApp (loc,(None,a),l) in - if args = [] then e + let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn),None) in + if List.is_empty l then a else CApp (loc,(None,a),l) in + if List.is_empty args then e else let args = extern_args (extern true) scopes vars args argsscopes in explicitize loc false argsimpls (None,e) args @@ -896,9 +930,9 @@ let extern_glob_type vars c = (******************************************************************) (* Main translation function from constr -> constr_expr *) -let loc = dummy_loc (* for constr and pattern, locations are lost *) +let loc = Loc.ghost (* for constr and pattern, locations are lost *) -let extern_constr_gen goal_concl_style scopt env t = +let extern_constr_gen lax goal_concl_style scopt env sigma t = (* "goal_concl_style" means do alpha-conversion using the "goal" convention *) (* i.e.: avoid using the names of goal/section/rel variables and the short *) (* names of global definitions of current module when computing names for *) @@ -907,87 +941,99 @@ let extern_constr_gen goal_concl_style scopt env t = (* those goal/section/rel variables that occurs in the subterm under *) (* consideration; see namegen.ml for further details *) let avoid = if goal_concl_style then ids_of_context env else [] in - let rel_env_names = names_of_rel_context env in - let r = Detyping.detype goal_concl_style avoid rel_env_names t in + let r = Detyping.detype ~lax:lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in extern false (scopt,[]) vars r -let extern_constr_in_scope goal_concl_style scope env t = - extern_constr_gen goal_concl_style (Some scope) env t +let extern_constr_in_scope goal_concl_style scope env sigma t = + extern_constr_gen false goal_concl_style (Some scope) env sigma t -let extern_constr goal_concl_style env t = - extern_constr_gen goal_concl_style None env t +let extern_constr ?(lax=false) goal_concl_style env sigma t = + extern_constr_gen lax goal_concl_style None env sigma t -let extern_type goal_concl_style env t = +let extern_type goal_concl_style env sigma t = let avoid = if goal_concl_style then ids_of_context env else [] in - let rel_env_names = names_of_rel_context env in - let r = Detyping.detype goal_concl_style avoid rel_env_names t in + let r = Detyping.detype goal_concl_style avoid env sigma t in extern_glob_type (vars_of_env env) r -let extern_sort s = extern_glob_sort (detype_sort s) +let extern_sort sigma s = extern_glob_sort (detype_sort sigma s) + +let extern_closed_glob ?lax goal_concl_style env sigma t = + let avoid = if goal_concl_style then ids_of_context env else [] in + let r = + Detyping.detype_closed_glob ?lax goal_concl_style avoid env sigma t + in + let vars = vars_of_env env in + extern false (None,[]) vars r (******************************************************************) (* Main translation function from pattern -> constr_expr *) let any_any_branch = (* | _ => _ *) - (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evd.InternalHole)) + (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) -let rec glob_of_pat env = function - | PRef ref -> GRef (loc,ref) +let rec glob_of_pat env sigma = function + | PRef ref -> GRef (loc,ref,None) | PVar id -> GVar (loc,id) - | PEvar (n,l) -> GEvar (loc,n,Some (array_map_to_list (glob_of_pat env) l)) + | PEvar (evk,l) -> + let test id = function PVar id' -> Id.equal id id' | _ -> false in + let l = Evd.evar_instance_array test (Evd.find sigma evk) l in + let id = Evd.evar_ident evk sigma in + GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l) | PRel n -> let id = try match lookup_name_of_rel n env with | Name id -> id | Anonymous -> - anomaly "glob_constr_of_pattern: index to an anonymous variable" - with Not_found -> id_of_string ("_UNBOUND_REL_"^(string_of_int n)) in + anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable") + with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in GVar (loc,id) - | PMeta None -> GHole (loc,Evd.InternalHole) + | PMeta None -> GHole (loc,Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) | PMeta (Some n) -> GPatVar (loc,(false,n)) + | PProj (p,c) -> GApp (loc,GRef (loc, ConstRef (Projection.constant p),None), + [glob_of_pat env sigma c]) | PApp (f,args) -> - GApp (loc,glob_of_pat env f,array_map_to_list (glob_of_pat env) args) + GApp (loc,glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) | PSoApp (n,args) -> GApp (loc,GPatVar (loc,(true,n)), - List.map (glob_of_pat env) args) + List.map (glob_of_pat env sigma) args) | PProd (na,t,c) -> - GProd (loc,na,Explicit,glob_of_pat env t,glob_of_pat (na::env) c) + GProd (loc,na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) | PLetIn (na,t,c) -> - GLetIn (loc,na,glob_of_pat env t, glob_of_pat (na::env) c) + GLetIn (loc,na,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c) | PLambda (na,t,c) -> - GLambda (loc,na,Explicit,glob_of_pat env t, glob_of_pat (na::env) c) + GLambda (loc,na,Explicit,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c) | PIf (c,b1,b2) -> - GIf (loc, glob_of_pat env c, (Anonymous,None), - glob_of_pat env b1, glob_of_pat env b2) - | PCase ({cip_style=LetStyle; cip_ind_args=None},PMeta None,tm,[(0,n,b)]) -> - let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env b) in - GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env tm,b) + GIf (loc, glob_of_pat env sigma c, (Anonymous,None), + glob_of_pat env sigma b1, glob_of_pat env sigma b2) + | PCase ({cip_style=LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> + let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env sigma b) in + GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] | _, Some ind -> - let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env c)) bl in + let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env sigma c)) bl in simple_cases_matrix_of_branches ind bl' - | _, None -> anomaly "PCase with some branches but unknown inductive" + | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive") in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in - let indnames,rtn = match p, info.cip_ind, info.cip_ind_args with + let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with | PMeta None, _, _ -> (Anonymous,None),None - | _, Some ind, Some (nparams,nargs) -> - return_type_of_predicate ind nparams nargs (glob_of_pat env p) - | _ -> anomaly "PCase with non-trivial predicate but unknown inductive" + | _, Some ind, Some nargs -> + return_type_of_predicate ind nargs (glob_of_pat env sigma p) + | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive") in - GCases (loc,RegularStyle,rtn,[glob_of_pat env tm,indnames],mat) - | PFix f -> Detyping.detype false [] env (mkFix f) - | PCoFix c -> Detyping.detype false [] env (mkCoFix c) + GCases (loc,RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) + | PFix f -> Detyping.detype_names false [] env (Global.env()) sigma (mkFix f) (** FIXME bad env *) + | PCoFix c -> Detyping.detype_names false [] env (Global.env()) sigma (mkCoFix c) | PSort s -> GSort (loc,s) -let extern_constr_pattern env pat = - extern true (None,[]) Idset.empty (glob_of_pat env pat) +let extern_constr_pattern env sigma pat = + extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat) -let extern_rel_context where env sign = - let a = detype_rel_context where [] (names_of_rel_context env) sign in +let extern_rel_context where env sigma sign = + let a = detype_rel_context where [] (names_of_rel_context env,env) sigma sign in let vars = vars_of_env env in pi3 (extern_local_binder (None,[]) vars a) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 8933d3af..b797e455 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -1,43 +1,47 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr_expr -> bool +open Misctypes (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) -val extern_cases_pattern : Idset.t -> cases_pattern -> cases_pattern_expr -val extern_glob_constr : Idset.t -> glob_constr -> constr_expr -val extern_glob_type : Idset.t -> glob_constr -> constr_expr -val extern_constr_pattern : names_context -> constr_pattern -> constr_expr +val extern_cases_pattern : Id.Set.t -> cases_pattern -> cases_pattern_expr +val extern_glob_constr : Id.Set.t -> glob_constr -> constr_expr +val extern_glob_type : Id.Set.t -> glob_constr -> constr_expr +val extern_constr_pattern : names_context -> Evd.evar_map -> + constr_pattern -> constr_expr +val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob_constr -> constr_expr (** If [b=true] in [extern_constr b env c] then the variables in the first - level of quantification clashing with the variables in [env] are renamed *) + level of quantification clashing with the variables in [env] are renamed. + ~lax is for debug printing, when the constr might not be well typed in + env, sigma +*) -val extern_constr : bool -> env -> constr -> constr_expr -val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr -val extern_reference : loc -> Idset.t -> global_reference -> reference -val extern_type : bool -> env -> types -> constr_expr -val extern_sort : sorts -> glob_sort -val extern_rel_context : constr option -> env -> +val extern_constr : ?lax:bool -> bool -> env -> Evd.evar_map -> constr -> constr_expr +val extern_constr_in_scope : bool -> scope_name -> env -> Evd.evar_map -> constr -> constr_expr +val extern_reference : Loc.t -> Id.Set.t -> global_reference -> reference +val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr +val extern_sort : Evd.evar_map -> sorts -> glob_sort +val extern_rel_context : constr option -> env -> Evd.evar_map -> rel_context -> local_binder list (** Printing options *) @@ -52,11 +56,9 @@ val print_projections : bool ref (** Customization of the global_reference printer *) val set_extern_reference : - (loc -> Idset.t -> global_reference -> reference) -> unit + (Loc.t -> Id.Set.t -> global_reference -> reference) -> unit val get_extern_reference : - unit -> (loc -> Idset.t -> global_reference -> reference) - -val in_debugger : bool ref + unit -> (Loc.t -> Id.Set.t -> global_reference -> reference) (** This governs printing of implicit arguments. If [with_implicits] is on and not [with_arguments] then implicit args are printed prefixed @@ -71,8 +73,11 @@ val with_coercions : ('a -> 'b) -> 'a -> 'b (** This forces printing universe names of Type\{.\} *) val with_universes : ('a -> 'b) -> 'a -> 'b -(** This suppresses printing of numeral and symbols *) +(** This suppresses printing of primitive tokens and notations *) val without_symbols : ('a -> 'b) -> 'a -> 'b +(** This suppresses printing of specific notations only *) +val without_specific_symbols : interp_rule list -> ('a -> 'b) -> 'a -> 'b + (** This prints metas as anonymous holes *) val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b diff --git a/interp/constrintern.ml b/interp/constrintern.ml index b6f18fe3..68f0050d 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1,33 +1,50 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_constr translation: + - it adds holes for implicit arguments + - it remplaces notations by their value (scopes stuff are here) + - it recognizes global vars from local ones + - it prepares pattern maching problems (a pattern becomes a tree where nodes + are constructor/variable pairs and leafs are variables) + + All that at once, fasten your seatbelt! +*) (* To interpret implicits and arg scopes of variables in inductive types and recursive definitions and of projection names in records *) type var_internalization_type = - | Inductive of identifier list (* list of params *) + | Inductive of Id.t list (* list of params *) | Recursive | Method | Variable @@ -38,16 +55,21 @@ type var_internalization_data = var_internalization_type * (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - identifier list * + Id.t list * (* signature of impargs of the variable *) Impargs.implicit_status list * (* subscopes of the args of the variable *) scope_name option list type internalization_env = - (var_internalization_data) Idmap.t + (var_internalization_data) Id.Map.t + +type glob_binder = (Name.t * binding_kind * glob_constr option * glob_constr) -type glob_binder = (name * binding_kind * glob_constr option * glob_constr) +type ltac_sign = { + ltac_vars : Id.Set.t; + ltac_bound : Id.Set.t; +} let interning_grammar = ref false @@ -75,38 +97,33 @@ let global_reference_of_reference ref = locate_reference (snd (qualid_of_reference ref)) let global_reference id = - constr_of_global (locate_reference (qualid_of_ident id)) + Universes.constr_of_global (locate_reference (qualid_of_ident id)) let construct_reference ctx id = try - Term.mkVar (let _ = Sign.lookup_named id ctx in id) + Term.mkVar (let _ = Context.lookup_named id ctx in id) with Not_found -> global_reference id let global_reference_in_absolute_module dir id = - constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) + Universes.constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) (**********************************************************************) (* Internalization errors *) type internalization_error = - | VariableCapture of identifier - | WrongExplicitImplicit + | VariableCapture of Id.t * Id.t | IllegalMetavariable | NotAConstructor of reference - | UnboundFixName of bool * identifier - | NonLinearPattern of identifier + | UnboundFixName of bool * Id.t + | NonLinearPattern of Id.t | BadPatternsNumber of int * int - | BadExplicitationNumber of explicitation * int option -exception InternalizationError of loc * internalization_error +exception InternalizationError of Loc.t * internalization_error -let explain_variable_capture id = - str "The variable " ++ pr_id id ++ str " occurs in its type" - -let explain_wrong_explicit_implicit = - str "Found an explicitly given implicit argument but was expecting" ++ - fnl () ++ str "a regular one" +let explain_variable_capture id id' = + pr_id id ++ str " is dependent in the type of " ++ pr_id id' ++ + strbrk ": cannot interpret both of them with the same type" let explain_illegal_metavariable = str "Metavariables allowed only in patterns" @@ -123,44 +140,31 @@ let explain_non_linear_pattern id = str "The variable " ++ pr_id id ++ str " is bound several times in pattern" let explain_bad_patterns_number n1 n2 = - str "Expecting " ++ int n1 ++ str (plural n1 " pattern") ++ + str "Expecting " ++ int n1 ++ str (String.plural n1 " pattern") ++ str " but found " ++ int n2 -let explain_bad_explicitation_number n po = - match n with - | ExplByPos (n,_id) -> - let s = match po with - | None -> str "a regular argument" - | Some p -> int p in - str "Bad explicitation number: found " ++ int n ++ - str" but was expecting " ++ s - | ExplByName id -> - let s = match po with - | None -> str "a regular argument" - | Some p -> (*pr_id (name_of_position p) in*) failwith "" in - str "Bad explicitation name: found " ++ pr_id id ++ - str" but was expecting " ++ s - let explain_internalization_error e = let pp = match e with - | VariableCapture id -> explain_variable_capture id - | WrongExplicitImplicit -> explain_wrong_explicit_implicit + | VariableCapture (id,id') -> explain_variable_capture id id' | IllegalMetavariable -> explain_illegal_metavariable | NotAConstructor ref -> explain_not_a_constructor ref | UnboundFixName (iscofix,id) -> explain_unbound_fix_name iscofix id | NonLinearPattern id -> explain_non_linear_pattern id | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 - | BadExplicitationNumber (n,po) -> explain_bad_explicitation_number n po in - pp ++ str "." + in pp ++ str "." let error_bad_inductive_type loc = user_err_loc (loc,"",str - "This should be an inductive type applied to names or \"_\".") + "This should be an inductive type applied to patterns.") -let error_inductive_parameter_not_implicit loc = +let error_parameter_not_implicit loc = user_err_loc (loc,"", str - ("The parameters of inductive types do not bind in\n"^ - "the 'return' clauses; they must be replaced by '_' in the 'in' clauses.")) + "The parameters do not bind in patterns;" ++ spc () ++ str + "they must be replaced by '_'.") + +let error_ldots_var loc = + user_err_loc (loc,"",str "Special token " ++ pr_id ldots_var ++ + str " is for use in the Notation command.") (**********************************************************************) (* Pre-computing the implicit arguments and arguments scopes needed *) @@ -168,12 +172,12 @@ let error_inductive_parameter_not_implicit loc = let parsing_explicit = ref false -let empty_internalization_env = Idmap.empty +let empty_internalization_env = Id.Map.empty let compute_explicitable_implicit imps = function | Inductive params -> (* In inductive types, the parameters are fixed implicit arguments *) - let sub_impl,_ = list_chop (List.length params) imps in + let sub_impl,_ = List.chop (List.length params) imps in let sub_impl' = List.filter is_status_implicit sub_impl in List.map name_of_implicit sub_impl' | Recursive | Method | Variable -> @@ -186,25 +190,25 @@ let compute_internalization_data env ty typ impl = (ty, expls_impl, impl, compute_arguments_scope typ) let compute_internalization_env env ty = - list_fold_left3 - (fun map id typ impl -> Idmap.add id (compute_internalization_data env ty typ impl) map) + List.fold_left3 + (fun map id typ impl -> Id.Map.add id (compute_internalization_data env ty typ impl) map) empty_internalization_env (**********************************************************************) (* Contracting "{ _ }" in notations *) let rec wildcards ntn n = - if n = String.length ntn then [] - else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l + if Int.equal n (String.length ntn) then [] + else let l = spaces ntn (n+1) in if ntn.[n] == '_' then n::l else l and spaces ntn n = - if n = String.length ntn then [] - else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1) + if Int.equal n (String.length ntn) then [] + else if ntn.[n] == ' ' then wildcards ntn (n+1) else spaces ntn (n+1) let expand_notation_string ntn n = let pos = List.nth (wildcards ntn 0) n in - let hd = if pos = 0 then "" else String.sub ntn 0 pos in + let hd = if Int.equal pos 0 then "" else String.sub ntn 0 pos in let tl = - if pos = String.length ntn then "" + if Int.equal pos (String.length ntn) then "" else String.sub ntn (pos+1) (String.length ntn - pos -1) in hd ^ "{ _ }" ^ tl @@ -227,7 +231,7 @@ let contract_pat_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CPatNotation (_,"{ _ }",([a],[])) :: l -> + | CPatNotation (_,"{ _ }",([a],[]),[]) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> @@ -237,19 +241,19 @@ let contract_pat_notation ntn (l,ll) = !ntn',(l,ll) type intern_env = { - ids: Names.Idset.t; + ids: Names.Id.Set.t; unb: bool; - tmp_scope: Topconstr.tmp_scope_name option; - scopes: Topconstr.scope_name list; + tmp_scope: Notation_term.tmp_scope_name option; + scopes: Notation_term.scope_name list; impls: internalization_env } (**********************************************************************) (* Remembering the parsing scope of variables in notations *) -let make_current_scope = function - | (Some tmp_scope,(sc::_ as scopes)) when sc = tmp_scope -> scopes - | (Some tmp_scope,scopes) -> tmp_scope::scopes - | None,scopes -> scopes +let make_current_scope tmp scopes = match tmp, scopes with +| Some tmp_scope, (sc :: _) when String.equal sc tmp_scope -> scopes +| Some tmp_scope, scopes -> tmp_scope :: scopes +| None, scopes -> scopes let pr_scope_stack = function | [] -> str "the empty scope stack" @@ -263,10 +267,6 @@ let error_inconsistent_scope loc id scopes1 scopes2 = pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++ pr_scope_stack scopes1) -let error_expect_constr_notation_type loc id = - user_err_loc (loc,"", - pr_id id ++ str " is bound in the notation to a term variable.") - let error_expect_binder_notation_type loc id = user_err_loc (loc,"", pr_id id ++ @@ -274,18 +274,17 @@ let error_expect_binder_notation_type loc id = let set_var_scope loc id istermvar env ntnvars = try - let idscopes,typ = List.assoc id ntnvars in - if istermvar then + let idscopes,typ = Id.Map.find id ntnvars in + let () = if istermvar then (* scopes have no effect on the interpretation of identifiers *) - if !idscopes = None then - idscopes := Some (env.tmp_scope,env.scopes) - else - if make_current_scope (Option.get !idscopes) - <> make_current_scope (env.tmp_scope,env.scopes) - then - error_inconsistent_scope loc id - (make_current_scope (Option.get !idscopes)) - (make_current_scope (env.tmp_scope,env.scopes)); + begin match !idscopes with + | None -> idscopes := Some (env.tmp_scope, env.scopes) + | Some (tmp, scope) -> + let s1 = make_current_scope tmp scope in + let s2 = make_current_scope env.tmp_scope env.scopes in + if not (List.equal String.equal s1 s2) then error_inconsistent_scope loc id s1 s2 + end + in match typ with | NtnInternTypeBinder -> if istermvar then error_expect_binder_notation_type loc id @@ -303,14 +302,14 @@ let set_type_scope env = {env with tmp_scope = Some Notation.type_scope} let reset_tmp_scope env = {env with tmp_scope = None} -let rec it_mkGProd env body = +let rec it_mkGProd loc2 env body = match env with - (na, bk, _, t) :: tl -> it_mkGProd tl (GProd (dummy_loc, na, bk, t, body)) + (loc1, (na, bk, _, t)) :: tl -> it_mkGProd loc2 tl (GProd (Loc.merge loc1 loc2, na, bk, t, body)) | [] -> body -let rec it_mkGLambda env body = +let rec it_mkGLambda loc2 env body = match env with - (na, bk, _, t) :: tl -> it_mkGLambda tl (GLambda (dummy_loc, na, bk, t, body)) + (loc1, (na, bk, _, t)) :: tl -> it_mkGLambda loc2 tl (GLambda (Loc.merge loc1 loc2, na, bk, t, body)) | [] -> body (**********************************************************************) @@ -318,7 +317,7 @@ let rec it_mkGLambda env body = let build_impls = function |Implicit -> (function |Name id -> Some (id, Impargs.Manual, (true,true)) - |Anonymous -> anomaly "Anonymous implicit argument") + |Anonymous -> anomaly (Pp.str "Anonymous implicit argument")) |Explicit -> fun _ -> None let impls_type_list ?(args = []) = @@ -337,30 +336,32 @@ let impls_term_list ?(args = []) = |_ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] -let check_capture loc ty = function - | Name id when occur_var_constr_expr id ty -> - raise (InternalizationError (loc,VariableCapture id)) - | _ -> +(* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) +let rec check_capture ty = function + | (loc,Name id)::(_,Name id')::_ when occur_glob_constr id ty -> + raise (InternalizationError (loc,VariableCapture (id,id'))) + | _::nal -> + check_capture ty nal + | [] -> () -let locate_if_isevar loc na = function - | GHole _ -> +let locate_if_hole loc na = function + | GHole (_,_,naming,arg) -> (try match na with - | Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id) + | Name id -> glob_constr_of_notation_constr loc + (Reserve.find_reserved_type id) | Anonymous -> raise Not_found - with Not_found -> GHole (loc, Evd.BinderType na)) + with Not_found -> GHole (loc, Evar_kinds.BinderType na, naming, arg)) | x -> x let reset_hidden_inductive_implicit_test env = - { env with impls = Idmap.fold (fun id x -> - let x = match x with + { env with impls = Id.Map.map (function | (Inductive _,b,c,d) -> (Inductive [],b,c,d) - | x -> x - in Idmap.add id x) env.impls Idmap.empty } + | x -> x) env.impls } let check_hidden_implicit_parameters id impls = - if Idmap.exists (fun _ -> function - | (Inductive indparams,_,_,_) -> List.mem id indparams + if Id.Map.exists (fun _ -> function + | (Inductive indparams,_,_,_) -> Id.List.mem id indparams | _ -> false) impls then errorlabstrm "" (strbrk "A parameter of an inductive type " ++ @@ -374,14 +375,17 @@ let push_name_env ?(global_level=false) lvar implargs env = env | loc,Name id -> check_hidden_implicit_parameters id env.impls ; - set_var_scope loc id false env (let (_,ntnvars) = lvar in ntnvars); + let (_,ntnvars) = lvar in + if Id.Map.is_empty ntnvars && Id.equal id ldots_var + then error_ldots_var loc; + set_var_scope loc id false env ntnvars; if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding loc id; - {env with ids = Idset.add id env.ids; impls = Idmap.add id implargs env.impls} + {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} let intern_generalized_binder ?(global_level=false) intern_type lvar - env bl (loc, na) b b' t ty = - let ids = (match na with Anonymous -> fun x -> x | Name na -> Idset.add na) env.ids in + env (loc, na) b b' t ty = + let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in let ty, ids' = if t then ty, ids else Implicit_quantifiers.implicit_application ids @@ -392,7 +396,11 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let env' = List.fold_left (fun env (x, l) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x)) env fvs in - let bl = List.map (fun (id, loc) -> (Name id, b, None, GHole (loc, Evd.BinderType (Name id)))) fvs in + let bl = List.map + (fun (id, loc) -> + (loc, (Name id, b, None, GHole (loc, Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) + fvs + in let na = match na with | Anonymous -> if global_level then na @@ -400,183 +408,221 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let name = let id = match ty with - | CApp (_, (_, CRef (Ident (loc,id))), _) -> id - | _ -> id_of_string "H" + | CApp (_, (_, CRef (Ident (loc,id),_)), _) -> id + | _ -> default_non_dependent_ident in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name | _ -> na - in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (na,b',None,ty') :: List.rev bl - -let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,bl) = function + in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (loc,(na,b',None,ty')) :: List.rev bl + +let intern_assumption intern lvar env nal bk ty = + let intern_type env = intern (set_type_scope env) in + match bk with + | Default k -> + let ty = intern_type env ty in + check_capture ty nal; + let impls = impls_type_list ty in + List.fold_left + (fun (env, bl) (loc, na as locna) -> + (push_name_env lvar impls env locna, + (loc,(na,k,None,locate_if_hole loc na ty))::bl)) + (env, []) nal + | Generalized (b,b',t) -> + let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in + env, b + +let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function | LocalRawAssum(nal,bk,ty) -> - (match bk with - | Default k -> - let ty = intern_type env ty in - let impls = impls_type_list ty in - List.fold_left - (fun (env,bl) (loc,na as locna) -> - (push_name_env lvar impls env locna, - (na,k,None,locate_if_isevar loc na ty)::bl)) - (env,bl) nal - | Generalized (b,b',t) -> - let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in - env, b @ bl) + let env, bl' = intern_assumption intern lvar env nal bk ty in + env, bl' @ bl | LocalRawDef((loc,na as locna),def) -> let indef = intern env def in (push_name_env lvar (impls_term_list indef) env locna, - (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl) + (loc,(na,Explicit,Some(indef),GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)))::bl) let intern_generalization intern env lvar loc bk ak c = let c = intern {env with unb = true} c in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:env.ids c in let env', c' = let abs = - let pi = - match ak with + let pi = match ak with | Some AbsPi -> true - | None when env.tmp_scope = Some Notation.type_scope - || List.mem Notation.type_scope env.scopes -> true - | _ -> false + | Some _ -> false + | None -> + let is_type_scope = match env.tmp_scope with + | None -> false + | Some sc -> String.equal sc Notation.type_scope + in + is_type_scope || + String.List.mem Notation.type_scope env.scopes in if pi then (fun (id, loc') acc -> - GProd (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc)) + GProd (Loc.merge loc' loc, Name id, bk, GHole (loc', Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) else (fun (id, loc') acc -> - GLambda (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc)) + GLambda (Loc.merge loc' loc, Name id, bk, GHole (loc', Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) in List.fold_right (fun (id, loc as lid) (env, acc) -> let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in (env', abs lid acc)) fvs (env,c) in c' -let iterate_binder intern lvar (env,bl) = function - | LocalRawAssum(nal,bk,ty) -> - let intern_type env = intern (set_type_scope env) in - (match bk with - | Default k -> - let ty = intern_type env ty in - let impls = impls_type_list ty in - List.fold_left - (fun (env,bl) (loc,na as locna) -> - (push_name_env lvar impls env locna, - (na,k,None,locate_if_isevar loc na ty)::bl)) - (env,bl) nal - | Generalized (b,b',t) -> - let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in - env, b @ bl) - | LocalRawDef((loc,na as locna),def) -> - let indef = intern env def in - (push_name_env lvar (impls_term_list indef) env locna, - (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl) - (**********************************************************************) (* Syntax extensions *) let option_mem_assoc id = function - | Some (id',c) -> id = id' + | Some (id',c) -> Id.equal id id' | None -> false -let find_fresh_name renaming (terms,termlists,binders) id = - let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) terms in - let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) termlists) in - let fvs3 = List.map snd renaming in +let find_fresh_name renaming (terms,termlists,binders) avoid id = + let fold1 _ (c, _) accu = Id.Set.union (free_vars_of_constr_expr c) accu in + let fold2 _ (l, _) accu = + let fold accu c = Id.Set.union (free_vars_of_constr_expr c) accu in + List.fold_left fold accu l + in + let fold3 _ x accu = Id.Set.add x accu in + let fvs1 = Id.Map.fold fold1 terms avoid in + let fvs2 = Id.Map.fold fold2 termlists fvs1 in + let fvs3 = Id.Map.fold fold3 renaming fvs2 in (* TODO binders *) - let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in - next_ident_away id fvs + next_ident_away_from id (fun id -> Id.Set.mem id fvs3) -let traverse_binder (terms,_,_ as subst) - (renaming,env)= - function +let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function | Anonymous -> (renaming,env),Anonymous | Name id -> try (* Binders bound in the notation are considered first-order objects *) - let _,na = coerce_to_name (fst (List.assoc id terms)) in - (renaming,{env with ids = name_fold Idset.add na env.ids}), na + let _,na = coerce_to_name (fst (Id.Map.find id terms)) in + (renaming,{env with ids = name_fold Id.Set.add na env.ids}), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) - let id' = find_fresh_name renaming subst id in - let renaming' = if id=id' then renaming else (id,id')::renaming in + let id' = find_fresh_name renaming subst avoid id in + let renaming' = + if Id.equal id id' then renaming else Id.Map.add id id' renaming + in (renaming',env), Name id' -let make_letins loc = List.fold_right (fun (na,b,t) c -> GLetIn (loc,na,b,c)) +let make_letins = List.fold_right (fun (loc,(na,b,t)) c -> GLetIn (loc,na,b,c)) let rec subordinate_letins letins = function (* binders come in reverse order; the non-let are returned in reverse order together *) (* with the subordinated let-in in writing order *) - | (na,_,Some b,t)::l -> - subordinate_letins ((na,b,t)::letins) l - | (na,bk,None,t)::l -> + | (loc,(na,_,Some b,t))::l -> + subordinate_letins ((loc,(na,b,t))::letins) l + | (loc,(na,bk,None,t))::l -> let letins',rest = subordinate_letins [] l in - letins',((na,bk,t),letins)::rest + letins',((loc,(na,bk,t)),letins)::rest | [] -> letins,[] let rec subst_iterator y t = function - | GVar (_,id) as x -> if id = y then t else x + | GVar (_,id) as x -> if Id.equal id y then t else x | x -> map_glob_constr (subst_iterator y t) x -let subst_aconstr_in_glob_constr loc intern lvar subst infos c = +let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c = let (terms,termlists,binders) = subst in + (* when called while defining a notation, avoid capturing the private binders + of the expression by variables bound by the notation (see #3892) *) + let avoid = Id.Map.domain ntnvars in let rec aux (terms,binderopt as subst') (renaming,env) c = let subinfos = renaming,{env with tmp_scope = None} in match c with - | AVar id -> - begin - (* subst remembers the delimiters stack in the interpretation *) - (* of the notations *) - try - let (a,(scopt,subscopes)) = List.assoc id terms in - intern {env with tmp_scope = scopt; - scopes = subscopes @ env.scopes} a - with Not_found -> - try - GVar (loc,List.assoc id renaming) - with Not_found -> - (* Happens for local notation joint with inductive/fixpoint defs *) - GVar (loc,id) - end - | AList (x,_,iter,terminator,lassoc) -> + | NVar id -> subst_var subst' (renaming, env) id + | NList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (l,(scopt,subscopes)) = List.assoc x termlists in + let (l,(scopt,subscopes)) = Id.Map.find x termlists in let termin = aux subst' subinfos terminator in - List.fold_right (fun a t -> - subst_iterator ldots_var t - (aux ((x,(a,(scopt,subscopes)))::terms,binderopt) subinfos iter)) - (if lassoc then List.rev l else l) termin + let fold a t = + let nterms = Id.Map.add x (a, (scopt, subscopes)) terms in + subst_iterator ldots_var t (aux (nterms, binderopt) subinfos iter) + in + List.fold_right fold (if lassoc then List.rev l else l) termin with Not_found -> - anomaly "Inconsistent substitution of recursive notation") - | AHole (Evd.BinderType (Name id as na)) -> - let na = - try snd (coerce_to_name (fst (List.assoc id terms))) - with Not_found -> na in - GHole (loc,Evd.BinderType na) - | ABinderList (x,_,iter,terminator) -> + anomaly (Pp.str "Inconsistent substitution of recursive notation")) + | NHole (knd, naming, arg) -> + let knd = match knd with + | Evar_kinds.BinderType (Name id as na) -> + let na = + try snd (coerce_to_name (fst (Id.Map.find id terms))) + with Not_found -> + try Name (Id.Map.find id renaming) + with Not_found -> na + in + Evar_kinds.BinderType na + | _ -> knd + in + let arg = match arg with + | None -> None + | Some arg -> + let open Tacexpr in + let open Genarg in + let wit = glbwit Constrarg.wit_tactic in + let body = + if has_type arg wit then out_gen wit arg + else assert false (** FIXME *) + in + let mk_env id (c, (tmp_scope, subscopes)) accu = + let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in + let gc = intern nenv c in + let c = ConstrMayEval (Genredexpr.ConstrTerm (gc, Some c)) in + ((loc, id), c) :: accu + in + let bindings = Id.Map.fold mk_env terms [] in + let tac = TacLetIn (false, bindings, body) in + let arg = in_gen wit tac in + Some arg + in + GHole (loc, knd, naming, arg) + | NBinderList (x,_,iter,terminator) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (bl,(scopt,subscopes)) = List.assoc x binders in - let env,bl = List.fold_left (iterate_binder intern lvar) (env,[]) bl in + let (bl,(scopt,subscopes)) = Id.Map.find x binders in + let env,bl = List.fold_left (intern_local_binder_aux intern lvar) (env,[]) bl in let letins,bl = subordinate_letins [] bl in let termin = aux subst' (renaming,env) terminator in let res = List.fold_left (fun t binder -> subst_iterator ldots_var t (aux (terms,Some(x,binder)) subinfos iter)) termin bl in - make_letins loc letins res + make_letins letins res with Not_found -> - anomaly "Inconsistent substitution of recursive notation") - | AProd (Name id, AHole _, c') when option_mem_assoc id binderopt -> - let (na,bk,t),letins = snd (Option.get binderopt) in - GProd (loc,na,bk,t,make_letins loc letins (aux subst' infos c')) - | ALambda (Name id,AHole _,c') when option_mem_assoc id binderopt -> - let (na,bk,t),letins = snd (Option.get binderopt) in - GLambda (loc,na,bk,t,make_letins loc letins (aux subst' infos c')) + anomaly (Pp.str "Inconsistent substitution of recursive notation")) + | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt -> + let (loc,(na,bk,t)),letins = snd (Option.get binderopt) in + GProd (loc,na,bk,t,make_letins letins (aux subst' infos c')) + | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> + let (loc,(na,bk,t)),letins = snd (Option.get binderopt) in + GLambda (loc,na,bk,t,make_letins letins (aux subst' infos c')) + (* Two special cases to keep binder name synchronous with BinderType *) + | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') + when Name.equal na na' -> + let subinfos,na = traverse_binder subst avoid subinfos na in + let ty = GHole (loc,Evar_kinds.BinderType na,naming,arg) in + GProd (loc,na,Explicit,ty,aux subst' subinfos c') + | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') + when Name.equal na na' -> + let subinfos,na = traverse_binder subst avoid subinfos na in + let ty = GHole (loc,Evar_kinds.BinderType na,naming,arg) in + GLambda (loc,na,Explicit,ty,aux subst' subinfos c') | t -> - glob_constr_of_aconstr_with_binders loc (traverse_binder subst) - (aux subst') subinfos t + glob_constr_of_notation_constr_with_binders loc + (traverse_binder subst avoid) (aux subst') subinfos t + and subst_var (terms, binderopt) (renaming, env) id = + (* subst remembers the delimiters stack in the interpretation *) + (* of the notations *) + try + let (a,(scopt,subscopes)) = Id.Map.find id terms in + intern {env with tmp_scope = scopt; + scopes = subscopes @ env.scopes} a + with Not_found -> + try + GVar (loc, Id.Map.find id renaming) + with Not_found -> + (* Happens for local notation joint with inductive/fixpoint defs *) + GVar (loc,id) in aux (terms,None) infos c let split_by_type ids = @@ -586,7 +632,9 @@ let split_by_type ids = | NtnTypeConstrList -> (l1,(x,scl)::l2,l3) | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[]) -let make_subst ids l = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids l +let make_subst ids l = + let fold accu (id, scl) a = Id.Map.add id (a, scl) accu in + List.fold_left2 fold Id.Map.empty ids l let intern_notation intern env lvar loc ntn fullargs = let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in @@ -597,7 +645,7 @@ let intern_notation intern env lvar loc ntn fullargs = let termlists = make_subst idsl argslist in let binders = make_subst idsbl bll in subst_aconstr_in_glob_constr loc intern lvar - (terms,termlists,binders) ([],env) c + (terms, termlists, binders) (Id.Map.empty, env) c (**********************************************************************) (* Discriminating between bound variables and global references *) @@ -609,39 +657,35 @@ let string_of_ty = function | Variable -> "var" let intern_var genv (ltacvars,ntnvars) namedctx loc id = - let (ltacvars,unbndltacvars) = ltacvars in (* Is [id] an inductive type potentially with implicit *) try - let ty,expl_impls,impls,argsc = Idmap.find id genv.impls in + let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in let expl_impls = List.map - (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in + (fun id -> CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in - Dumpglob.dump_reference loc "<>" (string_of_id id) tys; + Dumpglob.dump_reference loc "<>" (Id.to_string id) tys; GVar (loc,id), make_implicits_list impls, argsc, expl_impls with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) - if Idset.mem id genv.ids or List.mem id ltacvars + if Id.Set.mem id genv.ids || Id.Set.mem id ltacvars.ltac_vars then GVar (loc,id), [], [], [] (* Is [id] a notation variable *) - - else if List.mem_assoc id ntnvars + else if Id.Map.mem id ntnvars then (set_var_scope loc id true genv ntnvars; GVar (loc,id), [], [], []) (* Is [id] the special variable for recursive notations *) - else if ntnvars <> [] && id = ldots_var - then - GVar (loc,id), [], [], [] + else if Id.equal id ldots_var + then if Id.Map.is_empty ntnvars + then error_ldots_var loc + else GVar (loc,id), [], [], [] + else if Id.Set.mem id ltacvars.ltac_bound then + (* Is [id] bound to a free name in ltac (this is an ltac error message) *) + user_err_loc (loc,"intern_var", + str "variable " ++ pr_id id ++ str " should be bound to a term.") else - (* Is [id] bound to a free name in ltac (this is an ltac error message) *) - try - match List.assoc id unbndltacvars with - | None -> user_err_loc (loc,"intern_var", - str "variable " ++ pr_id id ++ str " should be bound to a term.") - | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 - with Not_found -> (* Is [id] a goal or section variable *) - let _ = Sign.lookup_named id namedctx in + let _ = Context.lookup_named id namedctx in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) @@ -649,128 +693,171 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - GRef (loc, ref), impls, scopes, [] + GRef (loc, ref, None), impls, scopes, [] with e when Errors.noncritical e -> (* [id] a goal variable *) GVar (loc,id), [], [], [] -let find_appl_head_data = function - | GRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[] - | GApp (_,GRef (_,ref),l) as x - when l <> [] & Flags.version_strictly_greater Flags.V8_2 -> +let proj_impls r impls = + let env = Global.env () in + let f (x, l) = x, projection_implicits env r l in + List.map f impls + +let proj_scopes n scopes = + List.skipn_at_least n scopes + +let proj_impls_scopes p impls scopes = + match p with + | Some (r, n) -> proj_impls r impls, proj_scopes n scopes + | None -> impls, scopes + +let find_appl_head_data c = + match c with + | GRef (loc,ref,_) as x -> + let impls = implicits_of_global ref in + let scopes = find_arguments_scope ref in + x, impls, scopes, [] + | GApp (_,GRef (_,ref,_),l) as x + when l != [] && Flags.version_strictly_greater Flags.V8_2 -> let n = List.length l in - x,List.map (drop_first_implicits n) (implicits_of_global ref), - list_skipn_at_least n (find_arguments_scope ref),[] + let impls = implicits_of_global ref in + let scopes = find_arguments_scope ref in + x, List.map (drop_first_implicits n) impls, + List.skipn_at_least n scopes,[] | x -> x,[],[],[] let error_not_enough_arguments loc = user_err_loc (loc,"",str "Abbreviation is not applied enough.") let check_no_explicitation l = - let l = List.filter (fun (a,b) -> b <> None) l in - if l <> [] then - let loc = fst (Option.get (snd (List.hd l))) in - user_err_loc - (loc,"",str"Unexpected explicitation of the argument of an abbreviation.") + let is_unset (a, b) = match b with None -> false | Some _ -> true in + let l = List.filter is_unset l in + match l with + | [] -> () + | (_, None) :: _ -> assert false + | (_, Some (loc, _)) :: _ -> + user_err_loc (loc,"",str"Unexpected explicitation of the argument of an abbreviation.") let dump_extended_global loc = function - | TrueGlobal ref -> Dumpglob.add_glob loc ref + | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob loc ref | SynDef sp -> Dumpglob.add_glob_kn loc sp let intern_extended_global_of_qualid (loc,qid) = - try let r = Nametab.locate_extended qid in dump_extended_global loc r; r - with Not_found -> error_global_not_found_loc loc qid + let r = Nametab.locate_extended qid in dump_extended_global loc r; r let intern_reference ref = - Smartlocate.global_of_extended_global - (intern_extended_global_of_qualid (qualid_of_reference ref)) + let qid = qualid_of_reference ref in + let r = + try intern_extended_global_of_qualid qid + with Not_found -> error_global_not_found_loc (fst qid) (snd qid) + in + Smartlocate.global_of_extended_global r (* Is it a global reference or a syntactic definition? *) -let intern_qualid loc qid intern env lvar args = +let intern_qualid loc qid intern env lvar us args = match intern_extended_global_of_qualid (loc,qid) with - | TrueGlobal ref -> - GRef (loc, ref), args + | TrueGlobal ref -> GRef (loc, ref, us), true, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in if List.length args < nids then error_not_enough_arguments loc; - let args1,args2 = list_chop nids args in + let args1,args2 = List.chop nids args in check_no_explicitation args1; - let subst = make_subst ids (List.map fst args1) in - subst_aconstr_in_glob_constr loc intern lvar (subst,[],[]) ([],env) c, args2 + let terms = make_subst ids (List.map fst args1) in + let subst = (terms, Id.Map.empty, Id.Map.empty) in + let infos = (Id.Map.empty, env) in + let projapp = match c with NRef _ -> true | _ -> false in + subst_aconstr_in_glob_constr loc intern lvar subst infos c, projapp, args2 (* Rule out section vars since these should have been found by intern_var *) -let intern_non_secvar_qualid loc qid intern env lvar args = - match intern_qualid loc qid intern env lvar args with - | GRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid +let intern_non_secvar_qualid loc qid intern env lvar us args = + match intern_qualid loc qid intern env lvar us args with + | GRef (_, VarRef _, _),_,_ -> raise Not_found | r -> r -let intern_applied_reference intern env namedctx lvar args = function +let intern_applied_reference intern env namedctx lvar us args = function | Qualid (loc, qid) -> - let r,args2 = intern_qualid loc qid intern env lvar args in - find_appl_head_data r, args2 + let r,projapp,args2 = + try intern_qualid loc qid intern env lvar us args + with Not_found -> error_global_not_found_loc loc qid + in + let x, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), args2 | Ident (loc, id) -> try intern_var env lvar namedctx loc id, args with Not_found -> let qid = qualid_of_ident id in try - let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in - find_appl_head_data r, args2 - with e when Errors.noncritical e -> + let r, projapp, args2 = intern_non_secvar_qualid loc qid intern env lvar us args in + let x, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), args2 + with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then - (GVar (loc,id), [], [], []),args - else raise e + (GVar (loc,id), [], [], []), args + else error_global_not_found_loc loc qid let interp_reference vars r = let (r,_,_,_),_ = - intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc) - {ids = Idset.empty; unb = false ; + intern_applied_reference (fun _ -> error_not_enough_arguments Loc.ghost) + {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} [] - (vars,[]) [] r + (vars, Id.Map.empty) None [] r in r +(**********************************************************************) +(** {5 Cases } *) + +(** {6 Elemtary bricks } *) let apply_scope_env env = function | [] -> {env with tmp_scope = None}, [] | sc::scl -> {env with tmp_scope = sc}, scl let rec simple_adjust_scopes n scopes = - if n=0 then [] else match scopes with + (* Note: they can be less scopes than arguments but also more scopes *) + (* than arguments because extra scopes are used in the presence of *) + (* coercions to funclass *) + if Int.equal n 0 then [] else match scopes with | [] -> None :: simple_adjust_scopes (n-1) [] | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes -let find_remaining_constructor_scopes pl1 pl2 (ind,j as cstr) = - let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in - let npar = mib.Declarations.mind_nparams in - snd (list_chop (npar + List.length pl1) - (simple_adjust_scopes (npar + List.length pl1 + List.length pl2) - (find_arguments_scope (ConstructRef cstr)))) +let find_remaining_scopes pl1 pl2 ref = + let impls_st = implicits_of_global ref in + let len_pl1 = List.length pl1 in + let len_pl2 = List.length pl2 in + let impl_list = if Int.equal len_pl1 0 + then select_impargs_size len_pl2 impls_st + else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in + let allscs = find_arguments_scope ref in + let scope_list = List.skipn_at_least len_pl1 allscs in + let rec aux = function + |[],l -> l + |_,[] -> [] + |h::t,_::tt when is_status_implicit h -> aux (t,tt) + |_::t,h::tt -> h :: aux (t,tt) + in ((try List.firstn len_pl1 allscs with Failure _ -> simple_adjust_scopes len_pl1 allscs), + simple_adjust_scopes len_pl2 (aux (impl_list,scope_list))) -(**********************************************************************) -(* Cases *) +let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2 let product_of_cases_patterns ids idspl = List.fold_right (fun (ids,pl) (ids',ptaill) -> - (ids@ids', - (* Cartesian prod of the or-pats for the nth arg and the tail args *) - List.flatten ( - List.map (fun (subst,p) -> - List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl))) - idspl (ids,[[],[]]) - -let simple_product_of_cases_patterns pl = - List.fold_right (fun pl ptaill -> - List.flatten (List.map (fun (subst,p) -> - List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl)) - pl [[],[]] - -(* Check linearity of pattern-matching *) + (ids @ ids', + (* Cartesian prod of the or-pats for the nth arg and the tail args *) + List.flatten ( + List.map (fun (subst,p) -> + List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) + idspl (ids,[Id.Map.empty,[]]) + +(* @return the first variable that occurs twice in a pattern + +naive n^2 algo *) let rec has_duplicate = function | [] -> None - | x::l -> if List.mem x l then (Some x) else has_duplicate l + | x::l -> if Id.List.mem x l then (Some x) else has_duplicate l let loc_of_lhs lhs = - join_loc (fst (List.hd lhs)) (fst (list_last lhs)) + Loc.merge (fst (List.hd lhs)) (fst (List.last lhs)) let check_linearity lhs ids = match has_duplicate ids with @@ -782,167 +869,89 @@ let check_linearity lhs ids = (* Match the number of pattern against the number of matched args *) let check_number_of_pattern loc n l = let p = List.length l in - if n<>p then raise (InternalizationError (loc,BadPatternsNumber (n,p))) + if not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = - if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then + if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then user_err_loc (loc, "", str "The components of this disjunctive pattern must bind the same variables.") -let check_constructor_length env loc cstr pl pl0 = - let n = List.length pl + List.length pl0 in - let nargs = Inductiveops.constructor_nrealargs env cstr in - let nhyps = Inductiveops.constructor_nrealhyps env cstr in - if n <> nargs && n <> nhyps (* i.e. with let's *) then - error_wrong_numarg_constructor_loc loc env cstr nargs - -(* Manage multiple aliases *) - - (* [merge_aliases] returns the sets of all aliases encountered at this - point and a substitution mapping extra aliases to the first one *) -let merge_aliases (ids,asubst as _aliases) id = - ids@[id], if ids=[] then asubst else (id, List.hd ids)::asubst - -let alias_of = function - | ([],_) -> Anonymous - | (id::_,_) -> Name id - -let message_redundant_alias (id1,id2) = - if_warn msg_warning - (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2) - -(* Expanding notations *) - -let chop_aconstr_constructor loc (ind,k) args = - if List.length args = 0 then (* Tolerance for a @id notation *) args else - begin - let mib,_ = Global.lookup_inductive ind in - let nparams = mib.Declarations.mind_nparams in - if nparams > List.length args then error_invalid_pattern_notation loc; - let params,args = list_chop nparams args in - List.iter (function AHole _ -> () - | _ -> error_invalid_pattern_notation loc) params; - args - end - -let rec subst_pat_iterator y t (subst,p) = match p with - | PatVar (_,id) as x -> - if id = Name y then t else [subst,x] - | PatCstr (loc,id,l,alias) -> - let l' = List.map (fun a -> (subst_pat_iterator y t ([],a))) l in - let pl = simple_product_of_cases_patterns l' in - List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl - -let subst_cases_pattern loc alias intern fullsubst env a = - let rec aux alias (subst,substlist as fullsubst) = function - | AVar id -> - begin - (* subst remembers the delimiters stack in the interpretation *) - (* of the notations *) - try - let (a,(scopt,subscopes)) = List.assoc id subst in - intern {env with scopes=subscopes@env.scopes; - tmp_scope = scopt} ([],[]) a - with Not_found -> - if id = ldots_var then [], [[], PatVar (loc,Name id)] else - anomaly ("Unbound pattern notation variable: "^(string_of_id id)) - (* - (* Happens for local notation joint with inductive/fixpoint defs *) - if aliases <> ([],[]) then - anomaly "Pattern notation without constructors"; - [[id],[]], PatVar (loc,Name id) - *) - end - | ARef (ConstructRef c) -> - ([],[[], PatCstr (loc,c, [], alias)]) - | AApp (ARef (ConstructRef cstr),args) -> - let args = chop_aconstr_constructor loc cstr args in - let idslpll = List.map (aux Anonymous fullsubst) args in - let ids',pll = product_of_cases_patterns [] idslpll in - let pl' = List.map (fun (asubst,pl) -> - asubst,PatCstr (loc,cstr,pl,alias)) pll in - ids', pl' - | AList (x,_,iter,terminator,lassoc) -> - (try - (* All elements of the list are in scopes (scopt,subscopes) *) - let (l,(scopt,subscopes)) = List.assoc x substlist in - let termin = aux Anonymous fullsubst terminator in - let idsl,v = - List.fold_right (fun a (tids,t) -> - let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst,substlist) iter in - let pll = List.map (subst_pat_iterator ldots_var t) u in - tids@uids, List.flatten pll) - (if lassoc then List.rev l else l) termin in - idsl, List.map (fun ((asubst, pl) as x) -> - match pl with PatCstr (loc, c, pl, Anonymous) -> (asubst, PatCstr (loc, c, pl, alias)) | _ -> x) v - with Not_found -> - anomaly "Inconsistent substitution of recursive notation") - | AHole _ -> ([],[[], PatVar (loc,Anonymous)]) - | t -> error_invalid_pattern_notation loc - in aux alias fullsubst a - -(* Differentiating between constructors and matching variables *) -type pattern_qualid_kind = - | ConstrPat of constructor * (identifier list * - ((identifier * identifier) list * cases_pattern) list) list - | VarPat of identifier - -let find_constructor ref f aliases pats env = - let (loc,qid) = qualid_of_reference ref in - let gref = - try locate_extended qid - with Not_found -> raise (InternalizationError (loc,NotAConstructor ref)) in - match gref with - | SynDef sp -> - let (vars,a) = Syntax_def.search_syntactic_definition sp in - (match a with - | ARef (ConstructRef cstr) -> - assert (vars=[]); - cstr, [], pats - | AApp (ARef (ConstructRef cstr),args) -> - let args = chop_aconstr_constructor loc cstr args in - let nvars = List.length vars in - if List.length pats < nvars then error_not_enough_arguments loc; - let pats1,pats2 = list_chop nvars pats in - let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) vars pats1 in - let idspl1 = List.map (subst_cases_pattern loc Anonymous f (subst,[]) env) args in - cstr, idspl1, pats2 - | _ -> raise Not_found) - - | TrueGlobal r -> - let rec unf = function - | ConstRef cst -> - let v = Environ.constant_value (Global.env()) cst in - unf (global_of_constr v) - | ConstructRef cstr -> - Dumpglob.add_glob loc r; - cstr, [], pats - | _ -> raise Not_found - in unf r +(** Use only when params were NOT asked to the user. + @return if letin are included *) +let check_constructor_length env loc cstr len_pl pl0 = + let n = len_pl + List.length pl0 in + if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else + (Int.equal n (Inductiveops.constructor_nalldecls cstr) || + (error_wrong_numarg_constructor_loc loc env cstr + (Inductiveops.constructor_nrealargs cstr))) + +let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = + let impl_list = if Int.equal len_pl1 0 + then select_impargs_size (List.length pl2) impls_st + else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in + let remaining_args = List.fold_left (fun i x -> if is_status_implicit x then i else succ i) in + let rec aux i = function + |[],l -> let args_len = List.length l + List.length impl_list + len_pl1 in + ((if Int.equal args_len nargs then false + else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) + ,l) + |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp + then let (b,out) = aux i (q,[]) in (b,RCPatAtom(Loc.ghost,None)::out) + else fail (remaining_args (len_pl1+i) il) + |imp::q,(hh::tt as l) -> if is_status_implicit imp + then let (b,out) = aux i (q,l) in (b,RCPatAtom(Loc.ghost,None)::out) + else let (b,out) = aux (succ i) (q,tt) in (b,hh::out) + in aux 0 (impl_list,pl2) + +let add_implicits_check_constructor_length env loc c len_pl1 pl2 = + let nargs = Inductiveops.constructor_nallargs c in + let nargs' = Inductiveops.constructor_nalldecls c in + let impls_st = implicits_of_global (ConstructRef c) in + add_implicits_check_length (error_wrong_numarg_constructor_loc loc env c) + nargs nargs' impls_st len_pl1 pl2 + +let add_implicits_check_ind_length env loc c len_pl1 pl2 = + let nallargs = inductive_nallargs_env env c in + let nalldecls = inductive_nalldecls_env env c in + let impls_st = implicits_of_global (IndRef c) in + add_implicits_check_length (error_wrong_numarg_inductive_loc loc env c) + nallargs nalldecls impls_st len_pl1 pl2 + +(** Do not raise NotEnoughArguments thanks to preconditions*) +let chop_params_pattern loc ind args with_letin = + let nparams = if with_letin + then Inductiveops.inductive_nparamdecls ind + else Inductiveops.inductive_nparams ind in + assert (nparams <= List.length args); + let params,args = List.chop nparams args in + List.iter (function PatVar(_,Anonymous) -> () + | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit loc') params; + args + +let find_constructor loc add_params ref = + let cstr = match ref with + | ConstructRef cstr -> cstr + | IndRef _ -> + let error = str "There is an inductive name deep in a \"in\" clause." in + user_err_loc (loc, "find_constructor", error) + | ConstRef _ | VarRef _ -> + let error = str "This reference is not a constructor." in + user_err_loc (loc, "find_constructor", error) + in + cstr, (function (ind,_ as c) -> match add_params with + |Some nb_args -> + let nb = + if Int.equal nb_args (Inductiveops.constructor_nrealdecls c) + then Inductiveops.inductive_nparamdecls ind + else Inductiveops.inductive_nparams ind + in + List.make nb ([], [(Id.Map.empty, PatVar(Loc.ghost,Anonymous))]) + |None -> []) cstr let find_pattern_variable = function | Ident (loc,id) -> id | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x)) -let maybe_constructor ref f aliases env = - try - let c,idspl1,pl2 = find_constructor ref f aliases [] env in - assert (pl2 = []); - ConstrPat (c,idspl1) - with - (* patt var does not exists globally *) - | InternalizationError _ -> VarPat (find_pattern_variable ref) - (* patt var also exists globally but does not satisfy preconditions *) - | (Environ.NotEvaluableConst _ | Not_found) -> - if_warn msg_warning (str "pattern " ++ pr_reference ref ++ - str " is understood as a pattern variable"); - VarPat (find_pattern_variable ref) - -let mustbe_constructor loc ref f aliases patl env = - try find_constructor ref f aliases patl env - with (Environ.NotEvaluableConst _ | Not_found) -> - raise (InternalizationError (loc,NotAConstructor ref)) - let sort_fields mode loc l completer = (*mode=false if pattern and true if constructor*) match l with @@ -966,18 +975,19 @@ let sort_fields mode loc l completer = | [] -> (i, acc) | (Some name) :: b-> (match m with - | [] -> anomaly "Number of projections mismatch" + | [] -> anomaly (Pp.str "Number of projections mismatch") | (_, regular)::tm -> let boolean = not regular in - (match global_reference_of_reference refer with - | ConstRef name' when eq_constant name name' -> + begin match global_reference_of_reference refer with + | ConstRef name' when eq_constant name name' -> if boolean && mode then user_err_loc (loc, "", str"No local fields allowed in a record construction.") else build_patt b tm (i + 1) (i, snd acc) (* we found it *) | _ -> build_patt b tm (if boolean&&mode then i else i + 1) (if boolean && mode then acc - else fst acc, (i, ConstRef name) :: snd acc))) + else fst acc, (i, ConstRef name) :: snd acc) + end) | None :: b-> (* we don't want anonymous fields *) if mode then user_err_loc (loc, "", str "This record contains anonymous fields.") @@ -987,9 +997,9 @@ let sort_fields mode loc l completer = let ind = record.Recordops.s_CONST in try (* insertion of Constextern.reference_global *) (record.Recordops.s_EXPECTEDPARAM, - Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef ind)), + Qualid (loc, shortest_qualid_of_global Id.Set.empty (ConstructRef ind)), build_patt record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 (0,[])) - with Not_found -> anomaly "Environment corruption for records." + with Not_found -> anomaly (Pp.str "Environment corruption for records.") in (* now we want to have all fields of the pattern indexed by their place in the constructor *) @@ -1032,111 +1042,287 @@ let sort_fields mode loc l completer = Some (nparams, base_constructor, List.rev (clean_list sorted_indexed_pattern 0 [])) -let rec intern_cases_pattern genv env (ids,asubst as aliases) pat = - let intern_pat = intern_cases_pattern genv in - match pat with - | CPatAlias (loc, p, id) -> - let aliases' = merge_aliases aliases id in - intern_pat env aliases' p +(** {6 Manage multiple aliases} *) + +type alias = { + alias_ids : Id.t list; + alias_map : Id.t Id.Map.t; +} + +let empty_alias = { + alias_ids = []; + alias_map = Id.Map.empty; +} + + (* [merge_aliases] returns the sets of all aliases encountered at this + point and a substitution mapping extra aliases to the first one *) +let merge_aliases aliases id = + let alias_ids = aliases.alias_ids @ [id] in + let alias_map = match aliases.alias_ids with + | [] -> aliases.alias_map + | id' :: _ -> Id.Map.add id id' aliases.alias_map + in + { alias_ids; alias_map; } + +let alias_of als = match als.alias_ids with +| [] -> Anonymous +| id :: _ -> Name id + +let message_redundant_alias id1 id2 = + msg_warning + (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2) + +(** {6 Expanding notations } + + @returns a raw_case_pattern_expr : + - no notations and syntactic definition + - global reference and identifeir instead of reference + +*) + +let rec subst_pat_iterator y t p = match p with + | RCPatAtom (_,id) -> + begin match id with Some x when Id.equal x y -> t | _ -> p end + | RCPatCstr (loc,id,l1,l2) -> + RCPatCstr (loc,id,List.map (subst_pat_iterator y t) l1, + List.map (subst_pat_iterator y t) l2) + | RCPatAlias (l,p,a) -> RCPatAlias (l,subst_pat_iterator y t p,a) + | RCPatOr (l,pl) -> RCPatOr (l,List.map (subst_pat_iterator y t) pl) + +let drop_notations_pattern looked_for = + (* At toplevel, Constructors and Inductives are accepted, in recursive calls + only constructor are allowed *) + let ensure_kind top loc g = + try + if top then looked_for g else + match g with ConstructRef _ -> () | _ -> raise Not_found + with Not_found -> + error_invalid_pattern_notation loc + in + let test_kind top = + if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found + in + let rec drop_syndef top env re pats = + let (loc,qid) = qualid_of_reference re in + try + match locate_extended qid with + |SynDef sp -> + let (vars,a) = Syntax_def.search_syntactic_definition sp in + (match a with + | NRef g -> + test_kind top g; + let () = assert (List.is_empty vars) in + let (_,argscs) = find_remaining_scopes [] pats g in + Some (g, [], List.map2 (in_pat_sc env) argscs pats) + | NApp (NRef g,[]) -> (* special case : Syndef for @Cstr *) + test_kind top g; + let () = assert (List.is_empty vars) in + let (argscs,_) = find_remaining_scopes pats [] g in + Some (g, List.map2 (in_pat_sc env) argscs pats, []) + | NApp (NRef g,args) -> + ensure_kind top loc g; + let nvars = List.length vars in + if List.length pats < nvars then error_not_enough_arguments loc; + let pats1,pats2 = List.chop nvars pats in + let subst = make_subst vars pats1 in + let idspl1 = List.map (in_not false loc env (subst, Id.Map.empty) []) args in + let (_,argscs) = find_remaining_scopes pats1 pats2 g in + Some (g, idspl1, List.map2 (in_pat_sc env) argscs pats2) + | _ -> raise Not_found) + |TrueGlobal g -> + test_kind top g; + Dumpglob.add_glob loc g; + let (_,argscs) = find_remaining_scopes [] pats g in + Some (g,[],List.map2 (fun x -> in_pat false {env with tmp_scope = x}) argscs pats) + with Not_found -> None + and in_pat top env = function + | CPatAlias (loc, p, id) -> RCPatAlias (loc, in_pat top env p, id) | CPatRecord (loc, l) -> - let sorted_fields = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in - let self_patt = - match sorted_fields with - | None -> CPatAtom (loc, None) - | Some (_, head, pl) -> CPatCstr(loc, head, pl) - in - intern_pat env aliases self_patt - | CPatCstr (loc, head, pl) | CPatCstrExpl (loc, head, pl) -> - let c,idslpl1,pl2 = mustbe_constructor loc head intern_pat aliases pl env in - check_constructor_length genv loc c idslpl1 pl2; - let argscs2 = find_remaining_constructor_scopes idslpl1 pl2 c in - let idslpl2 = List.map2 (fun x -> intern_pat {env with tmp_scope = x} ([],[])) argscs2 pl2 in - let (ids',pll) = product_of_cases_patterns ids (idslpl1@idslpl2) in - let pl' = List.map (fun (asubst,pl) -> - (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll in - ids',pl' - | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[])) - when Bigint.is_strictly_pos p -> - intern_pat env aliases (CPatPrim(loc,Numeral(Bigint.neg p))) - | CPatNotation (_,"( _ )",([a],[])) -> - intern_pat env aliases a - | CPatNotation (loc, ntn, fullargs) -> + let sorted_fields = + sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in + begin match sorted_fields with + | None -> RCPatAtom (loc, None) + | Some (_, head, pl) -> + match drop_syndef top env head pl with + |Some (a,b,c) -> RCPatCstr(loc, a, b, c) + |None -> raise (InternalizationError (loc,NotAConstructor head)) + end + | CPatCstr (loc, head, [], pl) -> + begin + match drop_syndef top env head pl with + | Some (a,b,c) -> RCPatCstr(loc, a, b, c) + | None -> raise (InternalizationError (loc,NotAConstructor head)) + end + | CPatCstr (loc, r, expl_pl, pl) -> + let g = try + (locate (snd (qualid_of_reference r))) + with Not_found -> + raise (InternalizationError (loc,NotAConstructor r)) in + let (argscs1,argscs2) = find_remaining_scopes expl_pl pl g in + RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl, List.map2 (in_pat_sc env) argscs2 pl) + | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]),[]) + when Bigint.is_strictly_pos p -> + fst (Notation.interp_prim_token_cases_pattern_expr loc (ensure_kind false loc) (Numeral (Bigint.neg p)) + (env.tmp_scope,env.scopes)) + | CPatNotation (_,"( _ )",([a],[]),[]) -> + in_pat top env a + | CPatNotation (loc, ntn, fullargs,extrargs) -> let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in let ((ids',c),df) = Notation.interp_notation loc ntn (env.tmp_scope,env.scopes) in let (ids',idsl',_) = split_by_type ids' in Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df; - let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in - let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in - let ids'',pl = - subst_cases_pattern loc (alias_of aliases) intern_pat (subst,substlist) - env c - in ids@ids'', pl - | CPatPrim (loc, p) -> - let a = alias_of aliases in - let (c,_) = Notation.interp_prim_token_cases_pattern loc p a - (env.tmp_scope,env.scopes) in - (ids,[asubst,c]) - | CPatDelimiters (loc, key, e) -> - intern_pat {env with scopes=find_delimiters_scope loc key::env.scopes; - tmp_scope = None} aliases e - | CPatAtom (loc, Some head) -> - (match maybe_constructor head intern_pat aliases env with - | ConstrPat (c,idspl) -> - check_constructor_length genv loc c idspl []; - let (ids',pll) = product_of_cases_patterns ids idspl in - (ids,List.map (fun (asubst,pl) -> - (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll) - | VarPat id -> - let ids,asubst = merge_aliases aliases id in - (ids,[asubst, PatVar (loc,alias_of (ids,asubst))])) - | CPatAtom (loc, None) -> - (ids,[asubst, PatVar (loc,alias_of aliases)]) - | CPatOr (loc, pl) -> - assert (pl <> []); - let pl' = List.map (intern_pat env aliases) pl in + let substlist = make_subst idsl' argsl in + let subst = make_subst ids' args in + in_not top loc env (subst,substlist) extrargs c + | CPatDelimiters (loc, key, e) -> + in_pat top {env with scopes=find_delimiters_scope loc key::env.scopes; + tmp_scope = None} e + | CPatPrim (loc,p) -> fst (Notation.interp_prim_token_cases_pattern_expr loc (test_kind false) p + (env.tmp_scope,env.scopes)) + | CPatAtom (loc, Some id) -> + begin + match drop_syndef top env id [] with + |Some (a,b,c) -> RCPatCstr (loc, a, b, c) + |None -> RCPatAtom (loc, Some (find_pattern_variable id)) + end + | CPatAtom (loc,None) -> RCPatAtom (loc,None) + | CPatOr (loc, pl) -> + RCPatOr (loc,List.map (in_pat top env) pl) + and in_pat_sc env x = in_pat false {env with tmp_scope = x} + and in_not top loc env (subst,substlist as fullsubst) args = function + | NVar id -> + let () = assert (List.is_empty args) in + begin + (* subst remembers the delimiters stack in the interpretation *) + (* of the notations *) + try + let (a,(scopt,subscopes)) = Id.Map.find id subst in + in_pat top {env with scopes=subscopes@env.scopes; + tmp_scope = scopt} a + with Not_found -> + if Id.equal id ldots_var then RCPatAtom (loc,Some id) else + anomaly (str "Unbound pattern notation variable: " ++ Id.print id) + end + | NRef g -> + ensure_kind top loc g; + let (_,argscs) = find_remaining_scopes [] args g in + RCPatCstr (loc, g, [], List.map2 (in_pat_sc env) argscs args) + | NApp (NRef g,pl) -> + ensure_kind top loc g; + let (argscs1,argscs2) = find_remaining_scopes pl args g in + RCPatCstr (loc, g, + List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl, + List.map2 (in_pat_sc env) argscs2 args) + | NList (x,_,iter,terminator,lassoc) -> + let () = assert (List.is_empty args) in + (try + (* All elements of the list are in scopes (scopt,subscopes) *) + let (l,(scopt,subscopes)) = Id.Map.find x substlist in + let termin = in_not top loc env fullsubst [] terminator in + List.fold_right (fun a t -> + let nsubst = Id.Map.add x (a, (scopt, subscopes)) subst in + let u = in_not false loc env (nsubst, substlist) [] iter in + subst_pat_iterator ldots_var t u) + (if lassoc then List.rev l else l) termin + with Not_found -> + anomaly (Pp.str "Inconsistent substitution of recursive notation")) + | NHole _ -> + let () = assert (List.is_empty args) in + RCPatAtom (loc, None) + | t -> error_invalid_pattern_notation loc + in in_pat true + +let rec intern_pat genv aliases pat = + let intern_cstr_with_all_args loc c with_letin idslpl1 pl2 = + let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in + let (ids',pll) = product_of_cases_patterns aliases.alias_ids (idslpl1@idslpl2) in + let pl' = List.map (fun (asubst,pl) -> + (asubst, PatCstr (loc,c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in + ids',pl' in + match pat with + | RCPatAlias (loc, p, id) -> + let aliases' = merge_aliases aliases id in + intern_pat genv aliases' p + | RCPatCstr (loc, head, expl_pl, pl) -> + if !oldfashion_patterns then + let len = if List.is_empty expl_pl then Some (List.length pl) else None in + let c,idslpl1 = find_constructor loc len head in + let with_letin = + check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in + intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl) + else + let c,idslpl1 = find_constructor loc None head in + let with_letin, pl2 = + add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in + intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) + | RCPatAtom (loc, Some id) -> + let aliases = merge_aliases aliases id in + (aliases.alias_ids,[aliases.alias_map, PatVar (loc, alias_of aliases)]) + | RCPatAtom (loc, None) -> + let { alias_ids = ids; alias_map = asubst; } = aliases in + (ids, [asubst, PatVar (loc, alias_of aliases)]) + | RCPatOr (loc, pl) -> + assert (not (List.is_empty pl)); + let pl' = List.map (intern_pat genv aliases) pl in let (idsl,pl') = List.split pl' in let ids = List.hd idsl in check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten pl') +let intern_cases_pattern genv env aliases pat = + intern_pat genv aliases + (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) env pat) + +let intern_ind_pattern genv env pat = + let no_not = + try + drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) env pat + with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type loc + in + match no_not with + | RCPatCstr (loc, head,expl_pl, pl) -> + let c = (function IndRef ind -> ind + |_ -> error_bad_inductive_type loc) head in + let with_letin, pl2 = add_implicits_check_ind_length genv loc c + (List.length expl_pl) pl in + let idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in + let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in + (with_letin, + match product_of_cases_patterns [] (List.rev_append idslpl1 idslpl2) with + |_,[_,pl] -> + (c,chop_params_pattern loc c pl with_letin) + |_ -> error_bad_inductive_type loc) + | x -> error_bad_inductive_type (raw_cases_pattern_expr_loc x) + (**********************************************************************) (* Utilities for application *) let merge_impargs l args = + let test x = function + | (_, Some (_, y)) -> explicitation_eq x y + | _ -> false + in List.fold_right (fun a l -> match a with | (_,Some (_,(ExplByName id as x))) when - List.exists (function (_,Some (_,y)) -> x=y | _ -> false) args -> l + List.exists (test x) args -> l | _ -> a::l) l args -let check_projection isproj nargs r = - match (r,isproj) with - | GRef (loc, ref), Some _ -> - (try - let n = Recordops.find_projection_nparams ref + 1 in - if nargs <> n then - user_err_loc (loc,"",str "Projection does not have the right number of explicit parameters."); - with Not_found -> - user_err_loc - (loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection.")) - | _, Some _ -> user_err_loc (loc_of_glob_constr r, "", str "Not a projection.") - | _, None -> () - let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) let set_hole_implicit i b = function - | GRef (loc,r) | GApp (_,GRef (loc,r),_) -> (loc,Evd.ImplicitArg (r,i,b)) - | GVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i,b)) - | _ -> anomaly "Only refs have implicits" + | GRef (loc,r,_) | GApp (_,GRef (loc,r,_),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | GVar (loc,id) -> (loc,Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) + | _ -> anomaly (Pp.str "Only refs have implicits") let exists_implicit_name id = - List.exists (fun imp -> is_status_implicit imp & id = name_of_implicit imp) + List.exists (fun imp -> is_status_implicit imp && Id.equal id (name_of_implicit imp)) let extract_explicit_arg imps args = let rec aux = function - | [] -> [],[] + | [] -> Id.Map.empty, [] | (a,e)::l -> let (eargs,rargs) = aux l in match e with @@ -1147,7 +1333,7 @@ let extract_explicit_arg imps args = if not (exists_implicit_name id imps) then user_err_loc (loc,"",str "Wrong argument name: " ++ pr_id id ++ str "."); - if List.mem_assoc id eargs then + if Id.Map.mem id eargs then user_err_loc (loc,"",str "Argument name " ++ pr_id id ++ str " occurs more than once."); id @@ -1161,29 +1347,30 @@ let extract_explicit_arg imps args = user_err_loc (loc,"",str"Wrong argument position: " ++ int p ++ str ".") in - if List.mem_assoc id eargs then + if Id.Map.mem id eargs then user_err_loc (loc,"",str"Argument at position " ++ int p ++ str " is mentioned more than once."); id in - ((id,(loc,a))::eargs,rargs) + (Id.Map.add id (loc, a) eargs, rargs) in aux args (**********************************************************************) (* Main loop *) -let internalize sigma globalenv env allow_patvar lvar c = +let internalize globalenv env allow_patvar lvar c = let rec intern env = function - | CRef ref as x -> + | CRef (ref,us) as x -> let (c,imp,subscopes,l),_ = - intern_applied_reference intern env (Environ.named_context globalenv) lvar [] ref in - (match intern_impargs c env imp subscopes l with - | [] -> c - | l -> GApp (constr_loc x, c, l)) + intern_applied_reference intern env (Environ.named_context globalenv) + lvar us [] ref + in + apply_impargs c env imp subscopes l (constr_loc x) + | CFix (loc, (locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in let dl = Array.of_list dl in let n = - try list_index0 iddef lf + try List.index0 Id.equal iddef lf with Not_found -> raise (InternalizationError (locid,UnboundFixName (false,iddef))) in @@ -1194,7 +1381,7 @@ let internalize sigma globalenv env allow_patvar lvar c = let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.length rbefore) n in + let n' = Option.map (fun _ -> List.length (List.filter (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore)) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, (env',rbl) = @@ -1207,47 +1394,45 @@ let internalize sigma globalenv env allow_patvar lvar c = intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r)) in ((n, ro), List.rev rbl, intern_type env' ty, env')) dl in - let idl = array_map2 (fun (_,_,_,_,bd) (a,b,c,env') -> - let env'' = list_fold_left_i (fun i en name -> + let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> + let env'' = List.fold_left_i (fun i en name -> let (_,bli,tyi,_) = idl_temp.(i) in - let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in + let fix_args = (List.map (fun (_,(na, bk, _, _)) -> (build_impls bk na)) bli) in push_name_env lvar (impls_type_list ~args:fix_args tyi) - en (dummy_loc, Name name)) 0 env' lf in + en (Loc.ghost, Name name)) 0 env' lf in (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in GRec (loc,GFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, - Array.map (fun (_,bl,_,_) -> bl) idl, + Array.map (fun (_,bl,_,_) -> List.map snd bl) idl, Array.map (fun (_,_,ty,_) -> ty) idl, Array.map (fun (_,_,_,bd) -> bd) idl) | CCoFix (loc, (locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_) -> id) dl in let dl = Array.of_list dl in let n = - try list_index0 iddef lf + try List.index0 Id.equal iddef lf with Not_found -> raise (InternalizationError (locid,UnboundFixName (true,iddef))) in let idl_tmp = Array.map - (fun (id,bl,ty,_) -> + (fun ((loc,id),bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in (List.rev rbl, intern_type env' ty,env')) dl in - let idl = array_map2 (fun (_,_,_,bd) (b,c,env') -> - let env'' = list_fold_left_i (fun i en name -> + let idl = Array.map2 (fun (_,_,_,bd) (b,c,env') -> + let env'' = List.fold_left_i (fun i en name -> let (bli,tyi,_) = idl_tmp.(i) in - let cofix_args = List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli in + let cofix_args = List.map (fun (_, (na, bk, _, _)) -> (build_impls bk na)) bli in push_name_env lvar (impls_type_list ~args:cofix_args tyi) - en (dummy_loc, Name name)) 0 env' lf in + en (Loc.ghost, Name name)) 0 env' lf in (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in GRec (loc,GCoFix n, Array.of_list lf, - Array.map (fun (bl,_,_) -> bl) idl, + Array.map (fun (bl,_,_) -> List.map snd bl) idl, Array.map (fun (_,ty,_) -> ty) idl, Array.map (fun (_,_,bd) -> bd) idl) - | CArrow (loc,c1,c2) -> - GProd (loc, Anonymous, Explicit, intern_type env c1, intern_type env c2) | CProdN (loc,[],c2) -> intern_type env c2 | CProdN (loc,(nal,bk,ty)::bll,c2) -> @@ -1273,100 +1458,154 @@ let internalize sigma globalenv env allow_patvar lvar c = | CDelimiters (loc, key, e) -> intern {env with tmp_scope = None; scopes = find_delimiters_scope loc key :: env.scopes} e - | CAppExpl (loc, (isproj,ref), args) -> + | CAppExpl (loc, (isproj,ref,us), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in - intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref in - check_projection isproj (List.length args) f; - (* Rem: GApp(_,f,[]) stands for @f *) - GApp (loc, f, intern_args env args_scopes (List.map fst args)) + intern_applied_reference intern env (Environ.named_context globalenv) + lvar us args ref + in + (* Rem: GApp(_,f,[]) stands for @f *) + GApp (loc, f, intern_args env args_scopes (List.map fst args)) + | CApp (loc, (isproj,f), args) -> - let isproj,f,args = match f with + let f,args = match f with (* Compact notations like "t.(f args') args" *) - | CApp (_,(Some _,f), args') when isproj=None -> isproj,f,args'@args + | CApp (_,(Some _,f), args') when not (Option.has_some isproj) -> + f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) - | _ -> isproj,f,args in + | _ -> f,args in let (c,impargs,args_scopes,l),args = match f with - | CRef ref -> intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref + | CRef (ref,us) -> + intern_applied_reference intern env + (Environ.named_context globalenv) lvar us args ref | CNotation (loc,ntn,([],[],[])) -> let c = intern_notation intern env lvar loc ntn ([],[],[]) in - find_appl_head_data c, args + let x, impl, scopes, l = find_appl_head_data c in + (x,impl,scopes,l), args | x -> (intern env f,[],[],[]), args in - let args = - intern_impargs c env impargs args_scopes (merge_impargs l args) in - check_projection isproj (List.length args) c; - (match c with - (* Now compact "(f args') args" *) - | GApp (loc', f', args') -> GApp (join_loc loc' loc, f',args'@args) - | _ -> GApp (loc, c, args)) + apply_impargs c env impargs args_scopes + (merge_impargs l args) loc + | CRecord (loc, _, fs) -> let cargs = sort_fields true loc fs - (fun k l -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: l) - in + (fun k l -> CHole (loc, Some (Evar_kinds.QuestionMark (Evar_kinds.Define true)), Misctypes.IntroAnonymous, None) :: l) + in begin match cargs with | None -> user_err_loc (loc, "intern", str"No constructor inference.") | Some (n, constrname, args) -> - let pars = list_make n (CHole (loc, None)) in - let app = CAppExpl (loc, (None, constrname), List.rev_append pars args) in + let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in + let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in intern env app end | CCases (loc, sty, rtnpo, tms, eqns) -> - let tms,env' = List.fold_right - (fun citm (inds,env) -> - let (tm,ind),nal = intern_case_item env citm in - (tm,ind)::inds,List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) - tms ([],env) in - let rtnpo = Option.map (intern_type env') rtnpo in + let as_in_vars = List.fold_left (fun acc (_,(na,inb)) -> + Option.fold_left (fun x tt -> List.fold_right Id.Set.add (ids_of_cases_indtype tt) x) + (Option.fold_left (fun x (_,y) -> match y with | Name y' -> Id.Set.add y' x |_ -> x) acc na) + inb) Id.Set.empty tms in + (* as, in & return vars *) + let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in + let tms,ex_ids,match_from_in = List.fold_right + (fun citm (inds,ex_ids,matchs) -> + let ((tm,ind),extra_id,match_td) = intern_case_item env forbidden_vars citm in + (tm,ind)::inds, Option.fold_right Id.Set.add extra_id ex_ids, List.rev_append match_td matchs) + tms ([],Id.Set.empty,[]) in + let env' = Id.Set.fold + (fun var bli -> push_name_env lvar (Variable,[],[],[]) bli (Loc.ghost,Name var)) + (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in + (* PatVars before a real pattern do not need to be matched *) + let stripped_match_from_in = let rec aux = function + |[] -> [] + |(_,PatVar _) :: q -> aux q + |l -> l + in aux match_from_in in + let rtnpo = match stripped_match_from_in with + | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) + | l -> let thevars,thepats=List.split l in + Some ( + GCases(Loc.ghost,Term.RegularStyle,(* Some (GSort (Loc.ghost,GType None)) *)None, (* "return Type" *) + List.map (fun id -> GVar (Loc.ghost,id),(Name id,None)) thevars, (* "match v1,..,vn" *) + [Loc.ghost,[],thepats, (* "|p1,..,pn" *) + Option.cata (intern_type env') (GHole(Loc.ghost,Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) rtnpo; (* "=> P" is there were a P "=> _" else *) + Loc.ghost,[],List.make (List.length thepats) (PatVar(Loc.ghost,Anonymous)), (* "|_,..,_" *) + GHole(Loc.ghost,Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None) (* "=> _" *)])) + in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in GCases (loc, sty, rtnpo, tms, List.flatten eqns') | CLetTuple (loc, nal, (na,po), b, c) -> let env' = reset_tmp_scope env in - let ((b',(na',_)),ids) = intern_case_item env' (b,(na,None)) in - let p' = Option.map (fun p -> - let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) env ids in - intern_type env'' p) po in + (* "in" is None so no match to add *) + let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,(na,None)) in + let p' = Option.map (fun u -> + let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') + (Loc.ghost,na') in + intern_type env'' u) po in GLetTuple (loc, List.map snd nal, (na', p'), b', intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (loc, c, (na,po), b1, b2) -> - let env' = reset_tmp_scope env in - let ((c',(na',_)),ids) = intern_case_item env' (c,(na,None)) in - let p' = Option.map (fun p -> - let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) ids in + let env' = reset_tmp_scope env in + let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,(na,None)) in (* no "in" no match to ad too *) + let p' = Option.map (fun p -> + let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) + (Loc.ghost,na') in intern_type env'' p) po in GIf (loc, c', (na', p'), intern env b1, intern env b2) - | CHole (loc, k) -> - GHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true)) + | CHole (loc, k, naming, solve) -> + let k = match k with + | None -> Evar_kinds.QuestionMark (Evar_kinds.Define true) + | Some k -> k + in + let solve = match solve with + | None -> None + | Some gen -> + let (ltacvars, ntnvars) = lvar in + let ntnvars = Id.Map.domain ntnvars in + let lvars = Id.Set.union ltacvars.ltac_bound ltacvars.ltac_vars in + let lvars = Id.Set.union lvars ntnvars in + let lvars = Id.Set.union lvars env.ids in + let ist = { + Genintern.ltacvars = lvars; + ltacrecvars = Id.Map.empty; + genv = globalenv; + } in + let (_, glb) = Genintern.generic_intern ist gen in + Some glb + in + GHole (loc, k, naming, solve) + (* Parsing pattern variables *) | CPatVar (loc, n) when allow_patvar -> - GPatVar (loc, n) - | CPatVar (loc, _) -> - raise (InternalizationError (loc,IllegalMetavariable)) + GPatVar (loc, (true,n)) + | CEvar (loc, n, []) when allow_patvar -> + GPatVar (loc, (false,n)) + (* end *) + (* Parsing existential variables *) | CEvar (loc, n, l) -> - GEvar (loc, n, Option.map (List.map (intern env)) l) + GEvar (loc, n, List.map (on_snd (intern env)) l) + | CPatVar (loc, _) -> + raise (InternalizationError (loc,IllegalMetavariable)) + (* end *) | CSort (loc, s) -> GSort(loc,s) - | CCast (loc, c1, CastConv (k, c2)) -> - GCast (loc,intern env c1, CastConv (k, intern_type env c2)) - | CCast (loc, c1, CastCoerce) -> - GCast (loc,intern env c1, CastCoerce) + | CCast (loc, c1, c2) -> + GCast (loc,intern env c1, Miscops.map_cast_type (intern_type env) c2) and intern_type env = intern (set_type_scope env) and intern_local_binder env bind = - intern_local_binder_aux intern intern_type lvar env bind + intern_local_binder_aux intern lvar env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) and intern_multiple_pattern env n (loc,pl) = let idsl_pll = - List.map (intern_cases_pattern globalenv {env with tmp_scope = None} ([],[])) pl in + List.map (intern_cases_pattern globalenv {env with tmp_scope = None} empty_alias) pl in check_number_of_pattern loc n pl; product_of_cases_patterns [] idsl_pll (* Expands a disjunction of multiple pattern *) and intern_disjunctive_multiple_pattern env loc n mpl = - assert (mpl <> []); + assert (not (List.is_empty mpl)); let mpl' = List.map (intern_multiple_pattern env n) mpl in let (idsl,mpl') = List.split mpl' in let ids = List.hd idsl in @@ -1378,91 +1617,77 @@ let internalize sigma globalenv env allow_patvar lvar c = let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in (* Linearity implies the order in ids is irrelevant *) check_linearity lhs eqn_ids; - let env_ids = List.fold_right Idset.add eqn_ids env.ids in + let env_ids = List.fold_right Id.Set.add eqn_ids env.ids in List.map (fun (asubst,pl) -> let rhs = replace_vars_constr_expr asubst rhs in - List.iter message_redundant_alias asubst; + Id.Map.iter message_redundant_alias asubst; let rhs' = intern {env with ids = env_ids} rhs in (loc,eqn_ids,pl,rhs')) pll - and intern_case_item env (tm,(na,t)) = + and intern_case_item env forbidden_names_for_gen (tm,(na,t)) = + (*the "match" part *) let tm' = intern env tm in - let ids,typ = match t with + (* the "as" part *) + let extra_id,na = match tm', na with + | GVar (loc,id), None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) + | GRef (loc, VarRef id, _), None -> Some id,(loc,Name id) + | _, None -> None,(Loc.ghost,Anonymous) + | _, Some (loc,na) -> None,(loc,na) in + (* the "in" part *) + let match_td,typ = match t with | Some t -> let tids = ids_of_cases_indtype t in - let tids = List.fold_right Idset.add tids Idset.empty in - let t = intern_type {env with ids = tids; tmp_scope = None} t in - let loc,ind,l = match t with - | GRef (loc,IndRef ind) -> (loc,ind,[]) - | GApp (loc,GRef (_,IndRef ind),l) -> (loc,ind,l) - | _ -> error_bad_inductive_type (loc_of_glob_constr t) in - let nparams, nrealargs = inductive_nargs globalenv ind in - let nindargs = nparams + nrealargs in - if List.length l <> nindargs then - error_wrong_numarg_inductive_loc loc globalenv ind nindargs; - let nal = List.map (function - | GHole (loc,_) -> loc,Anonymous - | GVar (loc,id) -> loc,Name id - | c -> user_err_loc (loc_of_glob_constr c,"",str "Not a name.")) l in - let parnal,realnal = list_chop nparams nal in - if List.exists (fun (_,na) -> na <> Anonymous) parnal then - error_inductive_parameter_not_implicit loc; - realnal, Some (loc,ind,nparams,List.map snd realnal) + let tids = List.fold_right Id.Set.add tids Id.Set.empty in + let with_letin,(ind,l) = intern_ind_pattern globalenv {env with ids = tids; tmp_scope = None} t in + let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in + let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in + (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) + + for "in Vect (S n)", we answer ((match over "m", relevant branch is "S + n"), abstract over "m") = ([("m","S n")],[(loc,"m")]) where "m" is + generated from the canonical name of the inductive and outside of + {forbidden_names_for_gen} *) + let (match_to_do,nal) = + let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc = + let add_name l = function + |_,Anonymous -> l + |loc,(Name y as x) -> (y,PatVar(loc,x)) :: l in + match case_rel_ctxt,arg_pats with + (* LetIn in the rel_context *) + |(_,Some _,_)::t, l when not with_letin -> + canonize_args t l forbidden_names match_acc ((Loc.ghost,Anonymous)::var_acc) + |[],[] -> + (add_name match_acc na, var_acc) + |_::t,PatVar (loc,x)::tt -> + canonize_args t tt forbidden_names + (add_name match_acc (loc,x)) ((loc,x)::var_acc) + |(cano_name,_,ty)::t,c::tt -> + let fresh = + Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names ty in + canonize_args t tt (fresh::forbidden_names) + ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc) + |_ -> assert false in + let _,args_rel = + List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in + canonize_args args_rel l (Id.Set.elements forbidden_names_for_gen) [] [] in + match_to_do, Some (cases_pattern_expr_loc t,ind,List.rev_map snd nal) | None -> - [], None in - let na = match tm', na with - | GVar (loc,id), None when not (List.mem_assoc id (snd lvar)) -> - loc,Name id - | GRef (loc, VarRef id), None -> loc,Name id - | _, None -> dummy_loc,Anonymous - | _, Some (loc,na) -> loc,na in - (tm',(snd na,typ)), na::ids + [], None in + (tm',(snd na,typ)), extra_id, match_td and iterate_prod loc2 env bk ty body nal = - let default env bk = function - | (loc1,na)::nal' as nal -> - if nal' <> [] then check_capture loc1 ty na; - let ty = intern_type env ty in - let impls = impls_type_list ty in - let env = List.fold_left (push_name_env lvar impls) env nal in - List.fold_right (fun (loc,na) c -> - GProd (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c)) - nal (intern_type env body) - | [] -> assert false - in - match bk with - | Default b -> default env b nal - | Generalized (b,b',t) -> - let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in - let body = intern_type env body in - it_mkGProd ibind body + let env, bl = intern_assumption intern lvar env nal bk ty in + it_mkGProd loc2 bl (intern_type env body) and iterate_lam loc2 env bk ty body nal = - let default env bk = function - | (loc1,na)::nal' as nal -> - if nal' <> [] then check_capture loc1 ty na; - let ty = intern_type env ty in - let impls = impls_type_list ty in - let env = List.fold_left (push_name_env lvar impls) env nal in - List.fold_right (fun (loc,na) c -> - GLambda (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c)) - nal (intern env body) - | [] -> assert false - in match bk with - | Default b -> default env b nal - | Generalized (b, b', t) -> - let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in - let body = intern env body in - it_mkGLambda ibind body + let env, bl = intern_assumption intern lvar env nal bk ty in + it_mkGLambda loc2 bl (intern env body) and intern_impargs c env l subscopes args = - let l = select_impargs_size (List.length args) l in let eargs, rargs = extract_explicit_arg l args in if !parsing_explicit then - if eargs <> [] then - error "Arguments given by name or position not supported in explicit mode." - else - intern_args env subscopes rargs + if Id.Map.is_empty eargs then intern_args env subscopes rargs + else error "Arguments given by name or position not supported in explicit mode." else let rec aux n impl subscopes eargs rargs = let (enva,subscopes') = apply_scope_env env subscopes in @@ -1470,11 +1695,11 @@ let internalize sigma globalenv env allow_patvar lvar c = | (imp::impl', rargs) when is_status_implicit imp -> begin try let id = name_of_implicit imp in - let (_,a) = List.assoc id eargs in - let eargs' = List.remove_assoc id eargs in + let (_,a) = Id.Map.find id eargs in + let eargs' = Id.Map.remove id eargs in intern enva a :: aux (n+1) impl' subscopes' eargs' rargs with Not_found -> - if rargs=[] & eargs=[] & not (maximal_insertion_of imp) then + if List.is_empty rargs && Id.Map.is_empty eargs && not (maximal_insertion_of imp) then (* Less regular arguments than expected: complete *) (* with implicit arguments if maximal insertion is set *) [] @@ -1485,17 +1710,28 @@ let internalize sigma globalenv env allow_patvar lvar c = | (imp::impl', a::rargs') -> intern enva a :: aux (n+1) impl' subscopes' eargs rargs' | (imp::impl', []) -> - if eargs <> [] then - (let (id,(loc,_)) = List.hd eargs in + if not (Id.Map.is_empty eargs) then + (let (id,(loc,_)) = Id.Map.choose eargs in user_err_loc (loc,"",str "Not enough non implicit \ arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] | ([], rargs) -> - assert (eargs = []); + assert (Id.Map.is_empty eargs); intern_args env subscopes rargs in aux 1 l subscopes eargs rargs + and apply_impargs c env imp subscopes l loc = + let imp = select_impargs_size (List.length l) imp in + let l = intern_impargs c env imp subscopes l in + smart_gapp c loc l + + and smart_gapp f loc = function + | [] -> f + | l -> match f with + | GApp (loc', g, args) -> GApp (Loc.merge loc' loc, g, args@l) + | _ -> GApp (Loc.merge (loc_of_glob_constr f) loc, f, l) + and intern_args env subscopes = function | [] -> [] | a::args -> @@ -1515,29 +1751,38 @@ let internalize sigma globalenv env allow_patvar lvar c = (**************************************************************************) let extract_ids env = - List.fold_right Idset.add + List.fold_right Id.Set.add (Termops.ids_of_rel_context (Environ.rel_context env)) - Idset.empty + Id.Set.empty + +let scope_of_type_kind = function + | IsType -> Some Notation.type_scope + | OfType typ -> compute_type_scope typ + | WithoutTypeConstraint -> None + +let empty_ltac_sign = { + ltac_vars = Id.Set.empty; + ltac_bound = Id.Set.empty; +} -let intern_gen isarity sigma env - ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[])) +let intern_gen kind env + ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=empty_ltac_sign) c = - let tmp_scope = - if isarity then Some Notation.type_scope else None in - internalize sigma env {ids = extract_ids env; unb = false; - tmp_scope = tmp_scope; scopes = []; - impls = impls} - allow_patvar (ltacvars, []) c + let tmp_scope = scope_of_type_kind kind in + internalize env {ids = extract_ids env; unb = false; + tmp_scope = tmp_scope; scopes = []; + impls = impls} + allow_patvar (ltacvars, Id.Map.empty) c -let intern_constr sigma env c = intern_gen false sigma env c +let intern_constr env c = intern_gen WithoutTypeConstraint env c -let intern_type sigma env c = intern_gen true sigma env c +let intern_type env c = intern_gen IsType env c let intern_pattern globalenv patt = try intern_cases_pattern globalenv {ids = extract_ids globalenv; unb = false; tmp_scope = None; scopes = []; - impls = empty_internalization_env} ([],[]) patt + impls = empty_internalization_env} empty_alias patt with InternalizationError (loc,e) -> user_err_loc (loc,"internalize",explain_internalization_error e) @@ -1546,158 +1791,135 @@ let intern_pattern globalenv patt = (*********************************************************************) (* Functions to parse and interpret constructions *) -let interp_gen kind sigma env - ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[])) - c = - let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in - Default.understand_gen kind sigma env c +(* All evars resolved *) -let interp_constr sigma env c = - interp_gen (OfType None) sigma env c +let interp_gen kind env sigma ?(impls=empty_internalization_env) c = + let c = intern_gen kind ~impls env c in + understand ~expected_type:kind env sigma c -let interp_type sigma env ?(impls=empty_internalization_env) c = - interp_gen IsType sigma env ~impls c +let interp_constr env sigma ?(impls=empty_internalization_env) c = + interp_gen WithoutTypeConstraint env sigma c -let interp_casted_constr sigma env ?(impls=empty_internalization_env) c typ = - interp_gen (OfType (Some typ)) sigma env ~impls c +let interp_type env sigma ?(impls=empty_internalization_env) c = + interp_gen IsType env sigma ~impls c -let interp_open_constr sigma env c = - Default.understand_tcc sigma env (intern_constr sigma env c) +let interp_casted_constr env sigma ?(impls=empty_internalization_env) c typ = + interp_gen (OfType typ) env sigma ~impls c -let interp_open_constr_patvar sigma env c = - let raw = intern_gen false sigma env c ~allow_patvar:true in - let sigma = ref sigma in - let evars = ref (Gmap.empty : (identifier,glob_constr) Gmap.t) in - let rec patvar_to_evar r = match r with - | GPatVar (loc,(_,id)) -> - ( try Gmap.find id !evars - with Not_found -> - let ev = Evarutil.e_new_evar sigma env (Termops.new_Type()) in - let ev = Evarutil.e_new_evar sigma env ev in - let rev = GEvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in - evars := Gmap.add id rev !evars; - rev - ) - | _ -> map_glob_constr patvar_to_evar r in - let raw = patvar_to_evar raw in - Default.understand_tcc !sigma env raw - -let interp_constr_judgment sigma env c = - Default.understand_judgment sigma env (intern_constr sigma env c) - -let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true) - env ?(impls=empty_internalization_env) kind c = - let evdref = - match evdref with - | None -> ref Evd.empty - | Some evdref -> evdref - in - let istype = kind = IsType in - let c = intern_gen istype ~impls !evdref env c in - let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:istype c in - Default.understand_tcc_evars ~fail_evar evdref env kind c, imps +(* Not all evars expected to be resolved *) + +let interp_open_constr env sigma c = + understand_tcc env sigma (intern_constr env c) -let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true) - env ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c +(* Not all evars expected to be resolved and computation of implicit args *) -let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c +let interp_constr_evars_gen_impls env evdref + ?(impls=empty_internalization_env) expected_type c = + let c = intern_gen expected_type ~impls env c in + let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in + understand_tcc_evars env evdref ~expected_type c, imps -let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c +let interp_constr_evars_impls env evdref ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls env evdref ~impls WithoutTypeConstraint c -let interp_constr_evars_gen evdref env ?(impls=empty_internalization_env) kind c = - let c = intern_gen (kind=IsType) ~impls !evdref env c in - Default.understand_tcc_evars evdref env kind c +let interp_casted_constr_evars_impls env evdref ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen_impls env evdref ~impls (OfType typ) c -let interp_casted_constr_evars evdref env ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c +let interp_type_evars_impls env evdref ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls env evdref ~impls IsType c -let interp_type_evars evdref env ?(impls=empty_internalization_env) c = - interp_constr_evars_gen evdref env IsType ~impls c +(* Not all evars expected to be resolved, with side-effect on evars *) -type ltac_sign = identifier list * unbound_ltac_var_map +let interp_constr_evars_gen env evdref ?(impls=empty_internalization_env) expected_type c = + let c = intern_gen expected_type ~impls env c in + understand_tcc_evars env evdref ~expected_type c -let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c = - let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in +let interp_constr_evars env evdref ?(impls=empty_internalization_env) c = + interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c + +let interp_casted_constr_evars env evdref ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen env evdref ~impls (OfType typ) c + +let interp_type_evars env evdref ?(impls=empty_internalization_env) c = + interp_constr_evars_gen env evdref IsType ~impls c + +(* Miscellaneous *) + +let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = + let c = intern_gen (if as_type then IsType else WithoutTypeConstraint) + ~allow_patvar:true ~ltacvars env c in pattern_of_glob_constr c -let interp_aconstr ?(impls=empty_internalization_env) vars recvars a = +let interp_notation_constr ?(impls=empty_internalization_env) nenv a = let env = Global.env () in (* [vl] is intended to remember the scope of the free variables of [a] *) - let vl = List.map (fun (id,typ) -> (id,(ref None,typ))) vars in - let c = internalize Evd.empty (Global.env()) {ids = extract_ids env; unb = false; + let vl = Id.Map.map (fun typ -> (ref None, typ)) nenv.ninterp_var_type in + let c = internalize (Global.env()) {ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impls} - false (([],[]),vl) a in + false (empty_ltac_sign, vl) a in (* Translate and check that [c] has all its free variables bound in [vars] *) - let a = aconstr_of_glob_constr vars recvars c in + let a = notation_constr_of_glob_constr nenv c in (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in - let vars = List.map (fun (id,(sc,typ)) -> (id,(out_scope !sc,typ))) vl in + let vars = Id.Map.map (fun (sc, typ) -> (out_scope !sc, typ)) vl in (* Returns [a] and the ordered list of variables with their scopes *) vars, a (* Interpret binders and contexts *) -let interp_binder sigma env na t = - let t = intern_gen true sigma env t in - let t' = locate_if_isevar (loc_of_glob_constr t) na t in - Default.understand_type sigma env t' +let interp_binder env sigma na t = + let t = intern_gen IsType env t in + let t' = locate_if_hole (loc_of_glob_constr t) na t in + understand ~expected_type:IsType env sigma t' -let interp_binder_evars evdref env na t = - let t = intern_gen true !evdref env t in - let t' = locate_if_isevar (loc_of_glob_constr t) na t in - Default.understand_tcc_evars evdref env IsType t' +let interp_binder_evars env evdref na t = + let t = intern_gen IsType env t in + let t' = locate_if_hole (loc_of_glob_constr t) na t in + understand_tcc_evars env evdref ~expected_type:IsType t' open Environ -open Term -let my_intern_constr sigma env lvar acc c = - internalize sigma env acc false lvar c +let my_intern_constr env lvar acc c = + internalize env acc false lvar c -let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c - -let intern_context global_level sigma env impl_env params = - let lvar = (([],[]), []) in +let intern_context global_level env impl_env binders = + try + let lvar = (empty_ltac_sign, Id.Map.empty) in let lenv, bl = List.fold_left - (intern_local_binder_aux ~global_level (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) + (intern_local_binder_aux ~global_level (my_intern_constr env lvar) lvar) ({ids = extract_ids env; unb = false; - tmp_scope = None; scopes = []; impls = impl_env}, []) params in (lenv.impls, bl) + tmp_scope = None; scopes = []; impls = impl_env}, []) binders in + (lenv.impls, List.map snd bl) + with InternalizationError (loc,e) -> + user_err_loc (loc,"internalize", explain_internalization_error e) -let interp_rawcontext_gen understand_type understand_judgment env bl = +let interp_rawcontext_evars env evdref bl = let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> match b with None -> - let t' = locate_if_isevar (loc_of_glob_constr t) na t in - let t = understand_type env t' in + let t' = locate_if_hole (loc_of_glob_constr t) na t in + let t = + understand_tcc_evars env evdref ~expected_type:IsType t' in let d = (na,None,t) in let impls = - if k = Implicit then + if k == Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls else impls in (push_rel d env, d::params, succ n, impls) | Some b -> - let c = understand_judgment env b in - let d = (na, Some c.uj_val, Termops.refresh_universes c.uj_type) in + let c = understand_judgment_tcc env evdref b in + let d = (na, Some c.uj_val, c.uj_type) in (push_rel d env, d::params, succ n, impls)) (env,[],1,[]) (List.rev bl) in (env, par), impls -let interp_context_gen understand_type understand_judgment ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params = - let int_env,bl = intern_context global_level sigma env impl_env params in - int_env, interp_rawcontext_gen understand_type understand_judgment env bl - -let interp_context ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params = - interp_context_gen (Default.understand_type sigma) - (Default.understand_judgment sigma) ~global_level ~impl_env sigma env params - -let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) evdref env params = - interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t) - (Default.understand_judgment_tcc evdref) ~global_level ~impl_env !evdref env params +let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) env evdref params = + let int_env,bl = intern_context global_level env impl_env params in + let x = interp_rawcontext_evars env evdref bl in + int_env, x diff --git a/interp/constrintern.mli b/interp/constrintern.mli index b8b3d995..792e6f63 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* var_internalization_type -> types -> Impargs.manual_explicitation list -> var_internalization_data val compute_internalization_env : env -> var_internalization_type -> - identifier list -> types list -> Impargs.manual_explicitation list list -> + Id.t list -> types list -> Impargs.manual_explicitation list list -> internalization_env -type ltac_sign = identifier list * unbound_ltac_var_map +type ltac_sign = { + ltac_vars : Id.Set.t; + (** Variables of Ltac which may be bound to a term *) + ltac_bound : Id.Set.t; + (** Other variables of Ltac *) +} -type glob_binder = (name * binding_kind * glob_constr option * glob_constr) +val empty_ltac_sign : ltac_sign + +type glob_binder = (Name.t * binding_kind * glob_constr option * glob_constr) (** {6 Internalization performs interpretation of global names and notations } *) -val intern_constr : evar_map -> env -> constr_expr -> glob_constr +val intern_constr : env -> constr_expr -> glob_constr -val intern_type : evar_map -> env -> constr_expr -> glob_constr +val intern_type : env -> constr_expr -> glob_constr -val intern_gen : bool -> evar_map -> env -> +val intern_gen : typing_constraint -> env -> ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> glob_constr val intern_pattern : env -> cases_pattern_expr -> - Names.identifier list * - ((Names.identifier * Names.identifier) list * Glob_term.cases_pattern) list - -val intern_context : bool -> evar_map -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list + Id.t list * (Id.t Id.Map.t * cases_pattern) list -(** {6 Composing internalization with pretyping } *) +val intern_context : bool -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list -(** Main interpretation function *) - -val interp_gen : typing_constraint -> evar_map -> env -> - ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> - constr_expr -> constr +(** {6 Composing internalization with type inference (pretyping) } *) -(** Particular instances *) +(** Main interpretation functions expecting evars to be all resolved *) -val interp_constr : evar_map -> env -> - constr_expr -> constr +val interp_constr : env -> evar_map -> ?impls:internalization_env -> + constr_expr -> constr Evd.in_evar_universe_context -val interp_type : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> types +val interp_casted_constr : env -> evar_map -> ?impls:internalization_env -> + constr_expr -> types -> constr Evd.in_evar_universe_context -val interp_open_constr : evar_map -> env -> constr_expr -> evar_map * constr +val interp_type : env -> evar_map -> ?impls:internalization_env -> + constr_expr -> types Evd.in_evar_universe_context -val interp_open_constr_patvar : evar_map -> env -> constr_expr -> evar_map * constr +(** Main interpretation function expecting evars to be all resolved *) -val interp_casted_constr : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> types -> constr +val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr -(** Accepting evars and giving back the manual implicits in addition. *) +(** Accepting unresolved evars *) -val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env -> - ?impls:internalization_env -> constr_expr -> types -> constr * Impargs.manual_implicits +val interp_constr_evars : env -> evar_map ref -> + ?impls:internalization_env -> constr_expr -> constr -val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> - env -> ?impls:internalization_env -> - constr_expr -> types * Impargs.manual_implicits +val interp_casted_constr_evars : env -> evar_map ref -> + ?impls:internalization_env -> constr_expr -> types -> constr -val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> - env -> ?impls:internalization_env -> - constr_expr -> constr * Impargs.manual_implicits +val interp_type_evars : env -> evar_map ref -> + ?impls:internalization_env -> constr_expr -> types -val interp_casted_constr_evars : evar_map ref -> env -> - ?impls:internalization_env -> constr_expr -> types -> constr +(** Accepting unresolved evars and giving back the manual implicit arguments *) -val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env -> - constr_expr -> types +val interp_constr_evars_impls : env -> evar_map ref -> + ?impls:internalization_env -> constr_expr -> + constr * Impargs.manual_implicits -(** {6 Build a judgment } *) +val interp_casted_constr_evars_impls : env -> evar_map ref -> + ?impls:internalization_env -> constr_expr -> types -> + constr * Impargs.manual_implicits -val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment +val interp_type_evars_impls : env -> evar_map ref -> + ?impls:internalization_env -> constr_expr -> + types * Impargs.manual_implicits (** Interprets constr patterns *) val intern_constr_pattern : - evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign -> + env -> ?as_type:bool -> ?ltacvars:ltac_sign -> constr_pattern_expr -> patvar list * constr_pattern (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) @@ -144,39 +149,42 @@ val interp_reference : ltac_sign -> reference -> glob_constr (** Interpret binders *) -val interp_binder : evar_map -> env -> name -> constr_expr -> types +val interp_binder : env -> evar_map -> Name.t -> constr_expr -> + types Evd.in_evar_universe_context -val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types +val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> types (** Interpret contexts: returns extended env and context *) -val interp_context_gen : (env -> glob_constr -> types) -> - (env -> glob_constr -> unsafe_judgment) -> +val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> - evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) - -val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> - evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) + env -> evar_map ref -> local_binder list -> + internalization_env * ((env * rel_context) * Impargs.manual_implicits) -val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> - evar_map ref -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) +(* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) +(* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) +(* ?global_level:bool -> ?impl_env:internalization_env -> *) +(* env -> evar_map -> local_binder list -> internalization_env * ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) + +(* val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> *) +(* env -> evar_map -> local_binder list -> *) +(* internalization_env * *) +(* ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) -val is_global : identifier -> bool -val construct_reference : named_context -> identifier -> constr -val global_reference : identifier -> constr -val global_reference_in_absolute_module : dir_path -> identifier -> constr - -(** Interprets a term as the left-hand side of a notation; the boolean - list is a set and this set is [true] for a variable occurring in - term position, [false] for a variable occurring in binding - position; [true;false] if in both kinds of position *) -val interp_aconstr : ?impls:internalization_env -> - (identifier * notation_var_internalization_type) list -> - (identifier * identifier) list -> constr_expr -> - (identifier * (subscopes * notation_var_internalization_type)) list * aconstr +val is_global : Id.t -> bool +val construct_reference : named_context -> Id.t -> constr +val global_reference : Id.t -> constr +val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr + +(** Interprets a term as the left-hand side of a notation. The returned map is + guaranteed to have the same domain as the input one. *) +val interp_notation_constr : ?impls:internalization_env -> + notation_interp_env -> constr_expr -> + (subscopes * notation_var_internalization_type) Id.Map.t * + notation_constr (** Globalization options *) val parsing_explicit : bool ref diff --git a/interp/coqlib.ml b/interp/coqlib.ml index e446d177..e722615a 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -1,34 +1,38 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* anomaly (locstr^": cannot find "^(string_of_path sp)) + with Not_found -> + anomaly ~label:locstr (str "cannot find " ++ Libnames.pr_path sp) -let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s -let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s) +let coq_reference locstr dir s = find_reference locstr (coq::dir) s +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let gen_reference = coq_reference let gen_constant = coq_constant @@ -40,103 +44,119 @@ let has_suffix_in_dirs dirs ref = let global_of_extended q = try Some (global_of_extended_global q) with Not_found -> None -let gen_constant_in_modules locstr dirs s = +let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_extended_all qualid in - let all = list_uniquize (list_map_filter global_of_extended all) in + let all = List.map_filter global_of_extended all in + let all = List.sort_uniquize RefOrdered_env.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with - | [x] -> constr_of_global x + | [x] -> x | [] -> - anomalylabstrm "" (str (locstr^": cannot find "^s^ + anomaly ~label:locstr (str ("cannot find "^s^ " in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_comma pr_dirpath dirs) | l -> - anomalylabstrm "" - (str (locstr^": found more than once object of name "^s^ - " in module"^(if List.length dirs > 1 then "s " else " ")) ++ - prlist_with_sep pr_comma pr_dirpath dirs) + anomaly ~label:locstr + (str ("ambiguous name "^s^" can represent ") ++ + prlist_with_sep pr_comma + (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ + str (" in module"^(if List.length dirs > 1 then "s " else " ")) ++ + prlist_with_sep pr_comma pr_dirpath dirs) + +let gen_constant_in_modules locstr dirs s = + Universes.constr_of_global (gen_reference_in_modules locstr dirs s) (* For tactics/commands requiring vernacular libraries *) let check_required_library d = - let d' = List.map id_of_string d in - let dir = make_dirpath (List.rev d') in - let mp = (fst(Lib.current_prefix())) in - let current_dir = match mp with - | MPfile dp -> (dir=dp) - | _ -> false - in - if not (Library.library_is_loaded dir) then - if not current_dir then + let dir = make_dir d in + if Library.library_is_loaded dir then () + else + let in_current_dir = match Lib.current_mp () with + | MPfile dp -> DirPath.equal dir dp + | _ -> false + in + if not in_current_dir then (* Loading silently ... - let m, prefix = list_sep_last d' in + let m, prefix = List.sep_last d' in read_library - (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m) + (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m) *) (* or failing ...*) - error ("Library "^(string_of_dirpath dir)^" has to be required first.") + error ("Library "^(DirPath.to_string dir)^" has to be required first.") (************************************************************************) (* Specific Coq objects *) -let init_reference dir s = gen_reference "Coqlib" ("Init"::dir) s +let init_reference dir s = + let d = "Init"::dir in + check_required_library (coq::d); gen_reference "Coqlib" d s -let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s +let init_constant dir s = + let d = "Init"::dir in + check_required_library (coq::d); gen_constant "Coqlib" d s -let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s +let logic_reference dir s = + let d = "Logic"::dir in + check_required_library ("Coq"::d); gen_reference "Coqlib" d s -let arith_dir = ["Coq";"Arith"] +let arith_dir = [coq;"Arith"] let arith_modules = [arith_dir] -let numbers_dir = [ "Coq";"Numbers"] -let parith_dir = ["Coq";"PArith"] -let narith_dir = ["Coq";"NArith"] -let zarith_dir = ["Coq";"ZArith"] +let numbers_dir = [coq;"Numbers"] +let parith_dir = [coq;"PArith"] +let narith_dir = [coq;"NArith"] +let zarith_dir = [coq;"ZArith"] let zarith_base_modules = [numbers_dir;parith_dir;narith_dir;zarith_dir] -let init_dir = ["Coq";"Init"] +let init_dir = [coq;"Init"] let init_modules = [ init_dir@["Datatypes"]; init_dir@["Logic"]; init_dir@["Specif"]; init_dir@["Logic_Type"]; + init_dir@["Nat"]; init_dir@["Peano"]; init_dir@["Wf"] ] -let logic_module_name = ["Coq";"Init";"Logic"] +let prelude_module_name = init_dir@["Prelude"] +let prelude_module = make_dir prelude_module_name + +let logic_module_name = init_dir@["Logic"] let logic_module = make_dir logic_module_name -let logic_type_module_name = ["Coq";"Init";"Logic_Type"] +let logic_type_module_name = init_dir@["Logic_Type"] let logic_type_module = make_dir logic_type_module_name -let datatypes_module_name = ["Coq";"Init";"Datatypes"] +let datatypes_module_name = init_dir@["Datatypes"] let datatypes_module = make_dir datatypes_module_name -let arith_module_name = ["Coq";"Arith";"Arith"] -let arith_module = make_dir arith_module_name - -let jmeq_module_name = ["Coq";"Logic";"JMeq"] +let jmeq_module_name = [coq;"Logic";"JMeq"] let jmeq_module = make_dir jmeq_module_name -(* TODO: temporary hack *) -let make_kn dir id = Libnames.encode_mind dir id -let make_con dir id = Libnames.encode_con dir id +(* TODO: temporary hack. Works only if the module isn't an alias *) +let make_ind dir id = Globnames.encode_mind dir (Id.of_string id) +let make_con dir id = Globnames.encode_con dir (Id.of_string id) (** Identity *) -let id = make_con datatypes_module (id_of_string "id") -let type_of_id = make_con datatypes_module (id_of_string "ID") +let id = make_con datatypes_module "idProp" +let type_of_id = make_con datatypes_module "IDProp" -let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id) +let _ = Termops.set_impossible_default_clause + (fun () -> + let c, ctx = Universes.fresh_global_instance (Global.env()) (ConstRef id) in + let (_, u) = destConst c in + (c,mkConstU (type_of_id,u)), ctx) (** Natural numbers *) -let nat_kn = make_kn datatypes_module (id_of_string "nat") -let nat_path = Libnames.make_path datatypes_module (id_of_string "nat") +let nat_kn = make_ind datatypes_module "nat" +let nat_path = Libnames.make_path datatypes_module (Id.of_string "nat") let glob_nat = IndRef (nat_kn,0) @@ -146,7 +166,7 @@ let glob_O = ConstructRef path_of_O let glob_S = ConstructRef path_of_S (** Booleans *) -let bool_kn = make_kn datatypes_module (id_of_string "bool") +let bool_kn = make_ind datatypes_module "bool" let glob_bool = IndRef (bool_kn,0) @@ -156,21 +176,21 @@ let glob_true = ConstructRef path_of_true let glob_false = ConstructRef path_of_false (** Equality *) -let eq_kn = make_kn logic_module (id_of_string "eq") +let eq_kn = make_ind logic_module "eq" let glob_eq = IndRef (eq_kn,0) -let identity_kn = make_kn datatypes_module (id_of_string "identity") +let identity_kn = make_ind datatypes_module "identity" let glob_identity = IndRef (identity_kn,0) -let jmeq_kn = make_kn jmeq_module (id_of_string "JMeq") +let jmeq_kn = make_ind jmeq_module "JMeq" let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } + proj1 : global_reference; + proj2 : global_reference; + elim : global_reference; + intro : global_reference; + typ : global_reference } type coq_bool_data = { andb : constr; @@ -182,59 +202,61 @@ let build_bool_type () = andb_prop = init_constant ["Datatypes"] "andb_prop"; andb_true_intro = init_constant ["Datatypes"] "andb_true_intro" } -let build_sigma_set () = anomaly "Use build_sigma_type" +let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type") let build_sigma_type () = - { proj1 = init_constant ["Specif"] "projT1"; - proj2 = init_constant ["Specif"] "projT2"; - elim = init_constant ["Specif"] "sigT_rect"; - intro = init_constant ["Specif"] "existT"; - typ = init_constant ["Specif"] "sigT" } + { proj1 = init_reference ["Specif"] "projT1"; + proj2 = init_reference ["Specif"] "projT2"; + elim = init_reference ["Specif"] "sigT_rect"; + intro = init_reference ["Specif"] "existT"; + typ = init_reference ["Specif"] "sigT" } let build_sigma () = - { proj1 = init_constant ["Specif"] "proj1_sig"; - proj2 = init_constant ["Specif"] "proj2_sig"; - elim = init_constant ["Specif"] "sig_rect"; - intro = init_constant ["Specif"] "exist"; - typ = init_constant ["Specif"] "sig" } + { proj1 = init_reference ["Specif"] "proj1_sig"; + proj2 = init_reference ["Specif"] "proj2_sig"; + elim = init_reference ["Specif"] "sig_rect"; + intro = init_reference ["Specif"] "exist"; + typ = init_reference ["Specif"] "sig" } + let build_prod () = - { proj1 = init_constant ["Datatypes"] "fst"; - proj2 = init_constant ["Datatypes"] "snd"; - elim = init_constant ["Datatypes"] "prod_rec"; - intro = init_constant ["Datatypes"] "pair"; - typ = init_constant ["Datatypes"] "prod" } + { proj1 = init_reference ["Datatypes"] "fst"; + proj2 = init_reference ["Datatypes"] "snd"; + elim = init_reference ["Datatypes"] "prod_rec"; + intro = init_reference ["Datatypes"] "pair"; + typ = init_reference ["Datatypes"] "prod" } (* Equalities *) type coq_eq_data = { - eq : constr; - ind : constr; - refl : constr; - sym : constr; - trans: constr; - congr: constr } + eq : global_reference; + ind : global_reference; + refl : global_reference; + sym : global_reference; + trans: global_reference; + congr: global_reference } (* Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : constr; (* : forall params, t -> Prop *) - inv_ind : constr; (* : forall params P y, eq params y -> P y *) - inv_congr: constr (* : forall params B (f:t->B) y, eq params y -> f c=f y *) + inv_eq : global_reference; (* : forall params, t -> Prop *) + inv_ind : global_reference; (* : forall params P y, eq params y -> P y *) + inv_congr: global_reference (* : forall params B (f:t->B) y, eq params y -> f c=f y *) } +let lazy_init_reference dir id = lazy (init_reference dir id) let lazy_init_constant dir id = lazy (init_constant dir id) -let lazy_logic_constant dir id = lazy (logic_constant dir id) +let lazy_logic_reference dir id = lazy (logic_reference dir id) (* Leibniz equality on Type *) -let coq_eq_eq = lazy_init_constant ["Logic"] "eq" -let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl" -let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind" -let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal" -let coq_eq_sym = lazy_init_constant ["Logic"] "eq_sym" -let coq_eq_trans = lazy_init_constant ["Logic"] "eq_trans" -let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2" +let coq_eq_eq = lazy_init_reference ["Logic"] "eq" +let coq_eq_refl = lazy_init_reference ["Logic"] "eq_refl" +let coq_eq_ind = lazy_init_reference ["Logic"] "eq_ind" +let coq_eq_congr = lazy_init_reference ["Logic"] "f_equal" +let coq_eq_sym = lazy_init_reference ["Logic"] "eq_sym" +let coq_eq_trans = lazy_init_reference ["Logic"] "eq_trans" +let coq_f_equal2 = lazy_init_reference ["Logic"] "f_equal2" let coq_eq_congr_canonical = - lazy_init_constant ["Logic"] "f_equal_canonical_form" + lazy_init_reference ["Logic"] "f_equal_canonical_form" let build_coq_eq_data () = let _ = check_required_library logic_module_name in { @@ -258,14 +280,15 @@ let build_coq_inversion_eq_data () = (* Heterogenous equality on Type *) -let coq_jmeq_eq = lazy_logic_constant ["JMeq"] "JMeq" -let coq_jmeq_refl = lazy_logic_constant ["JMeq"] "JMeq_refl" -let coq_jmeq_ind = lazy_logic_constant ["JMeq"] "JMeq_ind" -let coq_jmeq_sym = lazy_logic_constant ["JMeq"] "JMeq_sym" -let coq_jmeq_congr = lazy_logic_constant ["JMeq"] "JMeq_congr" -let coq_jmeq_trans = lazy_logic_constant ["JMeq"] "JMeq_trans" +let coq_jmeq_eq = lazy_logic_reference ["JMeq"] "JMeq" +let coq_jmeq_hom = lazy_logic_reference ["JMeq"] "JMeq_hom" +let coq_jmeq_refl = lazy_logic_reference ["JMeq"] "JMeq_refl" +let coq_jmeq_ind = lazy_logic_reference ["JMeq"] "JMeq_ind" +let coq_jmeq_sym = lazy_logic_reference ["JMeq"] "JMeq_sym" +let coq_jmeq_congr = lazy_logic_reference ["JMeq"] "JMeq_congr" +let coq_jmeq_trans = lazy_logic_reference ["JMeq"] "JMeq_trans" let coq_jmeq_congr_canonical = - lazy_logic_constant ["JMeq"] "JMeq_congr_canonical_form" + lazy_logic_reference ["JMeq"] "JMeq_congr_canonical_form" let build_coq_jmeq_data () = let _ = check_required_library jmeq_module_name in { @@ -276,14 +299,9 @@ let build_coq_jmeq_data () = trans = Lazy.force coq_jmeq_trans; congr = Lazy.force coq_jmeq_congr } -let join_jmeq_types eq = - mkLambda(Name (id_of_string "A"),Termops.new_Type(), - mkLambda(Name (id_of_string "x"),mkRel 1, - mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|]))) - let build_coq_inversion_jmeq_data () = let _ = check_required_library logic_module_name in { - inv_eq = join_jmeq_types (Lazy.force coq_jmeq_eq); + inv_eq = Lazy.force coq_jmeq_hom; inv_ind = Lazy.force coq_jmeq_ind; inv_congr = Lazy.force coq_jmeq_congr_canonical } @@ -293,13 +311,13 @@ let coq_sumbool = lazy_init_constant ["Specif"] "sumbool" let build_coq_sumbool () = Lazy.force coq_sumbool (* Equality on Type as a Type *) -let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity" -let coq_identity_refl = lazy_init_constant ["Datatypes"] "identity_refl" -let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind" -let coq_identity_congr = lazy_init_constant ["Logic_Type"] "identity_congr" -let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym" -let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans" -let coq_identity_congr_canonical = lazy_init_constant ["Logic_Type"] "identity_congr_canonical_form" +let coq_identity_eq = lazy_init_reference ["Datatypes"] "identity" +let coq_identity_refl = lazy_init_reference ["Datatypes"] "identity_refl" +let coq_identity_ind = lazy_init_reference ["Datatypes"] "identity_ind" +let coq_identity_congr = lazy_init_reference ["Logic_Type"] "identity_congr" +let coq_identity_sym = lazy_init_reference ["Logic_Type"] "identity_sym" +let coq_identity_trans = lazy_init_reference ["Logic_Type"] "identity_trans" +let coq_identity_congr_canonical = lazy_init_reference ["Logic_Type"] "identity_congr_canonical_form" let build_coq_identity_data () = let _ = check_required_library datatypes_module_name in { @@ -318,9 +336,9 @@ let build_coq_inversion_identity_data () = inv_congr = Lazy.force coq_identity_congr_canonical } (* Equality to true *) -let coq_eq_true_eq = lazy_init_constant ["Datatypes"] "eq_true" -let coq_eq_true_ind = lazy_init_constant ["Datatypes"] "eq_true_ind" -let coq_eq_true_congr = lazy_init_constant ["Logic"] "eq_true_congr" +let coq_eq_true_eq = lazy_init_reference ["Datatypes"] "eq_true" +let coq_eq_true_ind = lazy_init_reference ["Datatypes"] "eq_true_ind" +let coq_eq_true_congr = lazy_init_reference ["Logic"] "eq_true_congr" let build_coq_inversion_eq_true_data () = let _ = check_required_library datatypes_module_name in @@ -331,6 +349,7 @@ let build_coq_inversion_eq_true_data () = (* The False proposition *) let coq_False = lazy_init_constant ["Logic"] "False" +let coq_proof_admitted = lazy_init_constant ["Logic"] "proof_admitted" (* The True proposition and its unique proof *) let coq_True = lazy_init_constant ["Logic"] "True" @@ -352,6 +371,7 @@ let build_coq_True () = Lazy.force coq_True let build_coq_I () = Lazy.force coq_I let build_coq_False () = Lazy.force coq_False +let build_coq_proof_admitted () = Lazy.force coq_proof_admitted let build_coq_not () = Lazy.force coq_not let build_coq_and () = Lazy.force coq_and let build_coq_conj () = Lazy.force coq_conj @@ -368,7 +388,7 @@ let coq_eq_ref = lazy (init_reference ["Logic"] "eq") let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity") let coq_jmeq_ref = lazy (gen_reference "Coqlib" ["Logic";"JMeq"] "JMeq") let coq_eq_true_ref = lazy (gen_reference "Coqlib" ["Init";"Datatypes"] "eq_true") -let coq_existS_ref = lazy (anomaly "use coq_existT_ref") +let coq_existS_ref = lazy (anomaly (Pp.str "use coq_existT_ref")) let coq_existT_ref = lazy (init_reference ["Specif"] "existT") let coq_exist_ref = lazy (init_reference ["Specif"] "exist") let coq_not_ref = lazy (init_reference ["Logic"] "not") diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 0efebc29..986a4385 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string list -> string -> global_reference (** Search in several modules (not prefixed by "Coq") *) val gen_constant_in_modules : string->string list list-> string -> constr +val gen_reference_in_modules : string->string list list-> string -> global_reference val arith_modules : string list list val zarith_base_modules : string list list val init_modules : string list list @@ -53,12 +53,18 @@ val check_required_library : string list -> unit (** {6 Global references } *) (** Modules *) -val logic_module : dir_path -val logic_type_module : dir_path +val prelude_module : DirPath.t -val datatypes_module_name : string list +val logic_module : DirPath.t val logic_module_name : string list +val logic_type_module : DirPath.t + +val jmeq_module : DirPath.t +val jmeq_module_name : string list + +val datatypes_module_name : string list + (** Natural numbers *) val nat_path : full_path val glob_nat : global_reference @@ -96,43 +102,49 @@ val build_bool_type : coq_bool_data delayed (** {6 For Equality tactics } *) type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } + proj1 : global_reference; + proj2 : global_reference; + elim : global_reference; + intro : global_reference; + typ : global_reference } val build_sigma_set : coq_sigma_data delayed val build_sigma_type : coq_sigma_data delayed val build_sigma : coq_sigma_data delayed +(* val build_sigma_type_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_sigma_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_prod_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_coq_eq_data_in : Environ.env -> coq_eq_data Univ.in_universe_context_set *) + (** Non-dependent pairs in Set from Datatypes *) val build_prod : coq_sigma_data delayed type coq_eq_data = { - eq : constr; - ind : constr; - refl : constr; - sym : constr; - trans: constr; - congr: constr } + eq : global_reference; + ind : global_reference; + refl : global_reference; + sym : global_reference; + trans: global_reference; + congr: global_reference } val build_coq_eq_data : coq_eq_data delayed + val build_coq_identity_data : coq_eq_data delayed val build_coq_jmeq_data : coq_eq_data delayed -val build_coq_eq : constr delayed (** = [(build_coq_eq_data()).eq] *) -val build_coq_eq_refl : constr delayed (** = [(build_coq_eq_data()).refl] *) -val build_coq_eq_sym : constr delayed (** = [(build_coq_eq_data()).sym] *) -val build_coq_f_equal2 : constr delayed +val build_coq_eq : global_reference delayed (** = [(build_coq_eq_data()).eq] *) +val build_coq_eq_refl : global_reference delayed (** = [(build_coq_eq_data()).refl] *) +val build_coq_eq_sym : global_reference delayed (** = [(build_coq_eq_data()).sym] *) +val build_coq_f_equal2 : global_reference delayed (** Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : constr; (** : forall params, args -> Prop *) - inv_ind : constr; (** : forall params P (H : P params) args, eq params args + inv_eq : global_reference; (** : forall params, args -> Prop *) + inv_ind : global_reference; (** : forall params P (H : P params) args, eq params args -> P args *) - inv_congr: constr (** : forall params B (f:t->B) args, eq params args -> + inv_congr: global_reference (** : forall params B (f:t->B) args, eq params args -> f params = f args *) } @@ -148,6 +160,7 @@ val build_coq_sumbool : constr delayed (** Connectives The False proposition *) val build_coq_False : constr delayed +val build_coq_proof_admitted : constr delayed (** The True proposition and its unique proof *) val build_coq_True : constr delayed diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index dbccf8ae..c18ceeca 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -1,11 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* open_glob_file f; output_string !glob_file "DIGEST NO\n" - | NoGlob | StdOut -> + | NoGlob | Feedback | StdOut -> () let end_dump_glob () = match !glob_output with | MultFiles | File _ -> close_glob_file () - | NoGlob | StdOut -> () + | NoGlob | Feedback | StdOut -> () let previous_state = ref MultFiles let pause () = previous_state := !glob_output; glob_output := NoGlob let continue () = glob_output := !previous_state -type coqdoc_state = Lexer.location_table - -let coqdoc_freeze = Lexer.location_table -let coqdoc_unfreeze = Lexer.restore_location_table - open Decl_kinds let type_of_logical_kind = function @@ -102,18 +104,27 @@ let type_of_global_ref gr = "class" else match gr with - | Libnames.ConstRef cst -> + | Globnames.ConstRef cst -> type_of_logical_kind (Decls.constant_kind cst) - | Libnames.VarRef v -> + | Globnames.VarRef v -> "var" ^ type_of_logical_kind (Decls.variable_kind v) - | Libnames.IndRef ind -> + | Globnames.IndRef ind -> let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in - if mib.Declarations.mind_record then - if mib.Declarations.mind_finite then "rec" - else "corec" - else if mib.Declarations.mind_finite then "ind" - else "coind" - | Libnames.ConstructRef _ -> "constr" + if mib.Declarations.mind_record <> None then + let open Decl_kinds in + begin match mib.Declarations.mind_finite with + | Finite -> "indrec" + | BiFinite -> "rec" + | CoFinite -> "corec" + end + else + let open Decl_kinds in + begin match mib.Declarations.mind_finite with + | Finite -> "ind" + | BiFinite -> "variant" + | CoFinite -> "coind" + end + | Globnames.ConstructRef _ -> "constr" let remove_sections dir = if Libnames.is_dirpath_prefix_of dir (Lib.cwd ()) then @@ -124,79 +135,30 @@ let remove_sections dir = dir let interval loc = - let loc1,loc2 = Util.unloc loc in + let loc1,loc2 = Loc.unloc loc in loc1, loc2-1 let dump_ref loc filepath modpath ident ty = - let bl,el = interval loc in - dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" + if !glob_output = Feedback then + Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) + else + let bl,el = interval loc in + dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) -let add_glob_gen loc sp lib_dp ty = - if dump () then - let mod_dp,id = Libnames.repr_path sp in - let mod_dp = remove_sections mod_dp in - let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in - let filepath = Names.string_of_dirpath lib_dp in - let modpath = Names.string_of_dirpath mod_dp_trunc in - let ident = Names.string_of_id id in - dump_ref loc filepath modpath ident ty - -let add_glob loc ref = - if dump () && loc <> Util.dummy_loc then - let sp = Nametab.path_of_global ref in - let lib_dp = Lib.library_part ref in - let ty = type_of_global_ref ref in - add_glob_gen loc sp lib_dp ty - -let mp_of_kn kn = - let mp,sec,l = Names.repr_kn kn in - Names.MPdot (mp,l) - -let add_glob_kn loc kn = - if dump () && loc <> Util.dummy_loc then - let sp = Nametab.path_of_syndef kn in - let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in - add_glob_gen loc sp lib_dp "syndef" - -let dump_binding loc id = () - -let dump_definition (loc, id) sec s = - let bl,el = interval loc in - dump_string (Printf.sprintf "%s %d:%d %s %s\n" s bl el - (Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id)) - let dump_reference loc modpath ident ty = - let bl,el = interval loc in - dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" - bl el (Names.string_of_dirpath (Lib.library_dp ())) modpath ident ty) - -let dump_constraint ((loc, n), _, _) sec ty = - match n with - | Names.Name id -> dump_definition (loc, id) sec ty - | Names.Anonymous -> () + let filepath = Names.DirPath.to_string (Lib.library_dp ()) in + dump_ref loc filepath modpath ident ty let dump_modref loc mp ty = - if dump () then - let (dp, l) = Lib.split_modpath mp in - let l = if l = [] then l else Util.list_drop_last l in - let fp = Names.string_of_dirpath dp in - let mp = Names.string_of_dirpath (Names.make_dirpath l) in - let bl,el = interval loc in - dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" - bl el fp mp "<>" ty) - -let dump_moddef loc mp ty = - if dump () then - let bl,el = interval loc in - let (dp, l) = Lib.split_modpath mp in - let mp = Names.string_of_dirpath (Names.make_dirpath l) in - dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el "<>" mp) + let (dp, l) = Lib.split_modpath mp in + let filepath = Names.DirPath.to_string dp in + let modpath = Names.DirPath.to_string (Names.DirPath.make l) in + let ident = "<>" in + dump_ref loc filepath modpath ident ty let dump_libref loc dp ty = - let bl,el = interval loc in - dump_string (Printf.sprintf "R%d:%d %s <> <> %s\n" - bl el (Names.string_of_dirpath dp) ty) + dump_ref loc (Names.DirPath.to_string dp) "<>" "<>" ty let cook_notation df sc = (* We encode notations so that they are space-free and still human-readable *) @@ -212,19 +174,19 @@ let cook_notation df sc = let l = String.length df - 1 in let i = ref 0 in while !i <= l do - assert (df.[!i] <> ' '); - if df.[!i] = '_' && (!i = l || df.[!i+1] = ' ') then + assert (df.[!i] != ' '); + if df.[!i] == '_' && (Int.equal !i l || df.[!i+1] == ' ') then (* Next token is a non-terminal *) (ntn.[!j] <- 'x'; incr j; incr i) else begin (* Next token is a terminal *) ntn.[!j] <- '\''; incr j; - while !i <= l && df.[!i] <> ' ' do + while !i <= l && df.[!i] != ' ' do if df.[!i] < ' ' then let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i) else begin - if df.[!i] = '\'' then (ntn.[!j] <- '\''; incr j); + if df.[!i] == '\'' then (ntn.[!j] <- '\''; incr j); ntn.[!j] <- df.[!i]; incr j; incr i end done; @@ -235,16 +197,67 @@ let cook_notation df sc = let df = String.sub ntn 0 !j in match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df -let dump_notation (loc,(df,_)) sc sec = - (* We dump the location of the opening '"' *) - dump_string (Printf.sprintf "not %d %s %s\n" (fst (Util.unloc loc)) - (Names.string_of_dirpath (Lib.current_dirpath sec)) (cook_notation df sc)) - let dump_notation_location posl df (((path,secpath),_),sc) = if dump () then - let path = Names.string_of_dirpath path in - let secpath = Names.string_of_dirpath secpath in + let path = Names.DirPath.to_string path in + let secpath = Names.DirPath.to_string secpath in let df = cook_notation df sc in - List.iter (fun (bl,el) -> - dump_string(Printf.sprintf "R%d:%d %s %s %s not\n" bl el path secpath df)) + List.iter (fun l -> + dump_ref (Loc.make_loc l) path secpath df "not") posl + +let add_glob_gen loc sp lib_dp ty = + if dump () then + let mod_dp,id = Libnames.repr_path sp in + let mod_dp = remove_sections mod_dp in + let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in + let filepath = Names.DirPath.to_string lib_dp in + let modpath = Names.DirPath.to_string mod_dp_trunc in + let ident = Names.Id.to_string id in + dump_ref loc filepath modpath ident ty + +let add_glob loc ref = + if dump () && not (Loc.is_ghost loc) then + let sp = Nametab.path_of_global ref in + let lib_dp = Lib.library_part ref in + let ty = type_of_global_ref ref in + add_glob_gen loc sp lib_dp ty + +let mp_of_kn kn = + let mp,sec,l = Names.repr_kn kn in + Names.MPdot (mp,l) + +let add_glob_kn loc kn = + if dump () && not (Loc.is_ghost loc) then + let sp = Nametab.path_of_syndef kn in + let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in + add_glob_gen loc sp lib_dp "syndef" + +let dump_binding loc id = () + +let dump_def ty loc secpath id = + if !glob_output = Feedback then + Pp.feedback (Feedback.GlobDef (loc, id, secpath, ty)) + else + let bl,el = interval loc in + dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el secpath id) + +let dump_definition (loc, id) sec s = + dump_def s loc (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) + +let dump_constraint ((loc, n), _, _) sec ty = + match n with + | Names.Name id -> dump_definition (loc, id) sec ty + | Names.Anonymous -> () + +let dump_moddef loc mp ty = + let (dp, l) = Lib.split_modpath mp in + let mp = Names.DirPath.to_string (Names.DirPath.make l) in + dump_def ty loc "<>" mp + +let dump_notation (loc,(df,_)) sc sec = + (* We dump the location of the opening '"' *) + let i = fst (Loc.unloc loc) in + let location = (Loc.make_loc (i, i+1)) in + dump_def "not" location (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc) + diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index df192e9b..428189be 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val dump : unit -> bool val noglob : unit -> unit -val dump_to_stdout : unit -> unit -val dump_into_file : string -> unit +val dump_into_file : string -> unit (** special handling of "stdout" *) val dump_to_dotglob : unit -> unit +val feedback_glob : unit -> unit val pause : unit -> unit val continue : unit -> unit -type coqdoc_state = Lexer.location_table -val coqdoc_freeze : unit -> coqdoc_state -val coqdoc_unfreeze : coqdoc_state -> unit - -val add_glob : Util.loc -> Libnames.global_reference -> unit -val add_glob_kn : Util.loc -> Names.kernel_name -> unit - -val dump_definition : Util.loc * Names.identifier -> bool -> string -> unit -val dump_moddef : Util.loc -> Names.module_path -> string -> unit -val dump_modref : Util.loc -> Names.module_path -> string -> unit -val dump_reference : Util.loc -> string -> string -> string -> unit -val dump_libref : Util.loc -> Names.dir_path -> string -> unit -val dump_notation_location : (int * int) list -> Topconstr.notation -> (Notation.notation_location * Topconstr.scope_name option) -> unit -val dump_binding : Util.loc -> Names.Idset.elt -> unit -val dump_notation : Util.loc * (Topconstr.notation * Notation.notation_location) -> Topconstr.scope_name option -> bool -> unit -val dump_constraint : Topconstr.typeclass_constraint -> bool -> string -> unit +val add_glob : Loc.t -> Globnames.global_reference -> unit +val add_glob_kn : Loc.t -> Names.kernel_name -> unit + +val dump_definition : Loc.t * Names.Id.t -> bool -> string -> unit +val dump_moddef : Loc.t -> Names.module_path -> string -> unit +val dump_modref : Loc.t -> Names.module_path -> string -> unit +val dump_reference : Loc.t -> string -> string -> string -> unit +val dump_libref : Loc.t -> Names.DirPath.t -> string -> unit +val dump_notation_location : (int * int) list -> Constrexpr.notation -> + (Notation.notation_location * Notation_term.scope_name option) -> unit +val dump_binding : Loc.t -> Names.Id.Set.elt -> unit +val dump_notation : + Loc.t * (Constrexpr.notation * Notation.notation_location) -> + Notation_term.scope_name option -> bool -> unit +val dump_constraint : + Constrexpr.typeclass_constraint -> bool -> string -> unit val dump_string : string -> unit +val type_of_global_ref : Globnames.global_reference -> string diff --git a/interp/genarg.ml b/interp/genarg.ml deleted file mode 100644 index 41cbcdaf..00000000 --- a/interp/genarg.ml +++ /dev/null @@ -1,281 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* f c - | ByNotation (loc,s,_) -> loc - -type glob_constr_and_expr = glob_constr * constr_expr option -type open_constr_expr = unit * constr_expr -type open_glob_constr = unit * glob_constr_and_expr - -type glob_constr_pattern_and_expr = glob_constr_and_expr * Pattern.constr_pattern - -type 'a with_ebindings = 'a * open_constr bindings - -(* Dynamics but tagged by a type expression *) - -type 'a generic_argument = argument_type * Obj.t - -type rlevel -type glevel -type tlevel - -type intro_pattern_expr = - | IntroOrAndPattern of or_and_intro_pattern_expr - | IntroWildcard - | IntroRewrite of bool - | IntroIdentifier of identifier - | IntroFresh of identifier - | IntroForthcoming of bool - | IntroAnonymous -and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list - -let rec pr_intro_pattern (_,pat) = match pat with - | IntroOrAndPattern pll -> pr_or_and_intro_pattern pll - | IntroWildcard -> str "_" - | IntroRewrite true -> str "->" - | IntroRewrite false -> str "<-" - | IntroIdentifier id -> pr_id id - | IntroFresh id -> str "?" ++ pr_id id - | IntroForthcoming true -> str "*" - | IntroForthcoming false -> str "**" - | IntroAnonymous -> str "?" - -and pr_or_and_intro_pattern = function - | [pl] -> - str "(" ++ hv 0 (prlist_with_sep pr_comma pr_intro_pattern pl) ++ str ")" - | pll -> - str "[" ++ - hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc pr_intro_pattern) pll) - ++ str "]" - -let rawwit_bool = BoolArgType -let globwit_bool = BoolArgType -let wit_bool = BoolArgType - -let rawwit_int = IntArgType -let globwit_int = IntArgType -let wit_int = IntArgType - -let rawwit_int_or_var = IntOrVarArgType -let globwit_int_or_var = IntOrVarArgType -let wit_int_or_var = IntOrVarArgType - -let rawwit_string = StringArgType -let globwit_string = StringArgType -let wit_string = StringArgType - -let rawwit_pre_ident = PreIdentArgType -let globwit_pre_ident = PreIdentArgType -let wit_pre_ident = PreIdentArgType - -let rawwit_intro_pattern = IntroPatternArgType -let globwit_intro_pattern = IntroPatternArgType -let wit_intro_pattern = IntroPatternArgType - -let rawwit_ident_gen b = IdentArgType b -let globwit_ident_gen b = IdentArgType b -let wit_ident_gen b = IdentArgType b - -let rawwit_ident = rawwit_ident_gen true -let globwit_ident = globwit_ident_gen true -let wit_ident = wit_ident_gen true - -let rawwit_pattern_ident = rawwit_ident_gen false -let globwit_pattern_ident = globwit_ident_gen false -let wit_pattern_ident = wit_ident_gen false - -let rawwit_var = VarArgType -let globwit_var = VarArgType -let wit_var = VarArgType - -let rawwit_ref = RefArgType -let globwit_ref = RefArgType -let wit_ref = RefArgType - -let rawwit_quant_hyp = QuantHypArgType -let globwit_quant_hyp = QuantHypArgType -let wit_quant_hyp = QuantHypArgType - -let rawwit_sort = SortArgType -let globwit_sort = SortArgType -let wit_sort = SortArgType - -let rawwit_constr = ConstrArgType -let globwit_constr = ConstrArgType -let wit_constr = ConstrArgType - -let rawwit_constr_may_eval = ConstrMayEvalArgType -let globwit_constr_may_eval = ConstrMayEvalArgType -let wit_constr_may_eval = ConstrMayEvalArgType - -let rawwit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2) -let globwit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2) -let wit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2) - -let rawwit_open_constr = rawwit_open_constr_gen (false,false) -let globwit_open_constr = globwit_open_constr_gen (false,false) -let wit_open_constr = wit_open_constr_gen (false,false) - -let rawwit_casted_open_constr = rawwit_open_constr_gen (true,false) -let globwit_casted_open_constr = globwit_open_constr_gen (true,false) -let wit_casted_open_constr = wit_open_constr_gen (true,false) - -let rawwit_open_constr_wTC = rawwit_open_constr_gen (false,true) -let globwit_open_constr_wTC = globwit_open_constr_gen (false,true) -let wit_open_constr_wTC = wit_open_constr_gen (false,true) - -let rawwit_constr_with_bindings = ConstrWithBindingsArgType -let globwit_constr_with_bindings = ConstrWithBindingsArgType -let wit_constr_with_bindings = ConstrWithBindingsArgType - -let rawwit_bindings = BindingsArgType -let globwit_bindings = BindingsArgType -let wit_bindings = BindingsArgType - -let rawwit_red_expr = RedExprArgType -let globwit_red_expr = RedExprArgType -let wit_red_expr = RedExprArgType - -let wit_list0 t = List0ArgType t - -let wit_list1 t = List1ArgType t - -let wit_opt t = OptArgType t - -let wit_pair t1 t2 = PairArgType (t1,t2) - -let in_gen t o = (t,Obj.repr o) -let out_gen t (t',o) = if t = t' then Obj.magic o else failwith "out_gen" -let genarg_tag (s,_) = s - -let fold_list0 f = function - | (List0ArgType t, l) -> - List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) - | _ -> failwith "Genarg: not a list0" - -let fold_list1 f = function - | (List1ArgType t, l) -> - List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) - | _ -> failwith "Genarg: not a list1" - -let fold_opt f a = function - | (OptArgType t, l) -> - (match Obj.magic l with - | None -> a - | Some x -> f (in_gen t x)) - | _ -> failwith "Genarg: not a opt" - -let fold_pair f = function - | (PairArgType (t1,t2), l) -> - let (x1,x2) = Obj.magic l in - f (in_gen t1 x1) (in_gen t2 x2) - | _ -> failwith "Genarg: not a pair" - -let app_list0 f = function - | (List0ArgType t as u, l) -> - let o = Obj.magic l in - (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) - | _ -> failwith "Genarg: not a list0" - -let app_list1 f = function - | (List1ArgType t as u, l) -> - let o = Obj.magic l in - (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) - | _ -> failwith "Genarg: not a list1" - -let app_opt f = function - | (OptArgType t as u, l) -> - let o = Obj.magic l in - (u, Obj.repr (Option.map (fun x -> out_gen t (f (in_gen t x))) o)) - | _ -> failwith "Genarg: not an opt" - -let app_pair f1 f2 = function - | (PairArgType (t1,t2) as u, l) -> - let (o1,o2) = Obj.magic l in - let o1 = out_gen t1 (f1 (in_gen t1 o1)) in - let o2 = out_gen t2 (f2 (in_gen t2 o2)) in - (u, Obj.repr (o1,o2)) - | _ -> failwith "Genarg: not a pair" - -let unquote x = x - -type an_arg_of_this_type = Obj.t - -let in_generic t x = (t, Obj.repr x) - -let dyntab = ref ([] : (string * glevel generic_argument option) list) - -type ('a,'b) abstract_argument_type = argument_type - -let create_arg v s = - if List.mem_assoc s !dyntab then - anomaly ("Genarg.create: already declared generic argument " ^ s); - let t = ExtraArgType s in - dyntab := (s,Option.map (in_gen t) v) :: !dyntab; - (t,t,t) - -let exists_argtype s = List.mem_assoc s !dyntab - -let default_empty_argtype_value s = List.assoc s !dyntab - -let default_empty_value t = - let rec aux = function - | List0ArgType _ -> Some (in_gen t []) - | OptArgType _ -> Some (in_gen t None) - | PairArgType(t1,t2) -> - (match aux t1, aux t2 with - | Some (_,v1), Some (_,v2) -> Some (in_gen t (v1,v2)) - | _ -> None) - | ExtraArgType s -> default_empty_argtype_value s - | _ -> None in - match aux t with - | Some v -> Some (out_gen t v) - | None -> None diff --git a/interp/genarg.mli b/interp/genarg.mli deleted file mode 100644 index f1425c55..00000000 --- a/interp/genarg.mli +++ /dev/null @@ -1,320 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* loc) -> 'a or_by_notation -> loc - -(** In globalize tactics, we need to keep the initial [constr_expr] to recompute - in the environment by the effective calls to Intro, Inversion, etc - The [constr_expr] field is [None] in TacDef though *) -type glob_constr_and_expr = glob_constr * constr_expr option - -type open_constr_expr = unit * constr_expr -type open_glob_constr = unit * glob_constr_and_expr - -type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern - -type 'a with_ebindings = 'a * open_constr bindings - -type intro_pattern_expr = - | IntroOrAndPattern of or_and_intro_pattern_expr - | IntroWildcard - | IntroRewrite of bool - | IntroIdentifier of identifier - | IntroFresh of identifier - | IntroForthcoming of bool - | IntroAnonymous -and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list - -val pr_intro_pattern : intro_pattern_expr located -> Pp.std_ppcmds -val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds - -(** The route of a generic argument, from parsing to evaluation. -In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. - -{% \begin{%}verbatim{% }%} - parsing in_raw out_raw - char stream ---> raw_object ---> raw_object generic_argument -------+ - encapsulation decaps| - | - V - raw_object - | - globalization | - V - glob_object - | - encaps | - in_glob | - V - glob_object generic_argument - | - out in out_glob | - object <--- object generic_argument <--- object <--- glob_object <---+ - | decaps encaps interp decaps - | - V -effective use -{% \end{%}verbatim{% }%} - -To distinguish between the uninterpreted (raw), globalized and -interpreted worlds, we annotate the type [generic_argument] by a -phantom argument which is either [constr_expr], [glob_constr] or -[constr]. - -Transformation for each type : -{% \begin{%}verbatim{% }%} -tag raw open type cooked closed type - -BoolArgType bool bool -IntArgType int int -IntOrVarArgType int or_var int -StringArgType string (parsed w/ "") string -PreIdentArgType string (parsed w/o "") (vernac only) -IdentArgType true identifier identifier -IdentArgType false identifier (pattern_ident) identifier -IntroPatternArgType intro_pattern_expr intro_pattern_expr -VarArgType identifier located identifier -RefArgType reference global_reference -QuantHypArgType quantified_hypothesis quantified_hypothesis -ConstrArgType constr_expr constr -ConstrMayEvalArgType constr_expr may_eval constr -OpenConstrArgType open_constr_expr open_constr -ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings -BindingsArgType constr_expr bindings constr bindings -List0ArgType of argument_type -List1ArgType of argument_type -OptArgType of argument_type -ExtraArgType of string '_a '_b -{% \end{%}verbatim{% }%} -*) - -(** All of [rlevel], [glevel] and [tlevel] must be non convertible - to ensure the injectivity of the type inference from type - ['co generic_argument] to [('a,'co) abstract_argument_type]; - this guarantees that, for 'co fixed, the type of - out_gen is monomorphic over 'a, hence type-safe -*) - -type rlevel -type glevel -type tlevel - -type ('a,'co) abstract_argument_type - -val rawwit_bool : (bool,rlevel) abstract_argument_type -val globwit_bool : (bool,glevel) abstract_argument_type -val wit_bool : (bool,tlevel) abstract_argument_type - -val rawwit_int : (int,rlevel) abstract_argument_type -val globwit_int : (int,glevel) abstract_argument_type -val wit_int : (int,tlevel) abstract_argument_type - -val rawwit_int_or_var : (int or_var,rlevel) abstract_argument_type -val globwit_int_or_var : (int or_var,glevel) abstract_argument_type -val wit_int_or_var : (int or_var,tlevel) abstract_argument_type - -val rawwit_string : (string,rlevel) abstract_argument_type -val globwit_string : (string,glevel) abstract_argument_type - -val wit_string : (string,tlevel) abstract_argument_type - -val rawwit_pre_ident : (string,rlevel) abstract_argument_type -val globwit_pre_ident : (string,glevel) abstract_argument_type -val wit_pre_ident : (string,tlevel) abstract_argument_type - -val rawwit_intro_pattern : (intro_pattern_expr located,rlevel) abstract_argument_type -val globwit_intro_pattern : (intro_pattern_expr located,glevel) abstract_argument_type -val wit_intro_pattern : (intro_pattern_expr located,tlevel) abstract_argument_type - -val rawwit_ident : (identifier,rlevel) abstract_argument_type -val globwit_ident : (identifier,glevel) abstract_argument_type -val wit_ident : (identifier,tlevel) abstract_argument_type - -val rawwit_pattern_ident : (identifier,rlevel) abstract_argument_type -val globwit_pattern_ident : (identifier,glevel) abstract_argument_type -val wit_pattern_ident : (identifier,tlevel) abstract_argument_type - -val rawwit_ident_gen : bool -> (identifier,rlevel) abstract_argument_type -val globwit_ident_gen : bool -> (identifier,glevel) abstract_argument_type -val wit_ident_gen : bool -> (identifier,tlevel) abstract_argument_type - -val rawwit_var : (identifier located,rlevel) abstract_argument_type -val globwit_var : (identifier located,glevel) abstract_argument_type -val wit_var : (identifier,tlevel) abstract_argument_type - -val rawwit_ref : (reference,rlevel) abstract_argument_type -val globwit_ref : (global_reference located or_var,glevel) abstract_argument_type -val wit_ref : (global_reference,tlevel) abstract_argument_type - -val rawwit_quant_hyp : (quantified_hypothesis,rlevel) abstract_argument_type -val globwit_quant_hyp : (quantified_hypothesis,glevel) abstract_argument_type -val wit_quant_hyp : (quantified_hypothesis,tlevel) abstract_argument_type - -val rawwit_sort : (glob_sort,rlevel) abstract_argument_type -val globwit_sort : (glob_sort,glevel) abstract_argument_type -val wit_sort : (sorts,tlevel) abstract_argument_type - -val rawwit_constr : (constr_expr,rlevel) abstract_argument_type -val globwit_constr : (glob_constr_and_expr,glevel) abstract_argument_type -val wit_constr : (constr,tlevel) abstract_argument_type - -val rawwit_constr_may_eval : ((constr_expr,reference or_by_notation,constr_expr) may_eval,rlevel) abstract_argument_type -val globwit_constr_may_eval : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) may_eval,glevel) abstract_argument_type -val wit_constr_may_eval : (constr,tlevel) abstract_argument_type - -val rawwit_open_constr_gen : bool * bool -> (open_constr_expr,rlevel) abstract_argument_type -val globwit_open_constr_gen : bool * bool -> (open_glob_constr,glevel) abstract_argument_type -val wit_open_constr_gen : bool * bool -> (open_constr,tlevel) abstract_argument_type - -val rawwit_open_constr : (open_constr_expr,rlevel) abstract_argument_type -val globwit_open_constr : (open_glob_constr,glevel) abstract_argument_type -val wit_open_constr : (open_constr,tlevel) abstract_argument_type - -val rawwit_casted_open_constr : (open_constr_expr,rlevel) abstract_argument_type -val globwit_casted_open_constr : (open_glob_constr,glevel) abstract_argument_type -val wit_casted_open_constr : (open_constr,tlevel) abstract_argument_type - -val rawwit_open_constr_wTC : (open_constr_expr,rlevel) abstract_argument_type -val globwit_open_constr_wTC : (open_glob_constr,glevel) abstract_argument_type -val wit_open_constr_wTC : (open_constr,tlevel) abstract_argument_type - -val rawwit_constr_with_bindings : (constr_expr with_bindings,rlevel) abstract_argument_type -val globwit_constr_with_bindings : (glob_constr_and_expr with_bindings,glevel) abstract_argument_type -val wit_constr_with_bindings : (constr with_bindings sigma,tlevel) abstract_argument_type - -val rawwit_bindings : (constr_expr bindings,rlevel) abstract_argument_type -val globwit_bindings : (glob_constr_and_expr bindings,glevel) abstract_argument_type -val wit_bindings : (constr bindings sigma,tlevel) abstract_argument_type - -val rawwit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen,rlevel) abstract_argument_type -val globwit_red_expr : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen,glevel) abstract_argument_type -val wit_red_expr : ((constr,evaluable_global_reference,constr_pattern) red_expr_gen,tlevel) abstract_argument_type - -val wit_list0 : - ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type - -val wit_list1 : - ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type - -val wit_opt : - ('a,'co) abstract_argument_type -> ('a option,'co) abstract_argument_type - -val wit_pair : - ('a,'co) abstract_argument_type -> - ('b,'co) abstract_argument_type -> - ('a * 'b,'co) abstract_argument_type - -(** ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *) -type 'a generic_argument - -val fold_list0 : - ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c - -val fold_list1 : - ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c - -val fold_opt : - ('a generic_argument -> 'c) -> 'c -> 'a generic_argument -> 'c - -val fold_pair : - ('a generic_argument -> 'a generic_argument -> 'c) -> - 'a generic_argument -> 'c - -(** [app_list0] fails if applied to an argument not of tag [List0 t] - for some [t]; it's the responsability of the caller to ensure it *) - -val app_list0 : ('a generic_argument -> 'b generic_argument) -> -'a generic_argument -> 'b generic_argument - -val app_list1 : ('a generic_argument -> 'b generic_argument) -> -'a generic_argument -> 'b generic_argument - -val app_opt : ('a generic_argument -> 'b generic_argument) -> -'a generic_argument -> 'b generic_argument - -val app_pair : - ('a generic_argument -> 'b generic_argument) -> - ('a generic_argument -> 'b generic_argument) - -> 'a generic_argument -> 'b generic_argument - -(** create a new generic type of argument: force to associate - unique ML types at each of the three levels *) -val create_arg : 'rawa option -> - string -> - ('a,tlevel) abstract_argument_type - * ('globa,glevel) abstract_argument_type - * ('rawa,rlevel) abstract_argument_type - -val exists_argtype : string -> bool - -type argument_type = - (** Basic types *) - | BoolArgType - | IntArgType - | IntOrVarArgType - | StringArgType - | PreIdentArgType - | IntroPatternArgType - | IdentArgType of bool - | VarArgType - | RefArgType - (** Specific types *) - | SortArgType - | ConstrArgType - | ConstrMayEvalArgType - | QuantHypArgType - | OpenConstrArgType of bool * bool - | ConstrWithBindingsArgType - | BindingsArgType - | RedExprArgType - | List0ArgType of argument_type - | List1ArgType of argument_type - | OptArgType of argument_type - | PairArgType of argument_type * argument_type - | ExtraArgType of string - -val genarg_tag : 'a generic_argument -> argument_type - -val unquote : ('a,'co) abstract_argument_type -> argument_type - -val in_gen : - ('a,'co) abstract_argument_type -> 'a -> 'co generic_argument -val out_gen : - ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a - -(** [in_generic] is used in combination with camlp4 [Gramext.action] magic - - [in_generic: !l:type, !a:argument_type -> |a|_l -> 'l generic_argument] - - where |a|_l is the interpretation of a at level l - - [in_generic] is not typable; we replace the second argument by an absurd - type (with no introduction rule) -*) -type an_arg_of_this_type - -val in_generic : - argument_type -> an_arg_of_this_type -> 'co generic_argument - -val default_empty_value : ('a,rlevel) abstract_argument_type -> 'a option diff --git a/interp/genintern.ml b/interp/genintern.ml new file mode 100644 index 00000000..c78b13a8 --- /dev/null +++ b/interp/genintern.ml @@ -0,0 +1,57 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'raw -> glob_sign * 'glb +type 'glb subst_fun = substitution -> 'glb -> 'glb + +module InternObj = +struct + type ('raw, 'glb, 'top) obj = ('raw, 'glb) intern_fun + let name = "intern" + let default _ = None +end + +module SubstObj = +struct + type ('raw, 'glb, 'top) obj = 'glb subst_fun + let name = "subst" + let default _ = None +end + +module Intern = Register (InternObj) +module Subst = Register (SubstObj) + +let intern = Intern.obj +let register_intern0 = Intern.register0 + +let generic_intern ist v = + let unpacker wit v = + let (ist, v) = intern wit ist (raw v) in + (ist, in_gen (glbwit wit) v) + in + unpack { unpacker; } v + +(** Substitution functions *) + +let substitute = Subst.obj +let register_subst0 = Subst.register0 + +let generic_substitute subs v = + let unpacker wit v = in_gen (glbwit wit) (substitute wit subs (glb v)) in + unpack { unpacker; } v + +let () = Hook.set Detyping.subst_genarg_hook generic_substitute diff --git a/interp/genintern.mli b/interp/genintern.mli new file mode 100644 index 00000000..6e63f71c --- /dev/null +++ b/interp/genintern.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'raw -> glob_sign * 'glb +(** The type of functions used for internalizing generic arguments. *) + +val intern : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb) intern_fun + +val generic_intern : (raw_generic_argument, glob_generic_argument) intern_fun + +(** {5 Substitution functions} *) + +type 'glb subst_fun = substitution -> 'glb -> 'glb +(** The type of functions used for substituting generic arguments. *) + +val substitute : ('raw, 'glb, 'top) genarg_type -> 'glb subst_fun + +val generic_substitute : glob_generic_argument subst_fun + +(** Registering functions *) + +val register_intern0 : ('raw, 'glb, 'top) genarg_type -> + ('raw, 'glb) intern_fun -> unit + +val register_subst0 : ('raw, 'glb, 'top) genarg_type -> + 'glb subst_fun -> unit diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 1b0f1341..e304725d 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !generalizable_table); - Summary.unfreeze_function = (fun r -> generalizable_table := r); - Summary.init_function = (fun () -> generalizable_table := Idpred.empty) } +let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" let declare_generalizable_ident table (loc,id) = - if id <> root_of_id id then + if not (Id.equal id (root_of_id id)) then user_err_loc(loc,"declare_generalizable_ident", (pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); - if Idpred.mem id table then + if Id.Pred.mem id table then user_err_loc(loc,"declare_generalizable_ident", (pr_id id++str" is already declared as a generalizable identifier")) - else Idpred.add id table + else Id.Pred.add id table let add_generalizable gen table = match gen with - | None -> Idpred.empty - | Some [] -> Idpred.full + | None -> Id.Pred.empty + | Some [] -> Id.Pred.full | Some l -> List.fold_left (fun table lid -> declare_generalizable_ident table lid) table l @@ -57,7 +47,7 @@ let cache_generalizable_type (_,(local,cmd)) = let load_generalizable_type _ (_,(local,cmd)) = generalizable_table := add_generalizable cmd !generalizable_table -let in_generalizable : bool * identifier located list option -> obj = +let in_generalizable : bool * Id.t Loc.located list option -> obj = declare_object {(default_object "GENERALIZED-IDENT") with load_function = load_generalizable_type; cache_function = cache_generalizable_type; @@ -67,29 +57,22 @@ let in_generalizable : bool * identifier located list option -> obj = let declare_generalizable local gen = Lib.add_anonymous_leaf (in_generalizable (local, gen)) -let find_generalizable_ident id = Idpred.mem (root_of_id id) !generalizable_table +let find_generalizable_ident id = Id.Pred.mem (root_of_id id) !generalizable_table let ids_of_list l = - List.fold_right Idset.add l Idset.empty - -let locate_reference qid = - match Nametab.locate_extended qid with - | TrueGlobal ref -> true - | SynDef kn -> true + List.fold_right Id.Set.add l Id.Set.empty let is_global id = - try - locate_reference (qualid_of_ident id) - with Not_found -> - false + try ignore (Nametab.locate_extended (qualid_of_ident id)); true + with Not_found -> false + +let is_named id env = + try ignore (Environ.lookup_named id env); true + with Not_found -> false let is_freevar ids env x = - try - if Idset.mem x ids then false - else - try ignore(Environ.lookup_named x env) ; false - with e when Errors.noncritical e -> not (is_global x) - with e when Errors.noncritical e -> true + not (Id.Set.mem x ids || is_named x env || is_global x) + (* Auxiliary functions for the inference of implicitly quantified variables. *) @@ -97,9 +80,9 @@ let ungeneralizable loc id = user_err_loc (loc, "Generalization", str "Unbound and ungeneralizable variable " ++ pr_id id) -let free_vars_of_constr_expr c ?(bound=Idset.empty) l = +let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let found loc id bdvars l = - if List.mem id l then l + if Id.List.mem id l then l else if is_freevar bdvars (Global.env ()) id then if find_generalizable_ident id then id :: l @@ -107,26 +90,26 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l = else l in let rec aux bdvars l c = match c with - | CRef (Ident (loc,id)) -> found loc id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Idset.mem id bdvars) -> - fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c - | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c + | CRef (Ident (loc,id),_) -> found loc id bdvars l + | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id),_) :: _, [], [])) when not (Id.Set.mem id bdvars) -> + Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c + | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c let ids_of_names l = List.fold_left (fun acc x -> match snd x with Name na -> na :: acc | Anonymous -> acc) [] l -let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = +let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder list) = let rec aux bdvars l c = match c with ((LocalRawAssum (n, _, c)) :: tl) -> let bound = ids_of_names n in let l' = free_vars_of_constr_expr c ~bound:bdvars l in - aux (Idset.union (ids_of_list bound) bdvars) l' tl + aux (Id.Set.union (ids_of_list bound) bdvars) l' tl | ((LocalRawDef (n, c)) :: tl) -> let bound = match snd n with Anonymous -> [] | Name n -> [n] in let l' = free_vars_of_constr_expr c ~bound:bdvars l in - aux (Idset.union (ids_of_list bound) bdvars) l' tl + aux (Id.Set.union (ids_of_list bound) bdvars) l' tl | [] -> bdvars, l in aux bound l binders @@ -134,13 +117,13 @@ let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = let add_name_to_ids set na = match na with | Anonymous -> set - | Name id -> Idset.add id set + | Name id -> Id.Set.add id set -let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty) = +let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) = let rec vars bound vs = function | GVar (loc,id) -> if is_freevar bound (Global.env ()) id then - if List.mem_assoc id vs then vs + if Id.List.mem_assoc id vs then vs else (id, loc) :: vs else vs | GApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args) @@ -163,7 +146,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty let vs3 = vars bound vs2 b1 in vars bound vs3 b2 | GRec (loc,fk,idl,bl,tyl,bv) -> - let bound' = Array.fold_right Idset.add idl bound in + let bound' = Array.fold_right Id.Set.add idl bound in let vars_fix i vs fid = let vs1,bound1 = List.fold_left @@ -179,13 +162,13 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty let vs2 = vars bound1 vs1 tyl.(i) in vars bound1 vs2 bv.(i) in - array_fold_left_i vars_fix vs idl + Array.fold_left_i vars_fix vs idl | GCast (loc,c,k) -> let v = vars bound vs c in - (match k with CastConv (_,t) -> vars bound v t | _ -> v) + (match k with CastConv t | CastVM t -> vars bound v t | _ -> v) | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs and vars_pattern bound vs (loc,idl,p,c) = - let bound' = List.fold_right Idset.add idl bound in + let bound' = List.fold_right Id.Set.add idl bound in vars bound' vs c and vars_option bound vs = function None -> vs | Some p -> vars bound vs p @@ -196,7 +179,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty in fun rt -> let vars = List.rev (vars bound [] rt) in List.iter (fun (id, loc) -> - if not (Idset.mem id allowed || find_generalizable_ident id) then + if not (Id.Set.mem id allowed || find_generalizable_ident id) then ungeneralizable loc id) vars; vars @@ -205,7 +188,7 @@ let rec make_fresh ids env x = let next_name_away_from na avoid = match na with - | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon") + | Anonymous -> make_fresh avoid (Global.env ()) (Id.of_string "anon") | Name id -> make_fresh avoid (Global.env ()) id let combine_params avoid fn applied needed = @@ -213,7 +196,11 @@ let combine_params avoid fn applied needed = List.partition (function (t, Some (loc, ExplByName id)) -> - if not (List.exists (fun (_, (id', _, _)) -> Name id = id') needed) then + let is_id (_, (na, _, _)) = match na with + | Name id' -> Id.equal id id' + | Anonymous -> false + in + if not (List.exists is_id needed) then user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id); true | _ -> false) applied @@ -222,13 +209,17 @@ let combine_params avoid fn applied needed = (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false) named in - let needed = List.filter (fun (_, (_, b, _)) -> b = None) needed in + let is_unset (_, (_, b, _)) = match b with + | None -> true + | Some _ -> false + in + let needed = List.filter is_unset needed in let rec aux ids avoid app need = match app, need with [], [] -> List.rev ids, avoid - | app, (_, (Name id, _, _)) :: need when List.mem_assoc id named -> - aux (List.assoc id named :: ids) avoid app need + | app, (_, (Name id, _, _)) :: need when Id.List.mem_assoc id named -> + aux (Id.List.assoc id named :: ids) avoid app need | (x, None) :: app, (None, (Name id, _, _)) :: need -> aux (x :: ids) avoid app need @@ -244,25 +235,25 @@ let combine_params avoid fn applied needed = aux (t' :: ids) avoid' app need | (x,_) :: _, [] -> - user_err_loc (constr_loc x,"",str "Typeclass does not expect more arguments") + user_err_loc (Constrexpr_ops.constr_loc x,"",str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = fun avoid (_, (na, _, _)) -> let id' = next_name_away_from na avoid in - (CRef (Ident (dummy_loc, id')), Idset.add id' avoid) + (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = match cl with - | CApp (loc, (None, CRef ref), l) -> loc, ref, List.map fst l - | CAppExpl (loc, (None, ref), l) -> loc, ref, l - | CRef ref -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, List.map fst l + | CAppExpl (loc, (None, ref,_), l) -> loc, ref, l + | CRef (ref,_) -> loc_of_reference ref, ref, [] | _ -> raise Not_found let destClassAppExpl cl = match cl with - | CApp (loc, (None, CRef ref), l) -> loc, ref, l - | CRef ref -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, l + | CRef (ref,_) -> loc_of_reference ref, ref, [] | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = @@ -277,32 +268,37 @@ let implicit_application env ?(allow_partial=true) f ty = match is_class with | None -> ty, env | Some ((loc, id, par), gr) -> - let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in + let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = let c = class_info gr in let (ci, rd) = c.cl_context in if not allow_partial then begin - let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in - let needlen = List.fold_left (fun acc x -> if x = None then succ acc else acc) 0 ci in - if needlen <> applen then + let opt_succ x n = match x with + | None -> succ n + | Some _ -> n + in + let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in + let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in + if not (Int.equal needlen applen) then Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in - CAppExpl (loc, (None, id), args), avoid + CAppExpl (loc, (None, id, None), args), avoid in c, avoid let implicits_of_glob_constr ?(with_products=true) l = - let add_impl i na bk l = - if bk = Implicit then - let name = - match na with - | Name id -> Some id - | Anonymous -> None - in - (ExplByPos (i, name), (true, true, true)) :: l - else l in + let add_impl i na bk l = match bk with + | Implicit -> + let name = + match na with + | Name id -> Some id + | Anonymous -> None + in + (ExplByPos (i, name), (true, true, true)) :: l + | _ -> l + in let rec aux i c = let abs na bk b = add_impl i na bk (aux (succ i) b) @@ -310,15 +306,17 @@ let implicits_of_glob_constr ?(with_products=true) l = match c with | GProd (loc, na, bk, t, b) -> if with_products then abs na bk b - else - (if bk = Implicit then - msg_warning (str "Ignoring implicit status of product binder " ++ - pr_name na ++ str " and following binders"); - []) + else + let () = match bk with + | Implicit -> + msg_warning (strbrk "Ignoring implicit status of product binder " ++ + pr_name na ++ strbrk " and following binders") + | _ -> () + in [] | GLambda (loc, na, bk, t, b) -> abs na bk b | GLetIn (loc, na, t, b) -> aux i b | 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) + 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) | _ -> [] in aux 1 l diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index ab2ad566..818f7e9a 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -1,54 +1,47 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (identifier located) list option -> unit +val declare_generalizable : Vernacexpr.locality_flag -> (Id.t located) list option -> unit -val ids_of_list : identifier list -> Idset.t -val destClassApp : constr_expr -> loc * reference * constr_expr list -val destClassAppExpl : constr_expr -> loc * reference * (constr_expr * explicitation located option) list +val ids_of_list : Id.t list -> Id.Set.t +val destClassApp : constr_expr -> Loc.t * reference * constr_expr list +val destClassAppExpl : constr_expr -> Loc.t * reference * (constr_expr * explicitation located option) list (** Fragile, should be used only for construction a set of identifiers to avoid *) -val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t -> - identifier list -> identifier list +val free_vars_of_constr_expr : constr_expr -> ?bound:Id.Set.t -> + Id.t list -> Id.t list val free_vars_of_binders : - ?bound:Idset.t -> Names.identifier list -> local_binder list -> Idset.t * Names.identifier list + ?bound:Id.Set.t -> Id.t list -> local_binder list -> Id.Set.t * Id.t list (** Returns the generalizable free ids in left-to-right order with the location of their first occurence *) -val generalizable_vars_of_glob_constr : ?bound:Idset.t -> ?allowed:Idset.t -> - glob_constr -> (Names.identifier * loc) list +val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> + glob_constr -> (Id.t * Loc.t) list -val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier +val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : - Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> - Topconstr.constr_expr * Names.Idset.t + Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) -> + Constrexpr.constr_expr * Id.Set.t -val implicit_application : Idset.t -> ?allow_partial:bool -> - (Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> - Topconstr.constr_expr * Names.Idset.t) -> - constr_expr -> constr_expr * Idset.t +val implicit_application : Id.Set.t -> ?allow_partial:bool -> + (Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) -> + Constrexpr.constr_expr * Id.Set.t) -> + constr_expr -> constr_expr * Id.Set.t diff --git a/interp/interp.mllib b/interp/interp.mllib index 546f277e..c9a03152 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,10 +1,12 @@ -Tok -Lexer +Stdarg +Constrarg +Genintern +Constrexpr_ops +Notation_ops Topconstr Ppextend Notation Dumpglob -Genarg Syntax_def Smartlocate Reserve diff --git a/interp/modintern.ml b/interp/modintern.ml index 2feac863..fdc6e609 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -1,18 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a - -val error_not_a_functor : module_struct_entry -> 'a - -val error_not_equal : module_path -> module_path -> 'a - -val error_result_must_be_signature : unit -> 'a - -oval error_not_a_modtype_loc : loc -> string -> 'a - -val error_not_a_module_loc : loc -> string -> 'a - -val error_not_a_module_or_modtype_loc : loc -> string -> 'a - -val error_with_in_module : unit -> 'a - -val error_application_to_module_type : unit -> 'a -*) - -let error_result_must_be_signature () = - error "The result module type must be a signature." - -let error_not_a_modtype_loc loc s = - Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModuleType s)) - -let error_not_a_module_loc loc s = - Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModule s)) +let error_not_a_module_loc kind loc qid = + let s = string_of_qualid qid in + let e = match kind with + | Module -> Modops.ModuleTypingError (Modops.NotAModule s) + | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) + | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) + in + Loc.raise loc e -let error_not_a_module_nor_modtype_loc loc s = - Compat.Loc.raise loc (ModuleInternalizationError (NotAModuleNorModtype s)) +let error_application_to_not_path loc me = + Loc.raise loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) let error_incorrect_with_in_module loc = - Compat.Loc.raise loc (ModuleInternalizationError IncorrectWithInModule) + Loc.raise loc (ModuleInternalizationError IncorrectWithInModule) let error_application_to_module_type loc = - Compat.Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication) - - + Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication) +(** Searching for a module name in the Nametab. -let rec make_mp mp = function - [] -> mp - | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl + According to the input module kind, modules or module types + or both are searched. The returned kind is never ModAny, and + it is equal to the input kind when this one isn't ModAny. *) -(* -(* Since module components are not put in the nametab we try to locate -the module prefix *) -exception BadRef - -let lookup_qualid (modtype:bool) qid = - let rec make_mp mp = function - [] -> mp - | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl - in - let rec find_module_prefix dir n = - if n<0 then raise Not_found; - let dir',dir'' = list_chop n dir in - let id',dir''' = - match dir'' with - | hd::tl -> hd,tl - | _ -> anomaly "This list should not be empty!" - in - let qid' = make_qualid dir' id' in - try - match Nametab.locate qid' with - | ModRef mp -> mp,dir''' - | _ -> raise BadRef - with - Not_found -> find_module_prefix dir (pred n) - in - try Nametab.locate qid - with Not_found -> - let (dir,id) = repr_qualid qid in - let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in - let mp = - List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' - in - if modtype then - ModTypeRef (make_ln mp (label_of_id id)) - else - ModRef (MPdot (mp,label_of_id id)) - -*) - - -(* Search for the head of [qid] in [binders]. - If found, returns the module_path/kernel_name created from the dirpath - and the basename. Searches Nametab otherwise. -*) -let lookup_module (loc,qid) = +let lookup_module_or_modtype kind (loc,qid) = try + if kind == ModType then raise Not_found; let mp = Nametab.locate_module qid in - Dumpglob.dump_modref loc mp "modtype"; mp - with - | Not_found -> error_not_a_module_loc loc (string_of_qualid qid) - -let lookup_modtype (loc,qid) = - try - let mp = Nametab.locate_modtype qid in - Dumpglob.dump_modref loc mp "mod"; mp - with - | Not_found -> - error_not_a_modtype_loc loc (string_of_qualid qid) - -let lookup_module_or_modtype (loc,qid) = - try - let mp = Nametab.locate_module qid in - Dumpglob.dump_modref loc mp "modtype"; (mp,true) - with Not_found -> try - let mp = Nametab.locate_modtype qid in - Dumpglob.dump_modref loc mp "mod"; (mp,false) + Dumpglob.dump_modref loc mp "modtype"; (mp,Module) with Not_found -> - error_not_a_module_nor_modtype_loc loc (string_of_qualid qid) + try + if kind == Module then raise Not_found; + let mp = Nametab.locate_modtype qid in + Dumpglob.dump_modref loc mp "mod"; (mp,ModType) + with Not_found -> error_not_a_module_loc kind loc qid + +let lookup_module lqid = fst (lookup_module_or_modtype Module lqid) let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> - With_Module (fqid,lookup_module qid) + WithMod (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> - With_Definition (fqid,interp_constr Evd.empty env c) + WithDef (fqid,fst (interp_constr env Evd.empty c)) (*FIXME*) let loc_of_module = function | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc -let check_module_argument_is_path me' = function - | CMident _ -> () - | (CMapply (loc,_,_) | CMwith (loc,_,_)) -> - Compat.Loc.raise loc - (Modops.ModuleTypingError (Modops.ApplicationToNotPath me')) +(* Invariant : the returned kind is never ModAny, and it is + equal to the input kind when this one isn't ModAny. *) -let rec interp_modexpr env = function +let rec interp_module_ast env kind = function | CMident qid -> - MSEident (lookup_module qid) + let (mp,kind) = lookup_module_or_modtype kind qid in + (MEident mp, kind) | CMapply (_,me1,me2) -> - let me1' = interp_modexpr env me1 in - let me2' = interp_modexpr env me2 in - check_module_argument_is_path me2' me2; - MSEapply(me1',me2') - | CMwith (loc,_,_) -> error_incorrect_with_in_module loc - - -let rec interp_modtype env = function - | CMident qid -> - MSEident (lookup_modtype qid) - | CMapply (_,mty1,me) -> - let mty' = interp_modtype env mty1 in - let me' = interp_modexpr env me in - check_module_argument_is_path me' me; - MSEapply(mty',me') - | CMwith (_,mty,decl) -> - let mty = interp_modtype env mty in - let decl = transl_with_decl env decl in - MSEwith(mty,decl) - -let rec interp_modexpr_or_modtype env = function - | CMident qid -> - let (mp,ismod) = lookup_module_or_modtype qid in - (MSEident mp, ismod) - | CMapply (_,me1,me2) -> - let me1',ismod1 = interp_modexpr_or_modtype env me1 in - let me2',ismod2 = interp_modexpr_or_modtype env me2 in - check_module_argument_is_path me2' me2; - if not ismod2 then error_application_to_module_type (loc_of_module me2); - (MSEapply (me1',me2'), ismod1) + let me1',kind1 = interp_module_ast env kind me1 in + let me2',kind2 = interp_module_ast env ModAny me2 in + let mp2 = match me2' with + | MEident mp -> mp + | _ -> error_application_to_not_path (loc_of_module me2) me2' + in + if kind2 == ModType then + error_application_to_module_type (loc_of_module me2); + (MEapply (me1',mp2), kind1) | CMwith (loc,me,decl) -> - let me,ismod = interp_modexpr_or_modtype env me in + let me,kind = interp_module_ast env kind me in + if kind == Module then error_incorrect_with_in_module loc; let decl = transl_with_decl env decl in - if ismod then error_incorrect_with_in_module loc; - (MSEwith(me,decl), ismod) + (MEwith(me,decl), kind) diff --git a/interp/modintern.mli b/interp/modintern.mli index d832ffc6..8b6d002e 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -1,18 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_ast -> module_struct_entry - -val interp_modexpr : env -> module_ast -> module_struct_entry - -(** The following function tries to interprete an ast as a module, - and in case of failure, interpretes this ast as a module type. - The boolean is true for a module, false for a module type *) - -val interp_modexpr_or_modtype : env -> module_ast -> - module_struct_entry * bool - -val lookup_module : qualid located -> module_path + possible functor or functor signature arguments. When the input kind + is ModAny (i.e. module or module type), we tries to interprete this ast + as a module, and in case of failure, as a module type. The returned + kind is never ModAny, and it is equal to the input kind when this one + isn't ModAny. *) + +val interp_module_ast : + env -> module_kind -> module_ast -> module_struct_entry * module_kind diff --git a/interp/notation.ml b/interp/notation.ml index dddc8aad..aeec4b61 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1,12 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* level * dir_path *) -let notation_level_map = ref Gmap.empty +(* Uninterpreted notation map: notation -> level * DirPath.t *) +let notation_level_map = ref String.Map.empty (* Scopes table: scope_name -> symbol_interpretation *) -let scope_map = ref Gmap.empty +let scope_map = ref String.Map.empty (* Delimiter table : delimiter -> scope_name *) -let delimiters_map = ref Gmap.empty +let delimiters_map = ref String.Map.empty let empty_scope = { - notations = Gmap.empty; + notations = String.Map.empty; delimiters = None } @@ -65,22 +68,33 @@ let default_scope = "" (* empty name, not available from outside *) let type_scope = "type_scope" (* special scope used for interpreting types *) let init_scope_map () = - scope_map := Gmap.add default_scope empty_scope !scope_map; - scope_map := Gmap.add type_scope empty_scope !scope_map + scope_map := String.Map.add default_scope empty_scope !scope_map; + scope_map := String.Map.add type_scope empty_scope !scope_map (**********************************************************************) (* Operations on scopes *) +let parenRelation_eq t1 t2 = match t1, t2 with +| L, L | E, E | Any, Any -> true +| Prec l1, Prec l2 -> Int.equal l1 l2 +| _ -> false + +let level_eq (l1, t1) (l2, t2) = + let tolerability_eq (i1, r1) (i2, r2) = + Int.equal i1 i2 && parenRelation_eq r1 r2 + in + Int.equal l1 l2 && List.equal tolerability_eq t1 t2 + let declare_scope scope = - try let _ = Gmap.find scope !scope_map in () + try let _ = String.Map.find scope !scope_map in () with Not_found -> (* Flags.if_warn message ("Creating scope "^scope);*) - scope_map := Gmap.add scope empty_scope !scope_map + scope_map := String.Map.add scope empty_scope !scope_map let error_unknown_scope sc = error ("Scope "^sc^" is not declared.") let find_scope scope = - try Gmap.find scope !scope_map + try String.Map.find scope !scope_map with Not_found -> error_unknown_scope scope let check_scope sc = let _ = find_scope sc in () @@ -89,11 +103,11 @@ let check_scope sc = let _ = find_scope sc in () (now allowed after Open Scope) *) let normalize_scope sc = - try let _ = Gmap.find sc !scope_map in sc + try let _ = String.Map.find sc !scope_map in sc with Not_found -> try - let sc = Gmap.find sc !delimiters_map in - let _ = Gmap.find sc !scope_map in sc + let sc = String.Map.find sc !delimiters_map in + let _ = String.Map.find sc !scope_map in sc with Not_found -> error_unknown_scope sc (**********************************************************************) @@ -102,12 +116,18 @@ let normalize_scope sc = type scope_elem = Scope of scope_name | SingleNotation of string type scopes = scope_elem list +let scope_eq s1 s2 = match s1, s2 with +| Scope s1, Scope s2 +| SingleNotation s1, SingleNotation s2 -> String.equal s1 s2 +| Scope _, SingleNotation _ +| SingleNotation _, Scope _ -> false + let scope_stack = ref [] let current_scopes () = !scope_stack let scope_is_open_in_scopes sc l = - List.mem (Scope sc) l + List.exists (function Scope sc' -> String.equal sc sc' | _ -> false) l let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) @@ -115,13 +135,14 @@ let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) (* Exportation of scopes *) let open_scope i (_,(local,op,sc)) = - if i=1 then + if Int.equal i 1 then let sc = match sc with | Scope sc -> Scope (normalize_scope sc) | _ -> sc in scope_stack := - if op then sc :: !scope_stack else list_except sc !scope_stack + if op then sc :: !scope_stack + else List.except scope_eq sc !scope_stack let cache_scope o = open_scope 1 o @@ -165,24 +186,24 @@ let declare_delimiters scope key = let sc = find_scope scope in let newsc = { sc with delimiters = Some key } in begin match sc.delimiters with - | None -> scope_map := Gmap.add scope newsc !scope_map - | Some oldkey when oldkey = key -> () + | None -> scope_map := String.Map.add scope newsc !scope_map + | Some oldkey when String.equal oldkey key -> () | Some oldkey -> - Flags.if_warn msg_warning - (str ("Overwriting previous delimiting key "^oldkey^" in scope "^scope)); - scope_map := Gmap.add scope newsc !scope_map + msg_warning + (strbrk ("Overwriting previous delimiting key "^oldkey^" in scope "^scope)); + scope_map := String.Map.add scope newsc !scope_map end; try - let oldscope = Gmap.find key !delimiters_map in - if oldscope = scope then () + let oldscope = String.Map.find key !delimiters_map in + if String.equal oldscope scope then () else begin - Flags.if_warn msg_warning (str ("Hiding binding of key "^key^" to "^oldscope)); - delimiters_map := Gmap.add key scope !delimiters_map + msg_warning (strbrk ("Hiding binding of key "^key^" to "^oldscope)); + delimiters_map := String.Map.add key scope !delimiters_map end - with Not_found -> delimiters_map := Gmap.add key scope !delimiters_map + with Not_found -> delimiters_map := String.Map.add key scope !delimiters_map let find_delimiters_scope loc key = - try Gmap.find key !delimiters_map + try String.Map.find key !delimiters_map with Not_found -> user_err_loc (loc, "find_delimiters", str ("Unknown scope delimiting key "^key^".")) @@ -200,29 +221,50 @@ type key = | RefKey of global_reference | Oth +let key_compare k1 k2 = match k1, k2 with +| RefKey gr1, RefKey gr2 -> RefOrdered.compare gr1 gr2 +| RefKey _, Oth -> -1 +| Oth, RefKey _ -> 1 +| Oth, Oth -> 0 + +module KeyOrd = struct type t = key let compare = key_compare end +module KeyMap = Map.Make(KeyOrd) + +type notation_rule = interp_rule * interpretation * int option + +let keymap_add key interp map = + let old = try KeyMap.find key map with Not_found -> [] in + KeyMap.add key (interp :: old) map + +let keymap_find key map = + try KeyMap.find key map + with Not_found -> [] + (* Scopes table : interpretation -> scope_name *) -let notations_key_table = ref Gmapl.empty -let prim_token_key_table = Hashtbl.create 7 +let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) + +let prim_token_key_table = ref KeyMap.empty let glob_prim_constr_key = function - | GApp (_,GRef (_,ref),_) | GRef (_,ref) -> RefKey (canonical_gr ref) + | GApp (_,GRef (_,ref,_),_) | GRef (_,ref,_) -> RefKey (canonical_gr ref) | _ -> Oth let glob_constr_keys = function - | GApp (_,GRef (_,ref),_) -> [RefKey (canonical_gr ref); Oth] - | GRef (_,ref) -> [RefKey (canonical_gr ref)] + | GApp (_,GRef (_,ref,_),_) -> [RefKey (canonical_gr ref); Oth] + | GRef (_,ref,_) -> [RefKey (canonical_gr ref)] | _ -> [Oth] let cases_pattern_key = function | PatCstr (_,ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) | _ -> Oth -let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) - | AApp (ARef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) - | AList (_,_,AApp (ARef ref,args),_,_) - | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args) - | ARef ref -> RefKey(canonical_gr ref), None - | AApp (_,args) -> Oth, Some (List.length args) +let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) + | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) + | NList (_,_,NApp (NRef ref,args),_,_) + | NBinderList (_,_,NApp (NRef ref,args),_) -> + RefKey (canonical_gr ref), Some (List.length args) + | NRef ref -> RefKey(canonical_gr ref), None + | NApp (_,args) -> Oth, Some (List.length args) | _ -> Oth, None (**********************************************************************) @@ -231,7 +273,7 @@ let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) type required_module = full_path * string list type 'a prim_token_interpreter = - loc -> 'a -> glob_constr + Loc.t -> 'a -> glob_constr type cases_pattern_status = bool (* true = use prim token in patterns *) @@ -239,7 +281,7 @@ type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status type internal_prim_token_interpreter = - loc -> prim_token -> required_module * (unit -> glob_constr) + Loc.t -> prim_token -> required_module * (unit -> glob_constr) let prim_token_interpreter_tab = (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t) @@ -256,8 +298,8 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) = declare_scope sc; add_prim_token_interpreter sc interp; List.iter (fun pat -> - Hashtbl.add prim_token_key_table - (glob_prim_constr_key pat) (sc,uninterp,b)) + prim_token_key_table := KeyMap.add + (glob_prim_constr_key pat) (sc,uninterp,b) !prim_token_key_table) patl let mkNumeral n = Numeral n @@ -280,7 +322,7 @@ let check_required_module loc sc (sp,d) = with Not_found -> user_err_loc (loc,"prim_token_interpreter", str ("Cannot interpret in "^sc^" without requiring first module " - ^(list_last d)^".")) + ^(List.last d)^".")) (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) @@ -288,27 +330,31 @@ let check_required_module loc sc (sp,d) = let find_with_delimiters = function | None -> None | Some scope -> - match (Gmap.find scope !scope_map).delimiters with + match (String.Map.find scope !scope_map).delimiters with | Some key -> Some (Some scope, Some key) | None -> None let rec find_without_delimiters find (ntn_scope,ntn) = function | Scope scope :: scopes -> (* Is the expected ntn/numpr attached to the most recently open scope? *) - if Some scope = ntn_scope then + begin match ntn_scope with + | Some scope' when String.equal scope scope' -> Some (None,None) - else + | _ -> (* If the most recently open scope has a notation/numeral printer but not the expected one then we need delimiters *) if find scope then find_with_delimiters ntn_scope else find_without_delimiters find (ntn_scope,ntn) scopes + end | SingleNotation ntn' :: scopes -> - if ntn_scope = None & ntn = Some ntn' then - Some (None,None) - else + begin match ntn_scope, ntn with + | None, Some ntn when String.equal ntn ntn' -> + Some (None, None) + | _ -> find_without_delimiters find (ntn_scope,ntn) scopes + end | [] -> (* Can we switch to [scope]? Yes if it has defined delimiters *) find_with_delimiters ntn_scope @@ -316,35 +362,43 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function (* Uninterpreted notation levels *) let declare_notation_level ntn level = - if Gmap.mem ntn !notation_level_map then - anomaly ("Notation "^ntn^" is already assigned a level"); - notation_level_map := Gmap.add ntn level !notation_level_map + if String.Map.mem ntn !notation_level_map then + anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level"); + notation_level_map := String.Map.add ntn level !notation_level_map let level_of_notation ntn = - Gmap.find ntn !notation_level_map + String.Map.find ntn !notation_level_map (* The mapping between notations and their interpretation *) let declare_notation_interpretation ntn scopt pat df = let scope = match scopt with Some s -> s | None -> default_scope in let sc = find_scope scope in - if Gmap.mem ntn sc.notations then - Flags.if_warn msg_warning (str ("Notation "^ntn^" was already used"^ - (if scopt = None then "" else " in scope "^scope))); - let sc = { sc with notations = Gmap.add ntn (pat,df) sc.notations } in - scope_map := Gmap.add scope sc !scope_map; - if scopt = None then scope_stack := SingleNotation ntn :: !scope_stack + let () = + if String.Map.mem ntn sc.notations then + let which_scope = match scopt with + | None -> "" + | Some _ -> " in scope " ^ scope in + let message = "Notation " ^ ntn ^ " was already used" ^ which_scope in + msg_warning (strbrk message) + in + let sc = { sc with notations = String.Map.add ntn (pat,df) sc.notations } in + let () = scope_map := String.Map.add scope sc !scope_map in + begin match scopt with + | None -> scope_stack := SingleNotation ntn :: !scope_stack + | Some _ -> () + end let declare_uninterpretation rule (metas,c as pat) = - let (key,n) = aconstr_key c in - notations_key_table := Gmapl.add key (rule,pat,n) !notations_key_table + let (key,n) = notation_constr_key c in + notations_key_table := keymap_add key (rule,pat,n) !notations_key_table let rec find_interpretation ntn find = function | [] -> raise Not_found | Scope scope :: scopes -> (try let (pat,df) = find scope in pat,(df,Some scope) with Not_found -> find_interpretation ntn find scopes) - | SingleNotation ntn'::scopes when ntn' = ntn -> + | SingleNotation ntn'::scopes when String.equal ntn' ntn -> (try let (pat,df) = find default_scope in pat,(df,None) with Not_found -> (* e.g. because single notation only for constr, not cases_pattern *) @@ -353,7 +407,7 @@ let rec find_interpretation ntn find = function find_interpretation ntn find scopes let find_notation ntn sc = - Gmap.find ntn (find_scope sc).notations + String.Map.find ntn (find_scope sc).notations let notation_of_prim_token = function | Numeral n when is_pos_or_zero n -> to_string n @@ -364,12 +418,12 @@ let find_prim_token g loc p sc = (* Try for a user-defined numerical notation *) try let (_,c),df = find_notation (notation_of_prim_token p) sc in - g (glob_constr_of_aconstr loc c),df + g (Notation_ops.glob_constr_of_notation_constr loc c),df with Not_found -> (* Try for a primitive numerical notation *) let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in check_required_module loc sc spdir; - g (interp ()), ((dirpath (fst spdir),empty_dirpath),"") + g (interp ()), ((dirpath (fst spdir),DirPath.empty),"") let interp_prim_token_gen g loc p local_scopes = let scopes = make_current_scopes local_scopes in @@ -384,90 +438,129 @@ let interp_prim_token_gen g loc p local_scopes = let interp_prim_token = interp_prim_token_gen (fun x -> x) -let interp_prim_token_cases_pattern loc p name = - interp_prim_token_gen (cases_pattern_of_glob_constr name) loc p +(** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) -let rec interp_notation loc ntn local_scopes = +let rec rcp_of_glob looked_for = function + | GVar (loc,id) -> RCPatAtom (loc,Some id) + | GHole (loc,_,_,_) -> RCPatAtom (loc,None) + | GRef (loc,g,_) -> looked_for g; RCPatCstr (loc, g,[],[]) + | GApp (loc,GRef (_,g,_),l) -> + looked_for g; RCPatCstr (loc, g, List.map (rcp_of_glob looked_for) l,[]) + | _ -> raise Not_found + +let interp_prim_token_cases_pattern_expr loc looked_for p = + interp_prim_token_gen (rcp_of_glob looked_for) loc p + +let interp_notation loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try find_interpretation ntn (find_notation ntn) scopes with Not_found -> user_err_loc (loc,"",str ("Unknown interpretation for notation \""^ntn^"\".")) -let isGApp = function GApp _ -> true | _ -> false - let uninterp_notations c = - list_map_append (fun key -> Gmapl.find key !notations_key_table) + List.map_append (fun key -> keymap_find key !notations_key_table) (glob_constr_keys c) let uninterp_cases_pattern_notations c = - Gmapl.find (cases_pattern_key c) !notations_key_table + keymap_find (cases_pattern_key c) !notations_key_table + +let uninterp_ind_pattern_notations ind = + keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table let availability_of_notation (ntn_scope,ntn) scopes = let f scope = - Gmap.mem ntn (Gmap.find scope !scope_map).notations in + String.Map.mem ntn (String.Map.find scope !scope_map).notations in find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) let uninterp_prim_token c = try let (sc,numpr,_) = - Hashtbl.find prim_token_key_table (glob_prim_constr_key c) in + KeyMap.find (glob_prim_constr_key c) !prim_token_key_table in match numpr c with - | None -> raise No_match + | None -> raise Notation_ops.No_match + | Some n -> (sc,n) + with Not_found -> raise Notation_ops.No_match + +let uninterp_prim_token_ind_pattern ind args = + let ref = IndRef ind in + try + let k = RefKey (canonical_gr ref) in + let (sc,numpr,b) = KeyMap.find k !prim_token_key_table in + if not b then raise Notation_ops.No_match; + let args' = List.map + (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in + let ref = GRef (Loc.ghost,ref,None) in + match numpr (GApp (Loc.ghost,ref,args')) with + | None -> raise Notation_ops.No_match | Some n -> (sc,n) - with Not_found -> raise No_match + with Not_found -> raise Notation_ops.No_match let uninterp_prim_token_cases_pattern c = try let k = cases_pattern_key c in - let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in - if not b then raise No_match; + let (sc,numpr,b) = KeyMap.find k !prim_token_key_table in + if not b then raise Notation_ops.No_match; let na,c = glob_constr_of_closed_cases_pattern c in match numpr c with - | None -> raise No_match + | None -> raise Notation_ops.No_match | Some n -> (na,sc,n) - with Not_found -> raise No_match + with Not_found -> raise Notation_ops.No_match let availability_of_prim_token n printer_scope local_scopes = let f scope = - try ignore (Hashtbl.find prim_token_interpreter_tab scope dummy_loc n); true + try ignore (Hashtbl.find prim_token_interpreter_tab scope Loc.ghost n); true with Not_found -> false in let scopes = make_current_scopes local_scopes in Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes) (* Miscellaneous *) -let exists_notation_in_scope scopt ntn r = - let scope = match scopt with Some s -> s | None -> default_scope in - try - let sc = Gmap.find scope !scope_map in - let (r',_) = Gmap.find ntn sc.notations in - r' = r - with Not_found -> false - -let isAVar_or_AHole = function AVar _ | AHole _ -> true | _ -> false +let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) (* Mapping classes to scopes *) -open Classops +type scope_class = ScopeRef of global_reference | ScopeSort -let class_scope_map = ref (Gmap.empty : (cl_typ,scope_name) Gmap.t) +let scope_class_compare sc1 sc2 = match sc1, sc2 with +| ScopeRef gr1, ScopeRef gr2 -> RefOrdered.compare gr1 gr2 +| ScopeRef _, ScopeSort -> -1 +| ScopeSort, ScopeRef _ -> 1 +| ScopeSort, ScopeSort -> 0 -let _ = - class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty +let scope_class_of_reference x = ScopeRef x -let declare_class_scope sc cl = - class_scope_map := Gmap.add cl sc !class_scope_map +let compute_scope_class t = + let t', _ = decompose_appvect (Reductionops.whd_betaiotazeta Evd.empty t) in + match kind_of_term t' with + | Var _ | Const _ | Ind _ -> ScopeRef (global_of_constr t') + | Proj (p, c) -> ScopeRef (ConstRef (Projection.constant p)) + | Sort _ -> ScopeSort + | _ -> raise Not_found -let find_class_scope cl = - Gmap.find cl !class_scope_map +module ScopeClassOrd = +struct + type t = scope_class + let compare = scope_class_compare +end -let find_class_scope_opt = function - | None -> None - | Some cl -> try Some (find_class_scope cl) with Not_found -> None +module ScopeClassMap = Map.Make(ScopeClassOrd) -let find_class t = fst (find_class_type Evd.empty t) +let initial_scope_class_map : scope_name ScopeClassMap.t = + ScopeClassMap.add ScopeSort "type_scope" ScopeClassMap.empty + +let scope_class_map = ref initial_scope_class_map + +let declare_scope_class sc cl = + scope_class_map := ScopeClassMap.add cl sc !scope_class_map + +let find_scope_class cl = + ScopeClassMap.find cl !scope_class_map + +let find_scope_class_opt = function + | None -> None + | Some cl -> try Some (find_scope_class cl) with Not_found -> None (**********************************************************************) (* Special scopes associated to arguments of a global reference *) @@ -475,26 +568,37 @@ let find_class t = fst (find_class_type Evd.empty t) let rec compute_arguments_classes t = match kind_of_term (Reductionops.whd_betaiotazeta Evd.empty t) with | Prod (_,t,u) -> - let cl = try Some (find_class t) with Not_found -> None in + let cl = try Some (compute_scope_class t) with Not_found -> None in cl :: compute_arguments_classes u | _ -> [] let compute_arguments_scope_full t = let cls = compute_arguments_classes t in - let scs = List.map find_class_scope_opt cls in + let scs = List.map find_scope_class_opt cls in scs, cls let compute_arguments_scope t = fst (compute_arguments_scope_full t) -(** When merging scope list, we give priority to the first one (computed - by substitution), using the second one (user given or earlier automatic) - as fallback *) +let compute_type_scope t = + find_scope_class_opt (try Some (compute_scope_class t) with Not_found -> None) + +let compute_scope_of_global ref = + find_scope_class_opt (Some (ScopeRef ref)) + +(** Updating a scope list, thanks to a list of argument classes + and the current Bind Scope base. When some current scope + have been manually given, the corresponding argument class + is emptied below, so this manual scope will be preserved. *) -let rec merge_scope sc1 sc2 = match sc1, sc2 with - | [], _ -> sc2 - | _, [] -> sc1 - | Some sc :: sc1, _ :: sc2 -> Some sc :: merge_scope sc1 sc2 - | None :: sc1, sco :: sc2 -> sco :: merge_scope sc1 sc2 +let update_scope cl sco = + match find_scope_class_opt cl with + | None -> sco + | sco' -> sco' + +let rec update_scopes cls scl = match cls, scl with + | [], _ -> scl + | _, [] -> List.map find_scope_class_opt cls + | cl :: cls, sco :: scl -> update_scope cl sco :: update_scopes cls scl let arguments_scope = ref Refmap.empty @@ -505,43 +609,56 @@ type arguments_scope_discharge_request = let load_arguments_scope _ (_,(_,r,scl,cls)) = List.iter (Option.iter check_scope) scl; - arguments_scope := Refmap.add r (scl,cls) !arguments_scope + let initial_stamp = ScopeClassMap.empty in + arguments_scope := Refmap.add r (scl,cls,initial_stamp) !arguments_scope let cache_arguments_scope o = load_arguments_scope 1 o +let subst_scope_class subst cs = match cs with + | ScopeSort -> Some cs + | ScopeRef t -> + let (t',c) = subst_global subst t in + if t == t' then Some cs + else try Some (compute_scope_class c) with Not_found -> None + let subst_arguments_scope (subst,(req,r,scl,cls)) = let r' = fst (subst_global subst r) in - let subst_cl cl = - try Option.smartmap (subst_cl_typ subst) cl with Not_found -> None in - let cls' = list_smartmap subst_cl cls in - let scl' = merge_scope (List.map find_class_scope_opt cls') scl in - let scl'' = List.map (Option.map Declaremods.subst_scope) scl' in - (ArgsScopeNoDischarge,r',scl'',cls') + let subst_cl ocl = match ocl with + | None -> ocl + | Some cl -> + match subst_scope_class subst cl with + | Some cl' as ocl' when cl' != cl -> ocl' + | _ -> ocl in + let cls' = List.smartmap subst_cl cls in + (ArgsScopeNoDischarge,r',scl,cls') let discharge_arguments_scope (_,(req,r,l,_)) = - if req = ArgsScopeNoDischarge or (isVarRef r & Lib.is_in_section r) then None + if req == ArgsScopeNoDischarge || (isVarRef r && Lib.is_in_section r) then None else Some (req,Lib.discharge_global r,l,[]) let classify_arguments_scope (req,_,_,_ as obj) = - if req = ArgsScopeNoDischarge then Dispose else Substitute obj + if req == ArgsScopeNoDischarge then Dispose else Substitute obj let rebuild_arguments_scope (req,r,l,_) = match req with | ArgsScopeNoDischarge -> assert false | ArgsScopeAuto -> - let scs,cls = compute_arguments_scope_full (Global.type_of_global r) in + let scs,cls = compute_arguments_scope_full (fst(Universes.type_of_global r)(*FIXME?*)) in (req,r,scs,cls) | ArgsScopeManual -> (* Add to the manually given scopes the one found automatically - for the extra parameters of the section *) - let l',cls = compute_arguments_scope_full (Global.type_of_global r) in - let l1,_ = list_chop (List.length l' - List.length l) l' in - (req,r,l1@l,cls) + for the extra parameters of the section. Discard the classes + of the manually given scopes to avoid further re-computations. *) + let l',cls = compute_arguments_scope_full (Global.type_of_global_unsafe r) in + let nparams = List.length l' - List.length l in + let l1 = List.firstn nparams l' in + let cls1 = List.firstn nparams cls in + (req,r,l1@l,cls1) type arguments_scope_obj = arguments_scope_discharge_request * global_reference * - scope_name option list * Classops.cl_typ option list + scope_name option list * scope_class option list let inArgumentsScope : arguments_scope_obj -> obj = declare_object {(default_object "ARGUMENTS-SCOPE") with @@ -557,17 +674,27 @@ let is_local local ref = local || isVarRef ref && Lib.is_in_section ref let declare_arguments_scope_gen req r (scl,cls) = Lib.add_anonymous_leaf (inArgumentsScope (req,r,scl,cls)) -let declare_arguments_scope local ref scl = - let req = - if is_local local ref then ArgsScopeNoDischarge else ArgsScopeManual in - declare_arguments_scope_gen req ref (scl,[]) +let declare_arguments_scope local r scl = + let req = if is_local local r then ArgsScopeNoDischarge else ArgsScopeManual + in + (* We empty the list of argument classes to disable futher scope + re-computations and keep these manually given scopes. *) + declare_arguments_scope_gen req r (scl,[]) let find_arguments_scope r = - try fst (Refmap.find r !arguments_scope) + try + let (scl,cls,stamp) = Refmap.find r !arguments_scope in + let cur_stamp = !scope_class_map in + if stamp == cur_stamp then scl + else + (* Recent changes in the Bind Scope base, we re-compute the scopes *) + let scl' = update_scopes cls scl in + arguments_scope := Refmap.add r (scl',cls,cur_stamp) !arguments_scope; + scl' with Not_found -> [] let declare_ref_arguments_scope ref = - let t = Global.type_of_global ref in + let t = Global.type_of_global_unsafe ref in declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t) @@ -576,10 +703,18 @@ let declare_ref_arguments_scope ref = type symbol = | Terminal of string - | NonTerminal of identifier - | SProdList of identifier * symbol list + | NonTerminal of Id.t + | SProdList of Id.t * symbol list | Break of int +let rec symbol_eq s1 s2 = match s1, s2 with +| Terminal s1, Terminal s2 -> String.equal s1 s2 +| NonTerminal id1, NonTerminal id2 -> Id.equal id1 id2 +| SProdList (id1, l1), SProdList (id2, l2) -> + Id.equal id1 id2 && List.equal symbol_eq l1 l2 +| Break i1, Break i2 -> Int.equal i1 i2 +| _ -> false + let rec string_of_symbol = function | NonTerminal _ -> ["_"] | Terminal "_" -> ["'_'"] @@ -602,8 +737,8 @@ let decompose_notation_key s = in let tok = match String.sub s n (pos-n) with - | "_" -> NonTerminal (id_of_string "_") - | s -> Terminal (drop_simple_quotes s) in + | "_" -> NonTerminal (Id.of_string "_") + | s -> Terminal (String.drop_simple_quotes s) in decomp_ntn (tok::dirs) (pos+1) in decomp_ntn [] 0 @@ -616,29 +751,35 @@ let pr_delimiters_info = function | Some key -> str "Delimiting key is " ++ str key let classes_of_scope sc = - Gmap.fold (fun cl sc' l -> if sc = sc' then cl::l else l) !class_scope_map [] + ScopeClassMap.fold (fun cl sc' l -> if String.equal sc sc' then cl::l else l) !scope_class_map [] + +let pr_scope_class = function + | ScopeSort -> str "Sort" + | ScopeRef t -> pr_global_env Id.Set.empty t let pr_scope_classes sc = let l = classes_of_scope sc in - if l = [] then mt() - else - hov 0 (str ("Bound to class"^(if List.tl l=[] then "" else "es")) ++ - spc() ++ prlist_with_sep spc pr_class l) ++ fnl() + match l with + | [] -> mt () + | _ :: l -> + let opt_s = match l with [] -> "" | _ -> "es" in + hov 0 (str ("Bound to class" ^ opt_s) ++ + spc() ++ prlist_with_sep spc pr_scope_class l) ++ fnl() let pr_notation_info prglob ntn c = str "\"" ++ str ntn ++ str "\" := " ++ - prglob (glob_constr_of_aconstr dummy_loc c) + prglob (Notation_ops.glob_constr_of_notation_constr Loc.ghost c) let pr_named_scope prglob scope sc = - (if scope = default_scope then - match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with + (if String.equal scope default_scope then + match String.Map.cardinal sc.notations with | 0 -> str "No lonely notation" - | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s") + | n -> str "Lonely notation" ++ (if Int.equal n 1 then mt() else str"s") else str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters) ++ fnl () ++ pr_scope_classes scope - ++ Gmap.fold + ++ String.Map.fold (fun ntn ((_,r),(_,df)) strm -> pr_notation_info prglob df r ++ fnl () ++ strm) sc.notations (mt ()) @@ -646,16 +787,19 @@ let pr_named_scope prglob scope sc = let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope) let pr_scopes prglob = - Gmap.fold + String.Map.fold (fun scope sc strm -> pr_named_scope prglob scope sc ++ fnl () ++ strm) !scope_map (mt ()) let rec find_default ntn = function - | Scope scope::_ when Gmap.mem ntn (find_scope scope).notations -> - Some scope - | SingleNotation ntn'::_ when ntn = ntn' -> Some default_scope - | _::scopes -> find_default ntn scopes | [] -> None + | Scope scope :: scopes -> + if String.Map.mem ntn (find_scope scope).notations then + Some scope + else find_default ntn scopes + | SingleNotation ntn' :: scopes -> + if String.equal ntn ntn' then Some default_scope + else find_default ntn scopes let factorize_entries = function | [] -> [] @@ -663,29 +807,32 @@ let factorize_entries = function let (ntn,l_of_ntn,rest) = List.fold_left (fun (a',l,rest) (a,c) -> - if a = a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) + if String.equal a a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) (ntn,[c],[]) l in (ntn,l_of_ntn)::rest let browse_notation strict ntn map = - let find = - if String.contains ntn ' ' then (=) ntn - else fun ntn' -> + let find ntn' = + if String.contains ntn ' ' then String.equal ntn ntn' + else let toks = decompose_notation_key ntn' in - let trms = List.filter (function Terminal _ -> true | _ -> false) toks in - if strict then [Terminal ntn] = trms else List.mem (Terminal ntn) trms in + let get_terminals = function Terminal ntn -> Some ntn | _ -> None in + let trms = List.map_filter get_terminals toks in + if strict then String.List.equal [ntn] trms + else String.List.mem ntn trms + in let l = - Gmap.fold + String.Map.fold (fun scope_name sc -> - Gmap.fold (fun ntn ((_,r),df) l -> + String.Map.fold (fun ntn ((_,r),df) l -> if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations) map [] in - List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) l + List.sort (fun x y -> String.compare (fst x) (fst y)) l let global_reference_of_notation test (ntn,(sc,c,_)) = match c with - | ARef ref when test ref -> Some (ntn,sc,ref) - | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref -> + | NRef ref when test ref -> Some (ntn,sc,ref) + | NApp (NRef ref, l) when List.for_all isNVar_or_NHole l && test ref -> Some (ntn,sc,ref) | _ -> None @@ -700,7 +847,8 @@ let error_notation_not_reference loc ntn = let interp_notation_as_global_reference loc test ntn sc = let scopes = match sc with | Some sc -> - Gmap.add sc (find_scope (find_delimiters_scope dummy_loc sc)) Gmap.empty + let scope = find_scope (find_delimiters_scope Loc.ghost sc) in + String.Map.add sc scope String.Map.empty | None -> !scope_map in let ntns = browse_notation true ntn scopes in let refs = List.map (global_reference_of_notation test) ntns in @@ -708,7 +856,12 @@ let interp_notation_as_global_reference loc test ntn sc = | [_,_,ref] -> ref | [] -> error_notation_not_reference loc ntn | refs -> - let f (ntn,sc,ref) = find_default ntn !scope_stack = Some sc in + let f (ntn,sc,ref) = + let def = find_default ntn !scope_stack in + match def with + | None -> false + | Some sc' -> String.equal sc sc' + in match List.filter f refs with | [_,_,ref] -> ref | [] -> error_notation_not_reference loc ntn @@ -717,9 +870,9 @@ let interp_notation_as_global_reference loc test ntn sc = let locate_notation prglob ntn scope = let ntns = factorize_entries (browse_notation false ntn !scope_map) in let scopes = Option.fold_right push_scope scope !scope_stack in - if ntns = [] then - str "Unknown notation" - else + match ntns with + | [] -> str "Unknown notation" + | _ -> t (str "Notation " ++ tab () ++ str "Scope " ++ tab () ++ fnl () ++ prlist (fun (ntn,l) -> @@ -728,35 +881,35 @@ let locate_notation prglob ntn scope = (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prglob df r ++ tbrk (1,2) ++ - (if sc = default_scope then mt () else (str ": " ++ str sc)) ++ + (if String.equal sc default_scope then mt () else (str ": " ++ str sc)) ++ tbrk (1,2) ++ - (if Some sc = scope then str "(default interpretation)" else mt ()) + (if Option.equal String.equal (Some sc) scope then str "(default interpretation)" else mt ()) ++ fnl ())) l) ntns) let collect_notation_in_scope scope sc known = - assert (scope <> default_scope); - Gmap.fold + assert (not (String.equal scope default_scope)); + String.Map.fold (fun ntn ((_,r),(_,df)) (l,known as acc) -> - if List.mem ntn known then acc else ((df,r)::l,ntn::known)) + if String.List.mem ntn known then acc else ((df,r)::l,ntn::known)) sc.notations ([],known) let collect_notations stack = fst (List.fold_left (fun (all,knownntn as acc) -> function | Scope scope -> - if List.mem_assoc scope all then acc + if String.List.mem_assoc scope all then acc else let (l,knownntn) = collect_notation_in_scope scope (find_scope scope) knownntn in ((scope,l)::all,knownntn) | SingleNotation ntn -> - if List.mem ntn knownntn then (all,knownntn) + if String.List.mem ntn knownntn then (all,knownntn) else let ((_,r),(_,df)) = - Gmap.find ntn (find_scope default_scope).notations in + String.Map.find ntn (find_scope default_scope).notations in let all' = match all with - | (s,lonelyntn)::rest when s = default_scope -> + | (s,lonelyntn)::rest when String.equal s default_scope -> (s,(df,r)::lonelyntn)::rest | _ -> (default_scope,[df,r])::all in @@ -768,8 +921,8 @@ let pr_visible_in_scope prglob (scope,ntns) = List.fold_right (fun (df,r) strm -> pr_notation_info prglob df r ++ fnl () ++ strm) ntns (mt ()) in - (if scope = default_scope then - str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt()) + (if String.equal scope default_scope then + str "Lonely notation" ++ (match ntns with [_] -> mt () | _ -> str "s") else str "Visible in scope " ++ str scope) ++ fnl () ++ strm @@ -787,25 +940,36 @@ let pr_visibility prglob = function (* Mapping notations to concrete syntax *) type unparsing_rule = unparsing list * precedence - +type extra_unparsing_rules = (string * string) list (* Concrete syntax for symbolic-extension table *) let printing_rules = - ref (Gmap.empty : (string,unparsing_rule) Gmap.t) + ref (String.Map.empty : (unparsing_rule * extra_unparsing_rules) String.Map.t) -let declare_notation_printing_rule ntn unpl = - printing_rules := Gmap.add ntn unpl !printing_rules +let declare_notation_printing_rule ntn ~extra unpl = + printing_rules := String.Map.add ntn (unpl,extra) !printing_rules let find_notation_printing_rule ntn = - try Gmap.find ntn !printing_rules - with Not_found -> anomaly ("No printing rule found for "^ntn) + try fst (String.Map.find ntn !printing_rules) + with Not_found -> anomaly (str "No printing rule found for " ++ str ntn) +let find_notation_extra_printing_rules ntn = + try snd (String.Map.find ntn !printing_rules) + with Not_found -> [] +let add_notation_extra_printing_rule ntn k v = + try + printing_rules := + let p, pp = String.Map.find ntn !printing_rules in + String.Map.add ntn (p, (k,v) :: pp) !printing_rules + with Not_found -> + user_err_loc (Loc.ghost,"add_notation_extra_printing_rule", + str "No such Notation.") (**********************************************************************) (* Synchronisation with reset *) -let freeze () = +let freeze _ = (!scope_map, !notation_level_map, !scope_stack, !arguments_scope, !delimiters_map, !notations_key_table, !printing_rules, - !class_scope_map) + !scope_class_map) let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) = scope_map := scm; @@ -815,27 +979,26 @@ let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) = arguments_scope := asc; notations_key_table := fkm; printing_rules := pprules; - class_scope_map := clsc + scope_class_map := clsc let init () = init_scope_map (); -(* - scope_stack := Gmap.empty - arguments_scope := Refmap.empty -*) - notation_level_map := Gmap.empty; - delimiters_map := Gmap.empty; - notations_key_table := Gmapl.empty; - printing_rules := Gmap.empty; - class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty + notation_level_map := String.Map.empty; + delimiters_map := String.Map.empty; + notations_key_table := KeyMap.empty; + printing_rules := String.Map.empty; + scope_class_map := initial_scope_class_map let _ = - declare_summary "symbols" - { freeze_function = freeze; - unfreeze_function = unfreeze; - init_function = init } + Summary.declare_summary "symbols" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } let with_notation_protection f x = - let fs = freeze () in + let fs = freeze false in try let a = f x in unfreeze fs; a - with reraise -> unfreeze fs; raise reraise + with reraise -> + let reraise = Errors.push reraise in + let () = unfreeze fs in + iraise reraise diff --git a/interp/notation.mli b/interp/notation.mli index bb2d5090..c66115cb 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -1,19 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val current_scopes : unit -> scopes +val level_eq : level -> level -> bool + (** Check where a scope is opened or not in a scope list, or in * the current opened scopes *) val scope_is_open_in_scopes : scope_name -> scopes -> bool @@ -53,7 +55,7 @@ val find_scope : scope_name -> scope (** Declare delimiters for printing *) val declare_delimiters : scope_name -> delimiters -> unit -val find_delimiters_scope : loc -> delimiters -> scope_name +val find_delimiters_scope : Loc.t -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) @@ -62,12 +64,12 @@ val find_delimiters_scope : loc -> delimiters -> scope_name negative numbers are not supported, the interpreter must fail with an appropriate error message *) -type notation_location = (dir_path * dir_path) * string +type notation_location = (DirPath.t * DirPath.t) * string type required_module = full_path * string list type cases_pattern_status = bool (** true = use prim token in patterns *) type 'a prim_token_interpreter = - loc -> 'a -> glob_constr + Loc.t -> 'a -> glob_constr type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status @@ -81,10 +83,10 @@ val declare_string_interpreter : scope_name -> required_module -> (** Return the [term]/[cases_pattern] bound to a primitive token in a given scope context*) -val interp_prim_token : loc -> prim_token -> local_scopes -> +val interp_prim_token : Loc.t -> prim_token -> local_scopes -> glob_constr * (notation_location * scope_name option) -val interp_prim_token_cases_pattern : loc -> prim_token -> name -> - local_scopes -> cases_pattern * (notation_location * scope_name option) +val interp_prim_token_cases_pattern_expr : Loc.t -> (global_reference -> unit) -> prim_token -> + local_scopes -> raw_cases_pattern_expr * (notation_location * scope_name option) (** Return the primitive token associated to a [term]/[cases_pattern]; raise [No_match] if no such token *) @@ -92,7 +94,9 @@ val interp_prim_token_cases_pattern : loc -> prim_token -> name -> val uninterp_prim_token : glob_constr -> scope_name * prim_token val uninterp_prim_token_cases_pattern : - cases_pattern -> name * scope_name * prim_token + cases_pattern -> Name.t * scope_name * prim_token +val uninterp_prim_token_ind_pattern : + inductive -> cases_pattern list -> scope_name * prim_token val availability_of_prim_token : prim_token -> scope_name -> local_scopes -> delimiters option option @@ -110,14 +114,15 @@ val declare_notation_interpretation : notation -> scope_name option -> val declare_uninterpretation : interp_rule -> interpretation -> unit (** Return the interpretation bound to a notation *) -val interp_notation : loc -> notation -> local_scopes -> +val interp_notation : Loc.t -> notation -> local_scopes -> interpretation * (notation_location * scope_name option) +type notation_rule = interp_rule * interpretation * int option + (** Return the possible notations for a given term *) -val uninterp_notations : glob_constr -> - (interp_rule * interpretation * int option) list -val uninterp_cases_pattern_notations : cases_pattern -> - (interp_rule * interpretation * int option) list +val uninterp_notations : glob_constr -> notation_rule list +val uninterp_cases_pattern_notations : cases_pattern -> notation_rule list +val uninterp_ind_pattern_notations : inductive -> notation_rule list (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first @@ -132,36 +137,43 @@ val level_of_notation : notation -> level (** raise [Not_found] if no level *) (** {6 Miscellaneous} *) -val interp_notation_as_global_reference : loc -> (global_reference -> bool) -> +val interp_notation_as_global_reference : Loc.t -> (global_reference -> bool) -> notation -> delimiters option -> global_reference -(** Checks for already existing notations *) -val exists_notation_in_scope : scope_name option -> notation -> - interpretation -> bool - (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : bool (** true=local *) -> global_reference -> scope_name option list -> unit val find_arguments_scope : global_reference -> scope_name option list -val declare_class_scope : scope_name -> Classops.cl_typ -> unit +type scope_class + +val scope_class_of_reference : global_reference -> scope_class +val subst_scope_class : + Mod_subst.substitution -> scope_class -> scope_class option + +val declare_scope_class : scope_name -> scope_class -> unit val declare_ref_arguments_scope : global_reference -> unit val compute_arguments_scope : Term.types -> scope_name option list +val compute_type_scope : Term.types -> scope_name option +val compute_scope_of_global : global_reference -> scope_name option (** Building notation key *) type symbol = | Terminal of string - | NonTerminal of identifier - | SProdList of identifier * symbol list + | NonTerminal of Id.t + | SProdList of Id.t * symbol list | Break of int +val symbol_eq : symbol -> symbol -> bool + val make_notation_key : symbol list -> notation val decompose_notation_key : notation -> symbol list (** Prints scopes (expects a pure aconstr printer) *) +val pr_scope_class : scope_class -> std_ppcmds val pr_scope : (glob_constr -> std_ppcmds) -> scope_name -> std_ppcmds val pr_scopes : (glob_constr -> std_ppcmds) -> std_ppcmds val locate_notation : (glob_constr -> std_ppcmds) -> notation -> @@ -173,8 +185,12 @@ val pr_visibility: (glob_constr -> std_ppcmds) -> scope_name option -> std_ppcmd (** Declare and look for the printing rule for symbolic notations *) type unparsing_rule = unparsing list * precedence -val declare_notation_printing_rule : notation -> unparsing_rule -> unit +type extra_unparsing_rules = (string * string) list +val declare_notation_printing_rule : + notation -> extra:extra_unparsing_rules -> unparsing_rule -> unit val find_notation_printing_rule : notation -> unparsing_rule +val find_notation_extra_printing_rules : notation -> extra_unparsing_rules +val add_notation_extra_printing_rule : notation -> string -> string -> unit (** Rem: printing rules for primitive token are canonical *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml new file mode 100644 index 00000000..c91c7815 --- /dev/null +++ b/interp/notation_ops.ml @@ -0,0 +1,856 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Errors.error "This expression should be a simple identifier." + | Name id -> id + +let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na + +let rec cases_pattern_fold_map loc g e = function + | PatVar (_,na) -> + let e',na' = g e na in e', PatVar (loc,na') + | PatCstr (_,cstr,patl,na) -> + let e',na' = g e na in + let e',patl' = List.fold_map (cases_pattern_fold_map loc g) e patl in + e', PatCstr (loc,cstr,patl',na') + +let rec subst_glob_vars l = function + | GVar (_,id) as r -> (try Id.List.assoc id l with Not_found -> r) + | GProd (loc,Name id,bk,t,c) -> + let id = + try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id + with Not_found -> id in + GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) + | GLambda (loc,Name id,bk,t,c) -> + let id = + try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id + with Not_found -> id in + GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) + | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *) + +let ldots_var = Id.of_string ".." + +let glob_constr_of_notation_constr_with_binders loc g f e = function + | NVar id -> GVar (loc,id) + | NApp (a,args) -> GApp (loc,f e a, List.map (f e) args) + | NList (x,y,iter,tail,swap) -> + let t = f e tail in let it = f e iter in + let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in + let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in + let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in + subst_glob_vars outerl it + | NBinderList (x,y,iter,tail) -> + let t = f e tail in let it = f e iter in + let innerl = [(ldots_var,t);(x,GVar(loc,y))] in + let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in + let outerl = [(ldots_var,inner)] in + subst_glob_vars outerl it + | NLambda (na,ty,c) -> + let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c) + | NProd (na,ty,c) -> + let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c) + | NLetIn (na,b,c) -> + let e',na = g e na in GLetIn (loc,na,f e b,f e' c) + | NCases (sty,rtntypopt,tml,eqnl) -> + let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> + let e',t' = match t with + | None -> e',None + | Some (ind,nal) -> + let e',nal' = List.fold_right (fun na (e',nal) -> + let e',na' = g e' na in e',na'::nal) nal (e',[]) in + e',Some (loc,ind,nal') in + let e',na' = g e' na in + (e',(f e tm,(na',t'))::tml')) tml (e,[]) in + let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in + let eqnl' = List.map (fun (patl,rhs) -> + let ((idl,e),patl) = + List.fold_map (cases_pattern_fold_map loc fold) ([],e) patl in + (loc,idl,patl,f e rhs)) eqnl in + GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl') + | NLetTuple (nal,(na,po),b,c) -> + let e',nal = List.fold_map g e nal in + let e'',na = g e na in + GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c) + | NIf (c,(na,po),b1,b2) -> + let e',na = g e na in + GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2) + | NRec (fk,idl,dll,tl,bl) -> + let e,dll = Array.fold_map (List.fold_map (fun e (na,oc,b) -> + let e,na = g e na in + (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in + let e',idl = Array.fold_map (to_id g) e idl in + GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) + | NCast (c,k) -> GCast (loc,f e c,Miscops.map_cast_type (f e) k) + | NSort x -> GSort (loc,x) + | NHole (x, naming, arg) -> GHole (loc, x, naming, arg) + | NPatVar n -> GPatVar (loc,(false,n)) + | NRef x -> GRef (loc,x,None) + +let glob_constr_of_notation_constr loc x = + let rec aux () x = + glob_constr_of_notation_constr_with_binders loc (fun () id -> ((),id)) aux () x + in aux () x + +(****************************************************************************) +(* Translating a glob_constr into a notation, interpreting recursive patterns *) + +let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) +let add_name r = function Anonymous -> () | Name id -> add_id r id + +let split_at_recursive_part c = + let sub = ref None in + let rec aux = function + | GApp (loc0,GVar(loc,v),c::l) when Id.equal v ldots_var -> + begin match !sub with + | None -> + let () = sub := Some c in + begin match l with + | [] -> GVar (loc, ldots_var) + | _ :: _ -> GApp (loc0, GVar (loc, ldots_var), l) + end + | Some _ -> + (* Not narrowed enough to find only one recursive part *) + raise Not_found + end + | c -> map_glob_constr aux c in + let outer_iterator = aux c in + match !sub with + | None -> (* No recursive pattern found *) raise Not_found + | Some c -> + match outer_iterator with + | GVar (_,v) when Id.equal v ldots_var -> (* Not enough context *) raise Not_found + | _ -> outer_iterator, c + +let on_true_do b f c = if b then (f c; b) else b + +let compare_glob_constr f add t1 t2 = match t1,t2 with + | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2 + | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) + | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 + | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) + when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> + on_true_do (f ty1 ty2 && f c1 c2) add na1 + | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) + when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> + on_true_do (f ty1 ty2 && f c1 c2) add na1 + | GHole _, GHole _ -> true + | GSort (_,s1), GSort (_,s2) -> Miscops.glob_sort_eq s1 s2 + | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when Name.equal na1 na2 -> + on_true_do (f b1 b2 && f c1 c2) add na1 + | (GCases _ | GRec _ + | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ + | _,(GCases _ | GRec _ + | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) + -> error "Unsupported construction in recursive notations." + | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ + | GHole _ | GSort _ | GLetIn _), _ + -> false + +let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2 + +let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) + +let check_is_hole id = function GHole _ -> () | t -> + user_err_loc (loc_of_glob_constr t,"", + strbrk "In recursive notation with binders, " ++ pr_id id ++ + strbrk " is expected to come without type.") + +let compare_recursive_parts found f (iterator,subc) = + let diff = ref None in + let terminator = ref None in + let rec aux c1 c2 = match c1,c2 with + | GVar(_,v), term when Id.equal v ldots_var -> + (* We found the pattern *) + assert (match !terminator with None -> true | Some _ -> false); + terminator := Some term; + true + | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when Id.equal v ldots_var -> + (* We found the pattern, but there are extra arguments *) + (* (this allows e.g. alternative (recursive) notation of application) *) + assert (match !terminator with None -> true | Some _ -> false); + terminator := Some term; + List.for_all2eq aux l1 l2 + | GVar (_,x), GVar (_,y) when not (Id.equal x y) -> + (* We found the position where it differs *) + let lassoc = match !terminator with None -> false | Some _ -> true in + let x,y = if lassoc then y,x else x,y in + begin match !diff with + | None -> + let () = diff := Some (x, y, Some lassoc) in + true + | Some _ -> false + end + | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) + | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> + (* We found a binding position where it differs *) + check_is_hole x t_x; + check_is_hole y t_y; + begin match !diff with + | None -> + let () = diff := Some (x, y, None) in + aux c term + | Some _ -> false + end + | _ -> + compare_glob_constr aux (add_name found) c1 c2 in + if aux iterator subc then + match !diff with + | None -> + let loc1 = loc_of_glob_constr iterator in + let loc2 = loc_of_glob_constr (Option.get !terminator) in + (* Here, we would need a loc made of several parts ... *) + user_err_loc (subtract_loc loc1 loc2,"", + str "Both ends of the recursive pattern are the same.") + | Some (x,y,Some lassoc) -> + let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in + let iterator = + f (if lassoc then subst_glob_vars [y,GVar(Loc.ghost,x)] iterator + else iterator) in + (* found have been collected by compare_constr *) + found := newfound; + NList (x,y,iterator,f (Option.get !terminator),lassoc) + | Some (x,y,None) -> + let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in + let iterator = f iterator in + (* found have been collected by compare_constr *) + found := newfound; + NBinderList (x,y,iterator,f (Option.get !terminator)) + else + raise Not_found + +let notation_constr_and_vars_of_glob_constr a = + let found = ref ([],[],[]) in + let rec aux c = + let keepfound = !found in + (* n^2 complexity but small and done only once per notation *) + try compare_recursive_parts found aux' (split_at_recursive_part c) + with Not_found -> + found := keepfound; + match c with + | GApp (_,GVar (loc,f),[c]) when Id.equal f ldots_var -> + (* Fall on the second part of the recursive pattern w/o having + found the first part *) + user_err_loc (loc,"", + str "Cannot find where the recursive pattern starts.") + | c -> + aux' c + and aux' = function + | GVar (_,id) -> add_id found id; NVar id + | GApp (_,g,args) -> NApp (aux g, List.map aux args) + | GLambda (_,na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) + | GProd (_,na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) + | GLetIn (_,na,b,c) -> add_name found na; NLetIn (na,aux b,aux c) + | GCases (_,sty,rtntypopt,tml,eqnl) -> + let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in + NCases (sty,Option.map aux rtntypopt, + List.map (fun (tm,(na,x)) -> + add_name found na; + Option.iter + (fun (_,_,nl) -> List.iter (add_name found) nl) x; + (aux tm,(na,Option.map (fun (_,ind,nal) -> (ind,nal)) x))) tml, + List.map f eqnl) + | GLetTuple (loc,nal,(na,po),b,c) -> + add_name found na; + List.iter (add_name found) nal; + NLetTuple (nal,(na,Option.map aux po),aux b,aux c) + | GIf (loc,c,(na,po),b1,b2) -> + add_name found na; + NIf (aux c,(na,Option.map aux po),aux b1,aux b2) + | GRec (_,fk,idl,dll,tl,bl) -> + Array.iter (add_id found) idl; + let dll = Array.map (List.map (fun (na,bk,oc,b) -> + if bk != Explicit then + error "Binders marked as implicit not allowed in notations."; + add_name found na; (na,Option.map aux oc,aux b))) dll in + NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) + | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k) + | GSort (_,s) -> NSort s + | GHole (_,w,naming,arg) -> NHole (w, naming, arg) + | GRef (_,r,_) -> NRef r + | GPatVar (_,(_,n)) -> NPatVar n + | GEvar _ -> + error "Existential variables not allowed in notations." + + in + let t = aux a in + (* Side effect *) + t, !found + +let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' + +let check_variables nenv (found,foundrec,foundrecbinding) = + let recvars = nenv.ninterp_rec_vars in + let fold _ y accu = Id.Set.add y accu in + let useless_vars = Id.Map.fold fold recvars Id.Set.empty in + let filter y _ = not (Id.Set.mem y useless_vars) in + let vars = Id.Map.filter filter nenv.ninterp_var_type in + let check_recvar x = + if Id.List.mem x found then + errorlabstrm "" (pr_id x ++ + strbrk " should only be used in the recursive part of a pattern.") in + let check (x, y) = check_recvar x; check_recvar y in + let () = List.iter check foundrec in + let () = List.iter check foundrecbinding in + let check_bound x = + if not (Id.List.mem x found) then + if Id.List.mem_assoc x foundrec || + Id.List.mem_assoc x foundrecbinding || + Id.List.mem_assoc_sym x foundrec || + Id.List.mem_assoc_sym x foundrecbinding + then + error + (Id.to_string x ^ + " should not be bound in a recursive pattern of the right-hand side.") + else nenv.ninterp_only_parse <- true + in + let check_pair s x y where = + if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then + errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ + str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ + str " position as part of a recursive pattern.") in + let check_type x typ = + match typ with + | NtnInternTypeConstr -> + begin + try check_pair "term" x (Id.Map.find x recvars) foundrec + with Not_found -> check_bound x + end + | NtnInternTypeBinder -> + begin + try check_pair "binding" x (Id.Map.find x recvars) foundrecbinding + with Not_found -> check_bound x + end + | NtnInternTypeIdent -> check_bound x in + Id.Map.iter check_type vars + +let notation_constr_of_glob_constr nenv a = + let a, found = notation_constr_and_vars_of_glob_constr a in + let () = check_variables nenv found in + a + +(* Substitution of kernel names, avoiding a list of bound identifiers *) + +let notation_constr_of_constr avoiding t = + let t = Detyping.detype false avoiding (Global.env()) Evd.empty t in + let nenv = { + ninterp_var_type = Id.Map.empty; + ninterp_rec_vars = Id.Map.empty; + ninterp_only_parse = false; + } in + notation_constr_of_glob_constr nenv t + +let rec subst_pat subst pat = + match pat with + | PatVar _ -> pat + | PatCstr (loc,((kn,i),j),cpl,n) -> + let kn' = subst_mind subst kn + and cpl' = List.smartmap (subst_pat subst) cpl in + if kn' == kn && cpl' == cpl then pat else + PatCstr (loc,((kn',i),j),cpl',n) + +let rec subst_notation_constr subst bound raw = + match raw with + | NRef ref -> + let ref',t = subst_global subst ref in + if ref' == ref then raw else + notation_constr_of_constr bound t + + | NVar _ -> raw + + | NApp (r,rl) -> + let r' = subst_notation_constr subst bound r + and rl' = List.smartmap (subst_notation_constr subst bound) rl in + if r' == r && rl' == rl then raw else + NApp(r',rl') + + | NList (id1,id2,r1,r2,b) -> + let r1' = subst_notation_constr subst bound r1 + and r2' = subst_notation_constr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + NList (id1,id2,r1',r2',b) + + | NLambda (n,r1,r2) -> + let r1' = subst_notation_constr subst bound r1 + and r2' = subst_notation_constr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + NLambda (n,r1',r2') + + | NProd (n,r1,r2) -> + let r1' = subst_notation_constr subst bound r1 + and r2' = subst_notation_constr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + NProd (n,r1',r2') + + | NBinderList (id1,id2,r1,r2) -> + let r1' = subst_notation_constr subst bound r1 + and r2' = subst_notation_constr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + NBinderList (id1,id2,r1',r2') + + | NLetIn (n,r1,r2) -> + let r1' = subst_notation_constr subst bound r1 + and r2' = subst_notation_constr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + NLetIn (n,r1',r2') + + | NCases (sty,rtntypopt,rl,branches) -> + let rtntypopt' = Option.smartmap (subst_notation_constr subst bound) rtntypopt + and rl' = List.smartmap + (fun (a,(n,signopt) as x) -> + let a' = subst_notation_constr subst bound a in + let signopt' = Option.map (fun ((indkn,i),nal as z) -> + let indkn' = subst_mind subst indkn in + if indkn == indkn' then z else ((indkn',i),nal)) signopt in + if a' == a && signopt' == signopt then x else (a',(n,signopt'))) + rl + and branches' = List.smartmap + (fun (cpl,r as branch) -> + let cpl' = List.smartmap (subst_pat subst) cpl + and r' = subst_notation_constr subst bound r in + if cpl' == cpl && r' == r then branch else + (cpl',r')) + branches + in + if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' && + rl' == rl && branches' == branches then raw else + NCases (sty,rtntypopt',rl',branches') + + | NLetTuple (nal,(na,po),b,c) -> + let po' = Option.smartmap (subst_notation_constr subst bound) po + and b' = subst_notation_constr subst bound b + and c' = subst_notation_constr subst bound c in + if po' == po && b' == b && c' == c then raw else + NLetTuple (nal,(na,po'),b',c') + + | NIf (c,(na,po),b1,b2) -> + let po' = Option.smartmap (subst_notation_constr subst bound) po + and b1' = subst_notation_constr subst bound b1 + and b2' = subst_notation_constr subst bound b2 + and c' = subst_notation_constr subst bound c in + if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else + NIf (c',(na,po'),b1',b2') + + | NRec (fk,idl,dll,tl,bl) -> + let dll' = + Array.smartmap (List.smartmap (fun (na,oc,b as x) -> + let oc' = Option.smartmap (subst_notation_constr subst bound) oc in + let b' = subst_notation_constr subst bound b in + if oc' == oc && b' == b then x else (na,oc',b'))) dll in + let tl' = Array.smartmap (subst_notation_constr subst bound) tl in + let bl' = Array.smartmap (subst_notation_constr subst bound) bl in + if dll' == dll && tl' == tl && bl' == bl then raw else + NRec (fk,idl,dll',tl',bl') + + | NPatVar _ | NSort _ -> raw + + | NHole (knd, naming, solve) -> + let nknd = match knd with + | Evar_kinds.ImplicitArg (ref, i, b) -> + let nref, _ = subst_global subst ref in + if nref == ref then knd else Evar_kinds.ImplicitArg (nref, i, b) + | _ -> knd + in + let nsolve = Option.smartmap (Genintern.generic_substitute subst) solve in + if nsolve == solve && nknd == knd then raw + else NHole (nknd, naming, nsolve) + + | NCast (r1,k) -> + let r1' = subst_notation_constr subst bound r1 in + let k' = Miscops.smartmap_cast_type (subst_notation_constr subst bound) k in + if r1' == r1 && k' == k then raw else NCast(r1',k') + +let subst_interpretation subst (metas,pat) = + let bound = List.map fst metas in + (metas,subst_notation_constr subst bound pat) + +(* Pattern-matching glob_constr and notation_constr *) + +let abstract_return_type_context pi mklam tml rtno = + Option.map (fun rtn -> + let nal = + List.flatten (List.map (fun (_,(na,t)) -> + match t with Some x -> (pi x)@[na] | None -> [na]) tml) in + List.fold_right mklam nal rtn) + rtno + +let abstract_return_type_context_glob_constr = + abstract_return_type_context (fun (_,_,nal) -> nal) + (fun na c -> + GLambda(Loc.ghost,na,Explicit,GHole(Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) + +let abstract_return_type_context_notation_constr = + abstract_return_type_context snd + (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) + +exception No_match + +let rec alpha_var id1 id2 = function + | (i1,i2)::_ when Id.equal i1 id1 -> Id.equal i2 id2 + | (i1,i2)::_ when Id.equal i2 id2 -> Id.equal i1 id1 + | _::idl -> alpha_var id1 id2 idl + | [] -> Id.equal id1 id2 + +let add_env alp (sigma,sigmalist,sigmabinders) var v = + (* Check that no capture of binding variables occur *) + if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match; + (* TODO: handle the case of multiple occs in different scopes *) + ((var,v)::sigma,sigmalist,sigmabinders) + +let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = + try + let v' = Id.List.assoc var sigma in + match v, v' with + | GHole _, _ -> fullsigma + | _, GHole _ -> + add_env alp (Id.List.remove_assoc var sigma,sigmalist,sigmabinders) var v + | _, _ -> + if glob_constr_eq v v' then fullsigma + else raise No_match + with Not_found -> add_env alp fullsigma var v + +let bind_binder (sigma,sigmalist,sigmabinders) x bl = + (sigma,sigmalist,(x,List.rev bl)::sigmabinders) + +let match_fix_kind fk1 fk2 = + match (fk1,fk2) with + | GCoFix n1, GCoFix n2 -> Int.equal n1 n2 + | GFix (nl1,n1), GFix (nl2,n2) -> + let test (n1, _) (n2, _) = match n1, n2 with + | _, None -> true + | Some id1, Some id2 -> Int.equal id1 id2 + | _ -> false + in + Int.equal n1 n2 && + Array.for_all2 test nl1 nl2 + | _ -> false + +let match_opt f sigma t1 t2 = match (t1,t2) with + | None, None -> sigma + | Some t1, Some t2 -> f sigma t1 t2 + | _ -> raise No_match + +let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with + | (_,Name id2) when Id.List.mem id2 (fst metas) -> + let rhs = match na1 with + | Name id1 -> GVar (Loc.ghost,id1) + | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in + alp, bind_env alp sigma id2 rhs + | (Name id1,Name id2) -> (id1,id2)::alp,sigma + | (Anonymous,Anonymous) -> alp,sigma + | _ -> raise No_match + +let rec match_cases_pattern_binders metas acc pat1 pat2 = + match (pat1,pat2) with + | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2 + | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2) + when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> + List.fold_left2 (match_cases_pattern_binders metas) + (match_names metas acc na1 na2) patl1 patl2 + | _ -> raise No_match + +let glue_letin_with_decls = true + +let rec match_iterated_binders islambda decls = function + | GLambda (_,na,bk,t,b) when islambda -> + match_iterated_binders islambda ((na,bk,None,t)::decls) b + | GProd (_,(Name _ as na),bk,t,b) when not islambda -> + match_iterated_binders islambda ((na,bk,None,t)::decls) b + | GLetIn (loc,na,c,b) when glue_letin_with_decls -> + match_iterated_binders islambda + ((na,Explicit (*?*), Some c,GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None))::decls) b + | b -> (decls,b) + +let remove_sigma x (sigmavar,sigmalist,sigmabinders) = + (Id.List.remove_assoc x sigmavar,sigmalist,sigmabinders) + +let match_abinderlist_with_app match_fun metas sigma rest x iter termin = + let rec aux sigma acc rest = + try + let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in + let rest = Id.List.assoc ldots_var (pi1 sigma) in + let b = + match Id.List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false + in + let sigma = remove_sigma x (remove_sigma ldots_var sigma) in + aux sigma (b::acc) rest + with No_match when not (List.is_empty acc) -> + acc, match_fun metas sigma rest termin in + let bl,sigma = aux sigma [] rest in + bind_binder sigma x bl + +let match_alist match_fun metas sigma rest x iter termin lassoc = + let rec aux sigma acc rest = + try + let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in + let rest = Id.List.assoc ldots_var (pi1 sigma) in + let t = Id.List.assoc x (pi1 sigma) in + let sigma = remove_sigma x (remove_sigma ldots_var sigma) in + aux sigma (t::acc) rest + with No_match when not (List.is_empty acc) -> + acc, match_fun metas sigma rest termin in + let l,sigma = aux sigma [] rest in + (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma) + +let does_not_come_from_already_eta_expanded_var = + (* This is hack to avoid looping on a rule with rhs of the form *) + (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *) + (* "F (fun x => H x)" and "H x" is recursively matched against the same *) + (* rule, giving "H (fun x' => x x')" and so on. *) + (* Ideally, we would need the type of the expression to know which of *) + (* the arguments applied to it can be eta-expanded without looping. *) + (* The following test is then an approximation of what can be done *) + (* optimally (whether other looping situations can occur remains to be *) + (* checked). *) + function GVar _ -> false | _ -> true + +let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = + match (a1,a2) with + + (* Matching notation variable *) + | r1, NVar id2 when Id.List.mem id2 tmetas -> bind_env alp sigma id2 r1 + + (* Matching recursive notations for terms *) + | r1, NList (x,_,iter,termin,lassoc) -> + match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc + + (* Matching recursive notations for binders: ad hoc cases supporting let-in *) + | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name id2,_,b2),termin)-> + let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in + (* TODO: address the possibility that termin is a Lambda itself *) + match_in u alp metas (bind_binder sigma x decls) b termin + | GProd (_,na1,bk,t1,b1), NBinderList (x,_,NProd (Name id2,_,b2),termin) + when na1 != Anonymous -> + let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in + (* TODO: address the possibility that termin is a Prod itself *) + match_in u alp metas (bind_binder sigma x decls) b termin + (* Matching recursive notations for binders: general case *) + | r, NBinderList (x,_,iter,termin) -> + match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin + + (* Matching individual binders as part of a recursive pattern *) + | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) when Id.List.mem id blmetas -> + match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + | GProd (_,na,bk,t,b1), NProd (Name id,_,b2) + when Id.List.mem id blmetas && na != Anonymous -> + match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + + (* Matching compositionally *) + | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma + | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma + | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma + | GApp (loc,f1,l1), NApp (f2,l2) -> + let n1 = List.length l1 and n2 = List.length l2 in + let f1,l1,f2,l2 = + if n1 < n2 then + let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22 + else if n1 > n2 then + let l11,l12 = List.chop (n1-n2) l1 in GApp (loc,f1,l11),l12, f2,l2 + else f1,l1, f2, l2 in + let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in + List.fold_left2 (match_ may_use_eta u alp metas) + (match_in u alp metas sigma f1 f2) l1 l2 + | GLambda (_,na1,_,t1,b1), NLambda (na2,t2,b2) -> + match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 + | GProd (_,na1,_,t1,b1), NProd (na2,t2,b2) -> + match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 + | GLetIn (_,na1,t1,b1), NLetIn (na2,t2,b2) -> + match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 + | GCases (_,sty1,rtno1,tml1,eqnl1), NCases (sty2,rtno2,tml2,eqnl2) + when sty1 == sty2 + && Int.equal (List.length tml1) (List.length tml2) + && Int.equal (List.length eqnl1) (List.length eqnl2) -> + let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in + let rtno2' = abstract_return_type_context_notation_constr tml2 rtno2 in + let sigma = + try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2' + with Option.Heterogeneous -> raise No_match + in + let sigma = List.fold_left2 + (fun s (tm1,_) (tm2,_) -> + match_in u alp metas s tm1 tm2) sigma tml1 tml2 in + List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2 + | GLetTuple (_,nal1,(na1,to1),b1,c1), NLetTuple (nal2,(na2,to2),b2,c2) + when Int.equal (List.length nal1) (List.length nal2) -> + let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in + let sigma = match_in u alp metas sigma b1 b2 in + let (alp,sigma) = + List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in + match_in u alp metas sigma c1 c2 + | GIf (_,a1,(na1,to1),b1,c1), NIf (a2,(na2,to2),b2,c2) -> + let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in + List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2] + | GRec (_,fk1,idl1,dll1,tl1,bl1), NRec (fk2,idl2,dll2,tl2,bl2) + when match_fix_kind fk1 fk2 && Int.equal (Array.length idl1) (Array.length idl2) && + Array.for_all2 (fun l1 l2 -> Int.equal (List.length l1) (List.length l2)) dll1 dll2 + -> + let alp,sigma = Array.fold_left2 + (List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) -> + let sigma = + match_in u alp metas + (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2 + in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in + let sigma = Array.fold_left2 (match_in u alp metas) sigma tl1 tl2 in + let alp,sigma = Array.fold_right2 (fun id1 id2 alsig -> + match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in + Array.fold_left2 (match_in u alp metas) sigma bl1 bl2 + | GCast(_,c1,CastConv t1), NCast (c2,CastConv t2) + | GCast(_,c1,CastVM t1), NCast (c2,CastVM t2) -> + match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2 + | GCast(_,c1, CastCoerce), NCast(c2, CastCoerce) -> + match_in u alp metas sigma c1 c2 + | GSort (_,GType _), NSort (GType _) when not u -> sigma + | GSort (_,s1), NSort s2 when Miscops.glob_sort_eq s1 s2 -> sigma + | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match + | a, NHole _ -> sigma + + (* On the fly eta-expansion so as to use notations of the form + "exists x, P x" for "ex P"; ensure at least one constructor is + consumed to avoid looping; expects type not given because don't know + otherwise how to ensure it corresponds to a well-typed eta-expansion; + we make an exception for types which are metavariables: this is useful e.g. + to print "{x:_ & P x}" knowing that notation "{x & P x}" is not defined. *) + | b1, NLambda (Name id,(NHole _ | NVar _ as t2),b2) when inner -> + let id' = Namegen.next_ident_away id (free_glob_vars b1) in + let t1 = GHole(Loc.ghost,Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in + let sigma = match t2 with + | NHole _ -> sigma + | NVar id2 -> bind_env alp sigma id2 t1 + | _ -> assert false in + match_in u alp metas (bind_binder sigma id [(Name id',Explicit,None,t1)]) + (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2 + + | (GRec _ | GEvar _), _ + | _,_ -> raise No_match + +and match_in u = match_ true u + +and match_hd u = match_ false u + +and match_binders u alp metas na1 na2 sigma b1 b2 = + let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in + match_in u alp metas sigma b1 b2 + +and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = + (* patl1 and patl2 have the same length because they respectively + correspond to some tml1 and tml2 that have the same length *) + let (alp,sigma) = + List.fold_left2 (match_cases_pattern_binders metas) + (alp,sigma) patl1 patl2 in + match_in u alp metas sigma rhs1 rhs2 + +let match_notation_constr u c (metas,pat) = + let test (_, (_, x)) = match x with NtnTypeBinderList -> false | _ -> true in + let vars = List.partition test metas in + let vars = (List.map fst (fst vars), List.map fst (snd vars)) in + let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in + (* Reorder canonically the substitution *) + let find x = + try Id.List.assoc x terms + with Not_found -> + (* Happens for binders bound to Anonymous *) + (* Find a better way to propagate Anonymous... *) + GVar (Loc.ghost,x) in + List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> + match typ with + | NtnTypeConstr -> + ((find x, scl)::terms',termlists',binders') + | NtnTypeConstrList -> + (terms',(Id.List.assoc x termlists,scl)::termlists',binders') + | NtnTypeBinderList -> + (terms',termlists',(Id.List.assoc x binders,scl)::binders')) + metas ([],[],[]) + +(* Matching cases pattern *) +let add_patterns_for_params ind l = + let mib,_ = Global.lookup_inductive ind in + let nparams = mib.Declarations.mind_nparams in + Util.List.addn nparams (PatVar (Loc.ghost,Anonymous)) l + +let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v = + try + let vvar = Id.List.assoc var sigma in + if cases_pattern_eq v vvar then fullsigma else raise No_match + with Not_found -> + (* TODO: handle the case of multiple occs in different scopes *) + (var,v)::sigma,sigmalist,x + +let rec match_cases_pattern metas sigma a1 a2 = + match (a1,a2) with + | r1, NVar id2 when Id.List.mem id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) + | PatVar (_,Anonymous), NHole _ -> sigma,(0,[]) + | PatCstr (loc,(ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> + sigma,(0,add_patterns_for_params (fst r1) largs) + | PatCstr (loc,(ind,_ as r1),args1,_), NApp (NRef (ConstructRef r2),l2) + when eq_constructor r1 r2 -> + let l1 = add_patterns_for_params (fst r1) args1 in + let le2 = List.length l2 in + if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length l1 + then + raise No_match + else + let l1',more_args = Util.List.chop le2 l1 in + (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) + | r1, NList (x,_,iter,termin,lassoc) -> + (match_alist (fun (metas,_) -> match_cases_pattern_no_more_args metas) + (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc),(0,[]) + | _ -> raise No_match + +and match_cases_pattern_no_more_args metas sigma a1 a2 = + match match_cases_pattern metas sigma a1 a2 with + |out,(_,[]) -> out + |_ -> raise No_match + +let match_ind_pattern metas sigma ind pats a2 = + match a2 with + | NRef (IndRef r2) when eq_ind ind r2 -> + sigma,(0,pats) + | NApp (NRef (IndRef r2),l2) + when eq_ind ind r2 -> + let le2 = List.length l2 in + if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats + then + raise No_match + else + let l1',more_args = Util.List.chop le2 pats in + (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) + |_ -> raise No_match + +let reorder_canonically_substitution terms termlists metas = + List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> + match typ with + | NtnTypeConstr -> ((Id.List.assoc x terms, scl)::terms',termlists') + | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists') + | NtnTypeBinderList -> assert false) + metas ([],[]) + +let match_notation_constr_cases_pattern c (metas,pat) = + let vars = List.map fst metas in + let (terms,termlists,()),more_args = match_cases_pattern vars ([],[],()) c pat in + reorder_canonically_substitution terms termlists metas, more_args + +let match_notation_constr_ind_pattern ind args (metas,pat) = + let vars = List.map fst metas in + let (terms,termlists,()),more_args = match_ind_pattern vars ([],[],()) ind args pat in + reorder_canonically_substitution terms termlists metas, more_args diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli new file mode 100644 index 00000000..7283ed6f --- /dev/null +++ b/interp/notation_ops.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + glob_constr -> notation_constr + +(** Name of the special identifier used to encode recursive notations *) +val ldots_var : Id.t + +(** Equality of [glob_constr] (warning: only partially implemented) *) +(** FIXME: nothing to do here *) +val eq_glob_constr : glob_constr -> glob_constr -> bool + +(** Re-interpret a notation as a [glob_constr], taking care of binders *) + +val glob_constr_of_notation_constr_with_binders : Loc.t -> + ('a -> Name.t -> 'a * Name.t) -> + ('a -> notation_constr -> glob_constr) -> + 'a -> notation_constr -> glob_constr + +val glob_constr_of_notation_constr : Loc.t -> notation_constr -> glob_constr + +(** [match_notation_constr] matches a [glob_constr] against a notation + interpretation; raise [No_match] if the matching fails *) + +exception No_match + +val match_notation_constr : bool -> glob_constr -> interpretation -> + (glob_constr * subscopes) list * (glob_constr list * subscopes) list * + (glob_decl list * subscopes) list + +val match_notation_constr_cases_pattern : + cases_pattern -> interpretation -> + ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * + (int * cases_pattern list) + +val match_notation_constr_ind_pattern : + inductive -> cases_pattern list -> interpretation -> + ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * + (int * cases_pattern list) + +(** Substitution of kernel names in interpretation data *) + +val subst_interpretation : + Mod_subst.substitution -> interpretation -> interpretation + +val add_patterns_for_params : inductive -> cases_pattern list -> cases_pattern list diff --git a/interp/ppextend.ml b/interp/ppextend.ml index f244c4da..cb12b98a 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -1,16 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* RefKey(canonical_gr ref), Some (List.length args) - | AList (_,_,AApp (ARef ref,args),_,_) - | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args) - | ARef ref -> RefKey(canonical_gr ref), None +let key_compare k1 k2 = match k1, k2 with +| RefKey gr1, RefKey gr2 -> RefOrdered.compare gr1 gr2 +| RefKey _, Oth -> -1 +| Oth, RefKey _ -> 1 +| Oth, Oth -> 0 + +module KeyOrd = struct type t = key let compare = key_compare end +module KeyMap = Map.Make(KeyOrd) + +module ReservedSet : +sig + type t + val empty : t + val add : (Id.t * notation_constr) -> t -> t + val find : (Id.t -> notation_constr -> bool) -> t -> Id.t * notation_constr +end = +struct + type t = (Id.t * notation_constr) list + + let empty = [] + + let rec mem id c = function + | [] -> false + | (id', c') :: l -> + if c == c' && Id.equal id id' then true else mem id c l + + let add p l = + let (id, c) = p in + if mem id c l then l else p :: l + + let rec find f = function + | [] -> raise Not_found + | (id, c) as p :: l -> if f id c then p else find f l +end + + +let keymap_add key data map = + let old = try KeyMap.find key map with Not_found -> ReservedSet.empty in + KeyMap.add key (ReservedSet.add data old) map + +let reserve_table = Summary.ref Id.Map.empty ~name:"reserved-type" +let reserve_revtable = Summary.ref KeyMap.empty ~name:"reserved-type-rev" + +let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) + | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) + | NList (_,_,NApp (NRef ref,args),_,_) + | NBinderList (_,_,NApp (NRef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args) + | NRef ref -> RefKey(canonical_gr ref), None | _ -> Oth, None let cache_reserved_type (_,(id,t)) = - let key = fst (aconstr_key t) in - reserve_table := Idmap.add id t !reserve_table; - reserve_revtable := Gmapl.add key (t,id) !reserve_revtable + let key = fst (notation_constr_key t) in + reserve_table := Id.Map.add id t !reserve_table; + reserve_revtable := keymap_add key (id, t) !reserve_revtable -let in_reserved : identifier * aconstr -> obj = +let in_reserved : Id.t * notation_constr -> obj = declare_object {(default_object "RESERVED-TYPE") with cache_function = cache_reserved_type } -let freeze_reserved () = (!reserve_table,!reserve_revtable) -let unfreeze_reserved (r,rr) = reserve_table := r; reserve_revtable := rr -let init_reserved () = - reserve_table := Idmap.empty; reserve_revtable := Gmapl.empty - -let _ = - Summary.declare_summary "reserved-type" - { Summary.freeze_function = freeze_reserved; - Summary.unfreeze_function = unfreeze_reserved; - Summary.init_function = init_reserved } - let declare_reserved_type_binding (loc,id) t = - if id <> root_of_id id then + if not (Id.equal id (root_of_id id)) then user_err_loc(loc,"declare_reserved_type", (pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try - let _ = Idmap.find id !reserve_table in + let _ = Id.Map.find id !reserve_table in user_err_loc(loc,"declare_reserved_type", (pr_id id++str" is already bound to a type")) with Not_found -> () end; @@ -67,7 +99,7 @@ let declare_reserved_type_binding (loc,id) t = let declare_reserved_type idl t = List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl) -let find_reserved_type id = Idmap.find (root_of_id id) !reserve_table +let find_reserved_type id = Id.Map.find (root_of_id id) !reserve_table let constr_key c = try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c)))) @@ -75,25 +107,18 @@ let constr_key c = let revert_reserved_type t = try - let l = Gmapl.find (constr_key t) !reserve_revtable in - let t = Detyping.detype false [] [] t in - list_try_find - (fun (pat,id) -> - try let _ = match_aconstr false t ([],pat) in Name id - with No_match -> failwith "") l + let reserved = KeyMap.find (constr_key t) !reserve_revtable in + let t = Detyping.detype false [] (Global.env()) Evd.empty t in + (* pedrot: if [Notation_ops.match_notation_constr] may raise [Failure _] + then I've introduced a bug... *) + let filter _ pat = + try + let _ = match_notation_constr false t ([], pat) in + true + with No_match -> false + in + let (id, _) = ReservedSet.find filter reserved in + Name id with Not_found | Failure _ -> Anonymous let _ = Namegen.set_reserved_typed_name revert_reserved_type - -open Glob_term - -let anonymize_if_reserved na t = match na with - | Name id as na -> - (try - if not !Flags.raw_print & - (try aconstr_of_glob_constr [] [] t = find_reserved_type id - with UserError _ -> false) - then GHole (dummy_loc,Evd.BinderType na) - else t - with Not_found -> t) - | Anonymous -> t diff --git a/interp/reserve.mli b/interp/reserve.mli index 4d7685e3..6cae2b02 100644 --- a/interp/reserve.mli +++ b/interp/reserve.mli @@ -1,16 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* aconstr -> unit -val find_reserved_type : identifier -> aconstr -val anonymize_if_reserved : name -> glob_constr -> glob_constr +val declare_reserved_type : Id.t located list -> notation_constr -> unit +val find_reserved_type : Id.t -> notation_constr diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 5779231d..ce3c9b8f 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ref + | SynDef kn -> + let _, syn_def = search_syntactic_definition kn in + let rec head_of = function + | NRef ref -> ref + | NApp (rc, _) -> head_of rc + | NCast (rc, _) -> head_of rc + | NLetIn (_, _, rc) -> head_of rc + | _ -> raise Not_found in + head_of syn_def let global_of_extended_global = function | TrueGlobal ref -> ref | SynDef kn -> match search_syntactic_definition kn with - | [],ARef ref -> ref + | [],NRef ref -> ref + | [],NApp (NRef ref,[]) -> ref | _ -> raise Not_found -let locate_global_with_alias (loc,qid) = +let locate_global_with_alias ?(head=false) (loc,qid) = let ref = Nametab.locate_extended qid in - try global_of_extended_global ref + try + if head then global_of_extended_global_head ref + else global_of_extended_global ref with Not_found -> user_err_loc (loc,"",pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") @@ -43,14 +58,14 @@ let global_inductive_with_alias r = pr_reference r ++ spc () ++ str "is not an inductive type.") with Not_found -> Nametab.error_global_not_found_loc loc qid -let global_with_alias r = +let global_with_alias ?head r = let (loc,qid as lqid) = qualid_of_reference r in - try locate_global_with_alias lqid + try locate_global_with_alias ?head lqid with Not_found -> Nametab.error_global_not_found_loc loc qid -let smart_global = function +let smart_global ?head = function | AN r -> - global_with_alias r + global_with_alias ?head r | ByNotation (loc,ntn,sc) -> Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc @@ -60,3 +75,7 @@ let smart_global_inductive = function | ByNotation (loc,ntn,sc) -> destIndRef (Notation.interp_notation_as_global_reference loc isIndRef ntn sc) + +let loc_of_smart_reference = function + | AN r -> loc_of_reference r + | ByNotation (loc,_,_) -> loc diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 589505c3..68ef6594 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -1,35 +1,41 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* global_reference +val locate_global_with_alias : ?head:bool -> qualid located -> global_reference (** Extract a global_reference from a reference that can be an "alias" *) val global_of_extended_global : extended_global_reference -> global_reference -(** Locate a reference taking into account possible "alias" notations *) -val global_with_alias : reference -> global_reference +(** Locate a reference taking into account possible "alias" notations. + May raise [Nametab.GlobalizationError _] for an unknown reference, + or a [UserError] if bound to a syntactic def that does not denote + a reference. *) +val global_with_alias : ?head:bool -> reference -> global_reference (** The same for inductive types *) val global_inductive_with_alias : reference -> inductive (** Locate a reference taking into account notations and "aliases" *) -val smart_global : reference or_by_notation -> global_reference +val smart_global : ?head:bool -> reference or_by_notation -> global_reference (** The same for inductive types *) val smart_global_inductive : reference or_by_notation -> inductive +(** Return the loc of a smart reference *) +val loc_of_smart_reference : reference or_by_notation -> Loc.t diff --git a/interp/stdarg.ml b/interp/stdarg.ml new file mode 100644 index 00000000..e155a521 --- /dev/null +++ b/interp/stdarg.ml @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !syntax_table); - Summary.unfreeze_function = (fun ft -> syntax_table := ft); - Summary.init_function = (fun () -> syntax_table := KNmap.empty) } +let syntax_table = + Summary.ref (KNmap.empty : (interpretation*version) KNmap.t) + ~name:"SYNTAXCONSTANT" let add_syntax_constant kn c onlyparse = syntax_table := KNmap.add kn (c,onlyparse) !syntax_table @@ -39,19 +36,21 @@ let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function - | _,ARef ref -> - let (dir,id) = repr_qualid (shortest_qualid_of_global Idset.empty ref) in - dir = empty_dirpath && id = basename sp + | _,NRef ref -> + let (dir,id) = repr_qualid (shortest_qualid_of_global Id.Set.empty ref) in + DirPath.is_empty dir && Id.equal id (basename sp) | _ -> false let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = if not (is_alias_of_already_visible_name sp pat) then begin Nametab.push_syndef (Nametab.Exactly i) sp kn; - if onlyparse = None then + match onlyparse with + | None -> (* Redeclare it to be used as (short) name in case an other (distfix) notation was declared inbetween *) Notation.declare_uninterpretation (Notation.SynDefRule kn) pat + | _ -> () end let cache_syntax_constant d = @@ -59,7 +58,7 @@ let cache_syntax_constant d = open_syntax_constant 1 d let subst_syntax_constant (subst,(local,pat,onlyparse)) = - (local,subst_interpretation subst pat,onlyparse) + (local,Notation_ops.subst_interpretation subst pat,onlyparse) let classify_syntax_constant (local,_,_ as o) = if local then Dispose else Substitute o @@ -73,7 +72,7 @@ let in_syntax_constant subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } -type syndef_interpretation = (identifier * subscopes) list * aconstr +type syndef_interpretation = (Id.t * subscopes) list * notation_constr (* Coercions to the general format of notation that also supports variables bound to list of expressions *) @@ -83,8 +82,7 @@ let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac) let declare_syntactic_definition local id onlyparse pat = let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () -let pr_global r = pr_global_env Idset.empty r -let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Idset.empty kn) +let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Id.Set.empty kn) let allow_compat_notations = ref true let verbose_compat_notations = ref false @@ -98,7 +96,7 @@ let verbose_compat kn def = function if !verbose_compat_notations then msg_warning else errorlabstrm "" in let pp_def = match def with - | [], ARef r -> str " is " ++ pr_global_env Idset.empty r + | [], NRef r -> str " is " ++ pr_global_env Id.Set.empty r | _ -> str " is a compatibility notation" in let since = str (" since Coq > " ^ Flags.pr_version v ^ ".") in diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 338538a9..e5a3f4ce 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -1,23 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* identifier -> +val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : kernel_name -> syndef_interpretation diff --git a/interp/topconstr.ml b/interp/topconstr.ml index ff49fb73..1231f115 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* error "This expression should be a simple identifier." - | Name id -> id - -let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na - -let rec cases_pattern_fold_map loc g e = function - | PatVar (_,na) -> - let e',na' = g e na in e', PatVar (loc,na') - | PatCstr (_,cstr,patl,na) -> - let e',na' = g e na in - let e',patl' = list_fold_map (cases_pattern_fold_map loc g) e patl in - e', PatCstr (loc,cstr,patl',na') - -let rec subst_glob_vars l = function - | GVar (_,id) as r -> (try List.assoc id l with Not_found -> r) - | GProd (loc,Name id,bk,t,c) -> - let id = - try match List.assoc id l with GVar(_,id') -> id' | _ -> id - with Not_found -> id in - GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) - | GLambda (loc,Name id,bk,t,c) -> - let id = - try match List.assoc id l with GVar(_,id') -> id' | _ -> id - with Not_found -> id in - GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) - | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *) - -let ldots_var = id_of_string ".." - -let glob_constr_of_aconstr_with_binders loc g f e = function - | AVar id -> GVar (loc,id) - | AApp (a,args) -> GApp (loc,f e a, List.map (f e) args) - | AList (x,y,iter,tail,swap) -> - let t = f e tail in let it = f e iter in - let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in - let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in - let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in - subst_glob_vars outerl it - | ABinderList (x,y,iter,tail) -> - let t = f e tail in let it = f e iter in - let innerl = [(ldots_var,t);(x,GVar(loc,y))] in - let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in - let outerl = [(ldots_var,inner)] in - subst_glob_vars outerl it - | ALambda (na,ty,c) -> - let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c) - | AProd (na,ty,c) -> - let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c) - | ALetIn (na,b,c) -> - let e',na = g e na in GLetIn (loc,na,f e b,f e' c) - | ACases (sty,rtntypopt,tml,eqnl) -> - let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> - let e',t' = match t with - | None -> e',None - | Some (ind,npar,nal) -> - let e',nal' = List.fold_right (fun na (e',nal) -> - let e',na' = g e' na in e',na'::nal) nal (e',[]) in - e',Some (loc,ind,npar,nal') in - let e',na' = g e' na in - (e',(f e tm,(na',t'))::tml')) tml (e,[]) in - let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in - let eqnl' = List.map (fun (patl,rhs) -> - let ((idl,e),patl) = - list_fold_map (cases_pattern_fold_map loc fold) ([],e) patl in - (loc,idl,patl,f e rhs)) eqnl in - GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl') - | ALetTuple (nal,(na,po),b,c) -> - let e',nal = list_fold_map g e nal in - let e'',na = g e na in - GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c) - | AIf (c,(na,po),b1,b2) -> - let e',na = g e na in - GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2) - | ARec (fk,idl,dll,tl,bl) -> - let e,dll = array_fold_map (list_fold_map (fun e (na,oc,b) -> - let e,na = g e na in - (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in - let e',idl = array_fold_map (to_id g) e idl in - GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) - | ACast (c,k) -> GCast (loc,f e c, - match k with - | CastConv (k,t) -> CastConv (k,f e t) - | CastCoerce -> CastCoerce) - | ASort x -> GSort (loc,x) - | AHole x -> GHole (loc,x) - | APatVar n -> GPatVar (loc,(false,n)) - | ARef x -> GRef (loc,x) - -let rec glob_constr_of_aconstr loc x = - let rec aux () x = - glob_constr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x - in aux () x - -(****************************************************************************) -(* Translating a glob_constr into a notation, interpreting recursive patterns *) - -let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) -let add_name r = function Anonymous -> () | Name id -> add_id r id - -let split_at_recursive_part c = - let sub = ref None in - let rec aux = function - | GApp (loc0,GVar(loc,v),c::l) when v = ldots_var -> - if !sub <> None then - (* Not narrowed enough to find only one recursive part *) - raise Not_found - else - (sub := Some c; - if l = [] then GVar (loc,ldots_var) - else GApp (loc0,GVar (loc,ldots_var),l)) - | c -> map_glob_constr aux c in - let outer_iterator = aux c in - match !sub with - | None -> (* No recursive pattern found *) raise Not_found - | Some c -> - match outer_iterator with - | GVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found - | _ -> outer_iterator, c - -let on_true_do b f c = if b then (f c; b) else b - -let compare_glob_constr f add t1 t2 = match t1,t2 with - | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2 - | GVar (_,v1), GVar (_,v2) -> on_true_do (v1 = v2) add (Name v1) - | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2 - | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1 - | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> - on_true_do (f ty1 ty2 & f c1 c2) add na1 - | GHole _, GHole _ -> true - | GSort (_,s1), GSort (_,s2) -> s1 = s2 - | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when na1 = na2 -> - on_true_do (f b1 b2 & f c1 c2) add na1 - | (GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ - | _,(GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) - -> error "Unsupported construction in recursive notations." - | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ - | GHole _ | GSort _ | GLetIn _), _ - -> false - -let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2 - -let subtract_loc loc1 loc2 = make_loc (fst (unloc loc1),fst (unloc loc2)-1) - -let check_is_hole id = function GHole _ -> () | t -> - user_err_loc (loc_of_glob_constr t,"", - strbrk "In recursive notation with binders, " ++ pr_id id ++ - strbrk " is expected to come without type.") - -let compare_recursive_parts found f (iterator,subc) = - let diff = ref None in - let terminator = ref None in - let rec aux c1 c2 = match c1,c2 with - | GVar(_,v), term when v = ldots_var -> - (* We found the pattern *) - assert (!terminator = None); terminator := Some term; - true - | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when v = ldots_var -> - (* We found the pattern, but there are extra arguments *) - (* (this allows e.g. alternative (recursive) notation of application) *) - assert (!terminator = None); terminator := Some term; - list_for_all2eq aux l1 l2 - | GVar (_,x), GVar (_,y) when x<>y -> - (* We found the position where it differs *) - let lassoc = (!terminator <> None) in - let x,y = if lassoc then y,x else x,y in - !diff = None && (diff := Some (x,y,Some lassoc); true) - | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) - | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> - (* We found a binding position where it differs *) - check_is_hole x t_x; - check_is_hole y t_y; - !diff = None && (diff := Some (x,y,None); aux c term) - | _ -> - compare_glob_constr aux (add_name found) c1 c2 in - if aux iterator subc then - match !diff with - | None -> - let loc1 = loc_of_glob_constr iterator in - let loc2 = loc_of_glob_constr (Option.get !terminator) in - (* Here, we would need a loc made of several parts ... *) - user_err_loc (subtract_loc loc1 loc2,"", - str "Both ends of the recursive pattern are the same.") - | Some (x,y,Some lassoc) -> - let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in - let iterator = - f (if lassoc then subst_glob_vars [y,GVar(dummy_loc,x)] iterator - else iterator) in - (* found have been collected by compare_constr *) - found := newfound; - AList (x,y,iterator,f (Option.get !terminator),lassoc) - | Some (x,y,None) -> - let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in - let iterator = f iterator in - (* found have been collected by compare_constr *) - found := newfound; - ABinderList (x,y,iterator,f (Option.get !terminator)) - else - raise Not_found - -let aconstr_and_vars_of_glob_constr a = - let found = ref ([],[],[]) in - let rec aux c = - let keepfound = !found in - (* n^2 complexity but small and done only once per notation *) - try compare_recursive_parts found aux' (split_at_recursive_part c) - with Not_found -> - found := keepfound; - match c with - | GApp (_,GVar (loc,f),[c]) when f = ldots_var -> - (* Fall on the second part of the recursive pattern w/o having - found the first part *) - user_err_loc (loc,"", - str "Cannot find where the recursive pattern starts.") - | c -> - aux' c - and aux' = function - | GVar (_,id) -> add_id found id; AVar id - | GApp (_,g,args) -> AApp (aux g, List.map aux args) - | GLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c) - | GProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c) - | GLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c) - | GCases (_,sty,rtntypopt,tml,eqnl) -> - let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in - ACases (sty,Option.map aux rtntypopt, - List.map (fun (tm,(na,x)) -> - add_name found na; - Option.iter - (fun (_,_,_,nl) -> List.iter (add_name found) nl) x; - (aux tm,(na,Option.map (fun (_,ind,n,nal) -> (ind,n,nal)) x))) tml, - List.map f eqnl) - | GLetTuple (loc,nal,(na,po),b,c) -> - add_name found na; - List.iter (add_name found) nal; - ALetTuple (nal,(na,Option.map aux po),aux b,aux c) - | GIf (loc,c,(na,po),b1,b2) -> - add_name found na; - AIf (aux c,(na,Option.map aux po),aux b1,aux b2) - | GRec (_,fk,idl,dll,tl,bl) -> - Array.iter (add_id found) idl; - let dll = Array.map (List.map (fun (na,bk,oc,b) -> - if bk <> Explicit then - error "Binders marked as implicit not allowed in notations."; - add_name found na; (na,Option.map aux oc,aux b))) dll in - ARec (fk,idl,dll,Array.map aux tl,Array.map aux bl) - | GCast (_,c,k) -> ACast (aux c, - match k with CastConv (k,t) -> CastConv (k,aux t) - | CastCoerce -> CastCoerce) - | GSort (_,s) -> ASort s - | GHole (_,w) -> AHole w - | GRef (_,r) -> ARef r - | GPatVar (_,(_,n)) -> APatVar n - | GEvar _ -> - error "Existential variables not allowed in notations." - - in - let t = aux a in - (* Side effect *) - t, !found - -let rec list_rev_mem_assoc x = function - | [] -> false - | (_,x')::l -> x = x' || list_rev_mem_assoc x l - -let check_variables vars recvars (found,foundrec,foundrecbinding) = - let useless_vars = List.map snd recvars in - let vars = List.filter (fun (y,_) -> not (List.mem y useless_vars)) vars in - let check_recvar x = - if List.mem x found then - errorlabstrm "" (pr_id x ++ - strbrk " should only be used in the recursive part of a pattern.") in - List.iter (fun (x,y) -> check_recvar x; check_recvar y) - (foundrec@foundrecbinding); - let check_bound x = - if not (List.mem x found) then - if List.mem_assoc x foundrec or List.mem_assoc x foundrecbinding - or list_rev_mem_assoc x foundrec or list_rev_mem_assoc x foundrecbinding - then - error ((string_of_id x)^" should not be bound in a recursive pattern of the right-hand side.") - else - error ((string_of_id x)^" is unbound in the right-hand side.") in - let check_pair s x y where = - if not (List.mem (x,y) where) then - errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ - str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ - str " position as part of a recursive pattern.") in - let check_type (x,typ) = - match typ with - | NtnInternTypeConstr -> - begin - try check_pair "term" x (List.assoc x recvars) foundrec - with Not_found -> check_bound x - end - | NtnInternTypeBinder -> - begin - try check_pair "binding" x (List.assoc x recvars) foundrecbinding - with Not_found -> check_bound x - end - | NtnInternTypeIdent -> check_bound x in - List.iter check_type vars - -let aconstr_of_glob_constr vars recvars a = - let a,found = aconstr_and_vars_of_glob_constr a in - check_variables vars recvars found; - a - -(* Substitution of kernel names, avoiding a list of bound identifiers *) - -let aconstr_of_constr avoiding t = - aconstr_of_glob_constr [] [] (Detyping.detype false avoiding [] t) - -let rec subst_pat subst pat = - match pat with - | PatVar _ -> pat - | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn - and cpl' = list_smartmap (subst_pat subst) cpl in - if kn' == kn && cpl' == cpl then pat else - PatCstr (loc,((kn',i),j),cpl',n) - -let rec subst_aconstr subst bound raw = - match raw with - | ARef ref -> - let ref',t = subst_global subst ref in - if ref' == ref then raw else - aconstr_of_constr bound t - - | AVar _ -> raw - - | AApp (r,rl) -> - let r' = subst_aconstr subst bound r - and rl' = list_smartmap (subst_aconstr subst bound) rl in - if r' == r && rl' == rl then raw else - AApp(r',rl') - - | AList (id1,id2,r1,r2,b) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - AList (id1,id2,r1',r2',b) - - | ALambda (n,r1,r2) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - ALambda (n,r1',r2') - - | AProd (n,r1,r2) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - AProd (n,r1',r2') - - | ABinderList (id1,id2,r1,r2) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - ABinderList (id1,id2,r1',r2') - - | ALetIn (n,r1,r2) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - ALetIn (n,r1',r2') - - | ACases (sty,rtntypopt,rl,branches) -> - let rtntypopt' = Option.smartmap (subst_aconstr subst bound) rtntypopt - and rl' = list_smartmap - (fun (a,(n,signopt) as x) -> - let a' = subst_aconstr subst bound a in - let signopt' = Option.map (fun ((indkn,i),n,nal as z) -> - let indkn' = subst_ind subst indkn in - if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in - if a' == a && signopt' == signopt then x else (a',(n,signopt'))) - rl - and branches' = list_smartmap - (fun (cpl,r as branch) -> - let cpl' = list_smartmap (subst_pat subst) cpl - and r' = subst_aconstr subst bound r in - if cpl' == cpl && r' == r then branch else - (cpl',r')) - branches - in - if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' & - rl' == rl && branches' == branches then raw else - ACases (sty,rtntypopt',rl',branches') - - | ALetTuple (nal,(na,po),b,c) -> - let po' = Option.smartmap (subst_aconstr subst bound) po - and b' = subst_aconstr subst bound b - and c' = subst_aconstr subst bound c in - if po' == po && b' == b && c' == c then raw else - ALetTuple (nal,(na,po'),b',c') - - | AIf (c,(na,po),b1,b2) -> - let po' = Option.smartmap (subst_aconstr subst bound) po - and b1' = subst_aconstr subst bound b1 - and b2' = subst_aconstr subst bound b2 - and c' = subst_aconstr subst bound c in - if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else - AIf (c',(na,po'),b1',b2') - - | ARec (fk,idl,dll,tl,bl) -> - let dll' = - array_smartmap (list_smartmap (fun (na,oc,b as x) -> - let oc' = Option.smartmap (subst_aconstr subst bound) oc in - let b' = subst_aconstr subst bound b in - if oc' == oc && b' == b then x else (na,oc',b'))) dll in - let tl' = array_smartmap (subst_aconstr subst bound) tl in - let bl' = array_smartmap (subst_aconstr subst bound) bl in - if dll' == dll && tl' == tl && bl' == bl then raw else - ARec (fk,idl,dll',tl',bl') - - | APatVar _ | ASort _ -> raw - - | AHole (Evd.ImplicitArg (ref,i,b)) -> - let ref',t = subst_global subst ref in - if ref' == ref then raw else - AHole (Evd.InternalHole) - | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType - | Evd.InternalHole | Evd.TomatchTypeParameter _ | Evd.GoalEvar - | Evd.ImpossibleCase | Evd.MatchingVar _) -> raw - - | ACast (r1,k) -> - match k with - CastConv (k, r2) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - ACast (r1',CastConv (k,r2')) - | CastCoerce -> - let r1' = subst_aconstr subst bound r1 in - if r1' == r1 then raw else - ACast (r1',CastCoerce) - -let subst_interpretation subst (metas,pat) = - let bound = List.map fst metas in - (metas,subst_aconstr subst bound pat) - -(* Pattern-matching glob_constr and aconstr *) - -let abstract_return_type_context pi mklam tml rtno = - Option.map (fun rtn -> - let nal = - List.flatten (List.map (fun (_,(na,t)) -> - match t with Some x -> (pi x)@[na] | None -> [na]) tml) in - List.fold_right mklam nal rtn) - rtno - -let abstract_return_type_context_glob_constr = - abstract_return_type_context (fun (_,_,_,nal) -> nal) - (fun na c -> GLambda(dummy_loc,na,Explicit,GHole(dummy_loc,Evd.InternalHole),c)) - -let abstract_return_type_context_aconstr = - abstract_return_type_context pi3 - (fun na c -> ALambda(na,AHole Evd.InternalHole,c)) - -exception No_match - -let rec alpha_var id1 id2 = function - | (i1,i2)::_ when i1=id1 -> i2 = id2 - | (i1,i2)::_ when i2=id2 -> i1 = id1 - | _::idl -> alpha_var id1 id2 idl - | [] -> id1 = id2 - -let alpha_eq_val (x,y) = x = y - -let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = - try - let vvar = List.assoc var sigma in - if alpha_eq_val (v,vvar) then fullsigma - else raise No_match - with Not_found -> - (* Check that no capture of binding variables occur *) - if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match; - (* TODO: handle the case of multiple occs in different scopes *) - ((var,v)::sigma,sigmalist,sigmabinders) - -let bind_binder (sigma,sigmalist,sigmabinders) x bl = - (sigma,sigmalist,(x,List.rev bl)::sigmabinders) - -let match_fix_kind fk1 fk2 = - match (fk1,fk2) with - | GCoFix n1, GCoFix n2 -> n1 = n2 - | GFix (nl1,n1), GFix (nl2,n2) -> - n1 = n2 && - array_for_all2 (fun (n1,_) (n2,_) -> n2 = None || n1 = n2) nl1 nl2 - | _ -> false - -let match_opt f sigma t1 t2 = match (t1,t2) with - | None, None -> sigma - | Some t1, Some t2 -> f sigma t1 t2 - | _ -> raise No_match - -let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with - | (_,Name id2) when List.mem id2 (fst metas) -> - let rhs = match na1 with - | Name id1 -> GVar (dummy_loc,id1) - | Anonymous -> GHole (dummy_loc,Evd.InternalHole) in - alp, bind_env alp sigma id2 rhs - | (Name id1,Name id2) -> (id1,id2)::alp,sigma - | (Anonymous,Anonymous) -> alp,sigma - | _ -> raise No_match -let rec match_cases_pattern_binders metas acc pat1 pat2 = - match (pat1,pat2) with - | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2 - | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2) - when c1 = c2 & List.length patl1 = List.length patl2 -> - List.fold_left2 (match_cases_pattern_binders metas) - (match_names metas acc na1 na2) patl1 patl2 - | _ -> raise No_match - -let glue_letin_with_decls = true - -let rec match_iterated_binders islambda decls = function - | GLambda (_,na,bk,t,b) when islambda -> - match_iterated_binders islambda ((na,bk,None,t)::decls) b - | GProd (_,(Name _ as na),bk,t,b) when not islambda -> - match_iterated_binders islambda ((na,bk,None,t)::decls) b - | GLetIn (loc,na,c,b) when glue_letin_with_decls -> - match_iterated_binders islambda - ((na,Explicit (*?*), Some c,GHole(loc,Evd.BinderType na))::decls) b - | b -> (decls,b) - -let remove_sigma x (sigmavar,sigmalist,sigmabinders) = - (List.remove_assoc x sigmavar,sigmalist,sigmabinders) - -let rec match_abinderlist_with_app match_fun metas sigma rest x iter termin = - let rec aux sigma acc rest = - try - let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in - let rest = List.assoc ldots_var (pi1 sigma) in - let b = match List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false in - let sigma = remove_sigma x (remove_sigma ldots_var sigma) in - aux sigma (b::acc) rest - with No_match when acc <> [] -> - acc, match_fun metas sigma rest termin in - let bl,sigma = aux sigma [] rest in - bind_binder sigma x bl - -let match_alist match_fun metas sigma rest x iter termin lassoc = - let rec aux sigma acc rest = - try - let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in - let rest = List.assoc ldots_var (pi1 sigma) in - let t = List.assoc x (pi1 sigma) in - let sigma = remove_sigma x (remove_sigma ldots_var sigma) in - aux sigma (t::acc) rest - with No_match when acc <> [] -> - acc, match_fun metas sigma rest termin in - let l,sigma = aux sigma [] rest in - (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma) - -let does_not_come_from_already_eta_expanded_var = - (* This is hack to avoid looping on a rule with rhs of the form *) - (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *) - (* "F (fun x => H x)" and "H x" is recursively matched against the same *) - (* rule, giving "H (fun x' => x x')" and so on. *) - (* Ideally, we would need the type of the expression to know which of *) - (* the arguments applied to it can be eta-expanded without looping. *) - (* The following test is then an approximation of what can be done *) - (* optimally (whether other looping situations can occur remains to be *) - (* checked). *) - function GVar _ -> false | _ -> true - -let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = - match (a1,a2) with - - (* Matching notation variable *) - | r1, AVar id2 when List.mem id2 tmetas -> bind_env alp sigma id2 r1 - - (* Matching recursive notations for terms *) - | r1, AList (x,_,iter,termin,lassoc) -> - match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc - - (* Matching recursive notations for binders: ad hoc cases supporting let-in *) - | GLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)-> - let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in - (* TODO: address the possibility that termin is a Lambda itself *) - match_in u alp metas (bind_binder sigma x decls) b termin - | GProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin) - when na1 <> Anonymous -> - let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in - (* TODO: address the possibility that termin is a Prod itself *) - match_in u alp metas (bind_binder sigma x decls) b termin - (* Matching recursive notations for binders: general case *) - | r, ABinderList (x,_,iter,termin) -> - match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin - - (* Matching individual binders as part of a recursive pattern *) - | GLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas -> - match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 - | GProd (_,na,bk,t,b1), AProd (Name id,_,b2) - when List.mem id blmetas & na <> Anonymous -> - match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 - - (* Matching compositionally *) - | GVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma - | GRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma - | GPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma - | GApp (loc,f1,l1), AApp (f2,l2) -> - let n1 = List.length l1 and n2 = List.length l2 in - let f1,l1,f2,l2 = - if n1 < n2 then - let l21,l22 = list_chop (n2-n1) l2 in f1,l1, AApp (f2,l21), l22 - else if n1 > n2 then - let l11,l12 = list_chop (n1-n2) l1 in GApp (loc,f1,l11),l12, f2,l2 - else f1,l1, f2, l2 in - let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in - List.fold_left2 (match_ may_use_eta u alp metas) - (match_in u alp metas sigma f1 f2) l1 l2 - | GLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 - | GProd (_,na1,_,t1,b1), AProd (na2,t2,b2) -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 - | GLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 - | GCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2) - when sty1 = sty2 - & List.length tml1 = List.length tml2 - & List.length eqnl1 = List.length eqnl2 -> - let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in - let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in - let sigma = - try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2' - with Option.Heterogeneous -> raise No_match - in - let sigma = List.fold_left2 - (fun s (tm1,_) (tm2,_) -> - match_in u alp metas s tm1 tm2) sigma tml1 tml2 in - List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2 - | GLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) - when List.length nal1 = List.length nal2 -> - let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in - let sigma = match_in u alp metas sigma b1 b2 in - let (alp,sigma) = - List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in - match_in u alp metas sigma c1 c2 - | GIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) -> - let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in - List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2] - | GRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2) - when match_fix_kind fk1 fk2 & Array.length idl1 = Array.length idl2 & - array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) dll1 dll2 - -> - let alp,sigma = array_fold_left2 - (List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) -> - let sigma = - match_in u alp metas - (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2 - in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in - let sigma = array_fold_left2 (match_in u alp metas) sigma tl1 tl2 in - let alp,sigma = array_fold_right2 (fun id1 id2 alsig -> - match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in - array_fold_left2 (match_in u alp metas) sigma bl1 bl2 - | GCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) -> - match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2 - | GCast(_,c1, CastCoerce), ACast(c2, CastCoerce) -> - match_in u alp metas sigma c1 c2 - | GSort (_,GType _), ASort (GType None) when not u -> sigma - | GSort (_,s1), ASort s2 when s1 = s2 -> sigma - | GPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match - | a, AHole _ -> sigma - - (* On the fly eta-expansion so as to use notations of the form - "exists x, P x" for "ex P"; expects type not given because don't know - otherwise how to ensure it corresponds to a well-typed eta-expansion; - ensure at least one constructor is consumed to avoid looping *) - | b1, ALambda (Name id,AHole _,b2) when inner -> - let id' = Namegen.next_ident_away id (free_glob_vars b1) in - match_in u alp metas (bind_binder sigma id - [(Name id',Explicit,None,GHole(dummy_loc,Evd.BinderType (Name id')))]) - (mkGApp dummy_loc b1 (GVar (dummy_loc,id'))) b2 - - | (GRec _ | GEvar _), _ - | _,_ -> raise No_match - -and match_in u = match_ true u - -and match_hd u = match_ false u - -and match_binders u alp metas na1 na2 sigma b1 b2 = - let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in - match_in u alp metas sigma b1 b2 - -and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = - (* patl1 and patl2 have the same length because they respectively - correspond to some tml1 and tml2 that have the same length *) - let (alp,sigma) = - List.fold_left2 (match_cases_pattern_binders metas) - (alp,sigma) patl1 patl2 in - match_in u alp metas sigma rhs1 rhs2 - -let match_aconstr u c (metas,pat) = - let vars = list_split_by (fun (_,(_,x)) -> x <> NtnTypeBinderList) metas in - let vars = (List.map fst (fst vars), List.map fst (snd vars)) in - let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in - (* Reorder canonically the substitution *) - let find x = - try List.assoc x terms - with Not_found -> - (* Happens for binders bound to Anonymous *) - (* Find a better way to propagate Anonymous... *) - GVar (dummy_loc,x) in - List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> - match typ with - | NtnTypeConstr -> - ((find x, scl)::terms',termlists',binders') - | NtnTypeConstrList -> - (terms',(List.assoc x termlists,scl)::termlists',binders') - | NtnTypeBinderList -> - (terms',termlists',(List.assoc x binders,scl)::binders')) - metas ([],[],[]) - -(* Matching cases pattern *) - -let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v = - try - let vvar = List.assoc var sigma in - if v=vvar then fullsigma else raise No_match - with Not_found -> - (* TODO: handle the case of multiple occs in different scopes *) - (var,v)::sigma,sigmalist,x - -let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with - | r1, AVar id2 when List.mem id2 metas -> bind_env_cases_pattern sigma id2 r1 - | PatVar (_,Anonymous), AHole _ -> sigma - | PatCstr (loc,(ind,_ as r1),[],_), ARef (ConstructRef r2) when r1 = r2 -> - sigma - | PatCstr (loc,(ind,_ as r1),args1,_), AApp (ARef (ConstructRef r2),l2) - when r1 = r2 -> - let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in - if List.length l2 <> nparams + List.length args1 - then - (* TODO: revert partially applied notations of the form - "Notation P := (@pair)." *) - raise No_match - else - let (p2,args2) = list_chop nparams l2 in - (* All parameters must be _ *) - List.iter (function AHole _ -> () | _ -> raise No_match) p2; - List.fold_left2 (match_cases_pattern metas) sigma args1 args2 - | r1, AList (x,_,iter,termin,lassoc) -> - match_alist (fun (metas,_) -> match_cases_pattern metas) - (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc - | _ -> raise No_match - -let match_aconstr_cases_pattern c (metas,pat) = - let vars = List.map fst metas in - let terms,termlists,() = match_cases_pattern vars ([],[],()) c pat in - (* Reorder canonically the substitution *) - List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> - match typ with - | NtnTypeConstr -> ((List.assoc x terms, scl)::terms',termlists') - | NtnTypeConstrList -> (terms',(List.assoc x termlists,scl)::termlists') - | NtnTypeBinderList -> assert false) - metas ([],[]) - -(**********************************************************************) -(*s Concrete syntax for terms *) - -type notation = string - -type explicitation = ExplByPos of int * identifier option | ExplByName of identifier - -type binder_kind = Default of binding_kind | Generalized of binding_kind * binding_kind * bool - -type abstraction_kind = AbsLambda | AbsPi - -type proj_flag = int option (* [Some n] = proj of the n-th visible argument *) - -type prim_token = Numeral of Bigint.bigint | String of string - -type cases_pattern_expr = - | CPatAlias of loc * cases_pattern_expr * identifier - | CPatCstr of loc * reference * cases_pattern_expr list - | CPatCstrExpl of loc * reference * cases_pattern_expr list - | CPatAtom of loc * reference option - | CPatOr of loc * cases_pattern_expr list - | CPatNotation of loc * notation * cases_pattern_notation_substitution - | CPatPrim of loc * prim_token - | CPatRecord of Util.loc * (reference * cases_pattern_expr) list - | CPatDelimiters of loc * string * cases_pattern_expr - -and cases_pattern_notation_substitution = - cases_pattern_expr list * (** for constr subterms *) - cases_pattern_expr list list (** for recursive notations *) - -type constr_expr = - | CRef of reference - | CFix of loc * identifier located * fix_expr list - | CCoFix of loc * identifier located * cofix_expr list - | CArrow of loc * constr_expr * constr_expr - | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr - | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr - | CLetIn of loc * name located * constr_expr * constr_expr - | CAppExpl of loc * (proj_flag * reference) * constr_expr list - | CApp of loc * (proj_flag * constr_expr) * - (constr_expr * explicitation located option) list - | CRecord of loc * constr_expr option * (reference * constr_expr) list - | CCases of loc * case_style * constr_expr option * - (constr_expr * (name located option * constr_expr option)) list * - (loc * cases_pattern_expr list located list * constr_expr) list - | CLetTuple of loc * name located list * (name located option * constr_expr option) * - constr_expr * constr_expr - | CIf of loc * constr_expr * (name located option * constr_expr option) - * constr_expr * constr_expr - | CHole of loc * Evd.hole_kind option - | CPatVar of loc * (bool * patvar) - | CEvar of loc * existential_key * constr_expr list option - | CSort of loc * glob_sort - | CCast of loc * constr_expr * constr_expr cast_type - | CNotation of loc * notation * constr_notation_substitution - | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr - | CPrim of loc * prim_token - | CDelimiters of loc * string * constr_expr - -and fix_expr = - identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr - -and cofix_expr = - identifier located * local_binder list * constr_expr * constr_expr - -and recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option (* measure, relation *) - -and local_binder = - | LocalRawDef of name located * constr_expr - | LocalRawAssum of name located list * binder_kind * constr_expr - -and constr_notation_substitution = - constr_expr list * (* for constr subterms *) - constr_expr list list * (* for recursive notations *) - local_binder list list (* for binders subexpressions *) - -type typeclass_constraint = name located * binding_kind * constr_expr - -and typeclass_context = typeclass_constraint list - -type constr_pattern_expr = constr_expr - -(***********************) -(* For binders parsing *) - -let default_binder_kind = Default Explicit - -let names_of_local_assums bl = - List.flatten (List.map (function LocalRawAssum(l,_,_)->l|_->[]) bl) - -let names_of_local_binders bl = - List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]) bl) +let oldfashion_patterns = ref (false) +let _ = Goptions.declare_bool_option { + Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optname = + "Constructors in patterns require all their arguments but no parameters instead of explicit parameters and arguments"; + Goptions.optkey = ["Asymmetric";"Patterns"]; + Goptions.optread = (fun () -> !oldfashion_patterns); + Goptions.optwrite = (fun a -> oldfashion_patterns:=a); +} (**********************************************************************) (* Miscellaneous *) @@ -933,68 +38,22 @@ let error_invalid_pattern_notation loc = (**********************************************************************) (* Functions on constr_expr *) -let constr_loc = function - | CRef (Ident (loc,_)) -> loc - | CRef (Qualid (loc,_)) -> loc - | CFix (loc,_,_) -> loc - | CCoFix (loc,_,_) -> loc - | CArrow (loc,_,_) -> loc - | CProdN (loc,_,_) -> loc - | CLambdaN (loc,_,_) -> loc - | CLetIn (loc,_,_,_) -> loc - | CAppExpl (loc,_,_) -> loc - | CApp (loc,_,_) -> loc - | CRecord (loc,_,_) -> loc - | CCases (loc,_,_,_,_) -> loc - | CLetTuple (loc,_,_,_,_) -> loc - | CIf (loc,_,_,_,_) -> loc - | CHole (loc, _) -> loc - | CPatVar (loc,_) -> loc - | CEvar (loc,_,_) -> loc - | CSort (loc,_) -> loc - | CCast (loc,_,_) -> loc - | CNotation (loc,_,_) -> loc - | CGeneralization (loc,_,_,_) -> loc - | CPrim (loc,_) -> loc - | CDelimiters (loc,_,_) -> loc - -let cases_pattern_expr_loc = function - | CPatAlias (loc,_,_) -> loc - | CPatCstr (loc,_,_) -> loc - | CPatCstrExpl (loc,_,_) -> loc - | CPatAtom (loc,_) -> loc - | CPatOr (loc,_) -> loc - | CPatNotation (loc,_,_) -> loc - | CPatRecord (loc, _) -> loc - | CPatPrim (loc,_) -> loc - | CPatDelimiters (loc,_,_) -> loc - -let local_binder_loc = function - | LocalRawAssum ((loc,_)::_,_,t) - | LocalRawDef ((loc,_),t) -> join_loc loc (constr_loc t) - | LocalRawAssum ([],_,_) -> assert false - -let local_binders_loc bll = - if bll = [] then dummy_loc else - join_loc (local_binder_loc (List.hd bll)) (local_binder_loc (list_last bll)) - let ids_of_cases_indtype = - let add_var ids = function CRef (Ident (_,id)) -> id::ids | _ -> ids in - let rec vars_of = function + let rec vars_of ids = function (* We deal only with the regular cases *) - | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l) - | CNotation (_,_,(l,[],[])) + | (CPatCstr (_,_,l1,l2)|CPatNotation (_,_,(l1,[]),l2)) -> + List.fold_left vars_of (List.fold_left vars_of [] l2) l1 (* assume the ntn is applicative and does not instantiate the head !! *) - | CAppExpl (_,_,l) -> List.fold_left add_var [] l - | CDelimiters(_,_,c) -> vars_of c - | _ -> [] in - vars_of + | CPatDelimiters(_,_,c) -> vars_of ids c + | CPatAtom (_, Some (Libnames.Ident (_, x))) -> x::ids + | _ -> ids in + vars_of [] let ids_of_cases_tomatch tms = List.fold_right (fun (_,(ona,indnal)) l -> Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) - indnal (Option.fold_right (down_located name_cons) ona l)) + indnal (Option.fold_right (Loc.down_located name_cons) ona l)) tms [] let is_constructor id = @@ -1005,19 +64,23 @@ let rec cases_pattern_fold_names f a = function | CPatRecord (_, l) -> List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l | CPatAlias (_,pat,id) -> f id a - | CPatCstr (_,_,patl) | CPatCstrExpl (_,_,patl) | CPatOr (_,patl) -> + | CPatOr (_,patl) -> List.fold_left (cases_pattern_fold_names f) a patl - | CPatNotation (_,_,(patl,patll)) -> - List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll) + | CPatCstr (_,_,patl1,patl2) -> + List.fold_left (cases_pattern_fold_names f) + (List.fold_left (cases_pattern_fold_names f) a patl1) patl2 + | CPatNotation (_,_,(patl,patll),patl') -> + List.fold_left (cases_pattern_fold_names f) + (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' | CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat | CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a | CPatPrim _ | CPatAtom _ -> a let ids_of_pattern_list = List.fold_left - (located_fold_left - (List.fold_left (cases_pattern_fold_names Idset.add))) - Idset.empty + (Loc.located_fold_left + (List.fold_left (cases_pattern_fold_names Id.Set.add))) + Id.Set.empty let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> @@ -1038,18 +101,17 @@ let rec fold_local_binders g f n acc b = function f n acc b let fold_constr_expr_with_binders g f n acc = function - | CArrow (loc,a,b) -> f n (f n acc a) b - | CAppExpl (loc,(_,_),l) -> List.fold_left (f n) acc l + | CAppExpl (loc,(_,_,_),l) -> List.fold_left (f n) acc l | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a] - | CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b + | CCast (loc,a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b | CCast (loc,a,CastCoerce) -> f n acc a | CNotation (_,_,(l,ll,bll)) -> (* The following is an approximation: we don't know exactly if an ident is binding nor to which subterms bindings apply *) let acc = List.fold_left (f n) acc (l@List.flatten ll) in - List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (dummy_loc,None)) bl) acc bll + List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (Loc.ghost,None,IntroAnonymous,None)) bl) acc bll | CGeneralization (_,_,_,c) -> f n acc c | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> @@ -1061,93 +123,29 @@ let fold_constr_expr_with_binders g f n acc = function let acc = List.fold_left (f n) acc (List.map fst al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in - f (Idset.fold g ids n) acc rhs) bl acc + f (Id.Set.fold g ids n) acc rhs) bl acc | CLetTuple (loc,nal,(ona,po),b,c) -> - let n' = List.fold_right (down_located (name_fold g)) nal n in - f (Option.fold_right (down_located (name_fold g)) ona n') (f n acc b) c + let n' = List.fold_right (Loc.down_located (name_fold g)) nal n in + f (Option.fold_right (Loc.down_located (name_fold g)) ona n') (f n acc b) c | CIf (_,c,(ona,po),b1,b2) -> let acc = f n (f n (f n acc b1) b2) c in Option.fold_left - (f (Option.fold_right (down_located (name_fold g)) ona n)) acc po + (f (Option.fold_right (Loc.down_located (name_fold g)) ona n)) acc po | CFix (loc,_,l) -> let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in List.fold_right (fun (_,(_,o),lb,t,c) acc -> fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (loc,_,_) -> - Pp.msg_warn "Capture check in multiple binders not done"; acc + msg_warning (strbrk "Capture check in multiple binders not done"); acc let free_vars_of_constr_expr c = let rec aux bdvars l = function - | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l + | CRef (Ident (_,id),_) -> if Id.List.mem id bdvars then l else Id.Set.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c - in aux [] Idset.empty c - -let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c) - -let mkIdentC id = CRef (Ident (dummy_loc, id)) -let mkRefC r = CRef r -let mkCastC (a,k) = CCast (dummy_loc,a,k) -let mkLambdaC (idl,bk,a,b) = CLambdaN (dummy_loc,[idl,bk,a],b) -let mkLetInC (id,a,b) = CLetIn (dummy_loc,id,a,b) -let mkProdC (idl,bk,a,b) = CProdN (dummy_loc,[idl,bk,a],b) - -let mkAppC (f,l) = - let l = List.map (fun x -> (x,None)) l in - match f with - | CApp (_,g,l') -> CApp (dummy_loc, g, l' @ l) - | _ -> CApp (dummy_loc, (None, f), l) - -let rec mkCProdN loc bll c = - match bll with - | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> - CProdN (loc,[idl,bk,t],mkCProdN (join_loc loc1 loc) bll c) - | LocalRawDef ((loc1,_) as id,b) :: bll -> - CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c) - | [] -> c - | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c - -let rec mkCLambdaN loc bll c = - match bll with - | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> - CLambdaN (loc,[idl,bk,t],mkCLambdaN (join_loc loc1 loc) bll c) - | LocalRawDef ((loc1,_) as id,b) :: bll -> - CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c) - | [] -> c - | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c - -let rec abstract_constr_expr c = function - | [] -> c - | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl) - | LocalRawAssum (idl,bk,t)::bl -> - List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl - (abstract_constr_expr c bl) + in aux [] Id.Set.empty c -let rec prod_constr_expr c = function - | [] -> c - | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl) - | LocalRawAssum (idl,bk,t)::bl -> - List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl - (prod_constr_expr c bl) - -let coerce_reference_to_id = function - | Ident (_,id) -> id - | Qualid (loc,_) -> - user_err_loc (loc, "coerce_reference_to_id", - str "This expression should be a simple identifier.") - -let coerce_to_id = function - | CRef (Ident (loc,id)) -> (loc,id) - | a -> user_err_loc - (constr_loc a,"coerce_to_id", - str "This expression should be a simple identifier.") - -let coerce_to_name = function - | CRef (Ident (loc,id)) -> (loc,Name id) - | CHole (loc,_) -> (loc,Anonymous) - | a -> user_err_loc - (constr_loc a,"coerce_to_name", - str "This expression should be a name.") +let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) (* Interpret the index of a recursion order annotation *) @@ -1155,16 +153,27 @@ let split_at_annot bl na = let names = List.map snd (names_of_local_assums bl) in match na with | None -> - if names = [] then error "A fixpoint needs at least one parameter." - else [], bl + begin match names with + | [] -> error "A fixpoint needs at least one parameter." + | _ -> ([], bl) + end | Some (loc, id) -> let rec aux acc = function | LocalRawAssum (bls, k, t) as x :: rest -> - let l, r = list_split_when (fun (loc, na) -> na = Name id) bls in - if r = [] then aux (x :: acc) rest - else - (List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc), - LocalRawAssum (r, k, t) :: rest) + let test (_, na) = match na with + | Name id' -> Id.equal id id' + | Anonymous -> false + in + let l, r = List.split_when test bls in + begin match r with + | [] -> aux (x :: acc) rest + | _ -> + let ans = match l with + | [] -> acc + | _ -> LocalRawAssum (l, k, t) :: acc + in + (List.rev ans, LocalRawAssum (r, k, t) :: rest) + end | LocalRawDef _ as x :: rest -> aux (x :: acc) rest | [] -> user_err_loc(loc,"", @@ -1173,7 +182,7 @@ let split_at_annot bl na = (* Used in correctness and interface *) -let map_binder g e nal = List.fold_right (down_located (name_fold g)) nal e +let map_binder g e nal = List.fold_right (Loc.down_located (name_fold g)) nal e let map_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) @@ -1192,7 +201,6 @@ let map_local_binders f g e bl = (e, List.rev rbl) let map_constr_expr_with_binders g f e = function - | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b) | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) | CApp (loc,(p,a),l) -> CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l) @@ -1201,8 +209,7 @@ let map_constr_expr_with_binders g f e = function | CLambdaN (loc,bl,b) -> let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b) | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b) - | CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b)) - | CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce) + | CCast (loc,a,c) -> CCast (loc,f e a, Miscops.map_cast_type (f e) c) | CNotation (loc,n,(l,ll,bll)) -> (* This is an approximation because we don't know what binds what *) CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll, @@ -1219,11 +226,11 @@ let map_constr_expr_with_binders g f e = function let po = Option.map (f (List.fold_right g ids e)) rtnpo in CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> - let e' = List.fold_right (down_located (name_fold g)) nal e in - let e'' = Option.fold_right (down_located (name_fold g)) ona e in + let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in + let e'' = Option.fold_right (Loc.down_located (name_fold g)) ona e in CLetTuple (loc,nal,(ona,Option.map (f e'') po),f e b,f e' c) | CIf (loc,c,(ona,po),b1,b2) -> - let e' = Option.fold_right (down_located (name_fold g)) ona e in + let e' = Option.fold_right (Loc.down_located (name_fold g)) ona e in CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2) | CFix (loc,id,dl) -> CFix (loc,id,List.map (fun (id,n,bl,t,d) -> @@ -1243,33 +250,21 @@ let map_constr_expr_with_binders g f e = function (* Used in constrintern *) let rec replace_vars_constr_expr l = function - | CRef (Ident (loc,id)) as x -> - (try CRef (Ident (loc,List.assoc id l)) with Not_found -> x) - | c -> map_constr_expr_with_binders List.remove_assoc + | CRef (Ident (loc,id),us) as x -> + (try CRef (Ident (loc,Id.Map.find id l),us) with Not_found -> x) + | c -> map_constr_expr_with_binders Id.Map.remove replace_vars_constr_expr l c -(**********************************************************************) -(* Concrete syntax for modules and modules types *) - -type with_declaration_ast = - | CWith_Module of identifier list located * qualid located - | CWith_Definition of identifier list located * constr_expr - -type module_ast = - | CMident of qualid located - | CMapply of loc * module_ast * module_ast - | CMwith of loc * module_ast * with_declaration_ast - (* Returns the ranges of locs of the notation that are not occupied by args *) (* and which are then occupied by proper symbols of the notation (or spaces) *) let locs_of_notation loc locs ntn = - let (bl,el) = Util.unloc loc in - let locs = List.map Util.unloc locs in + let (bl, el) = Loc.unloc loc in + let locs = List.map Loc.unloc locs in let rec aux pos = function - | [] -> if pos = el then [] else [(pos,el-1)] - | (ba,ea)::l ->if pos = ba then aux ea l else (pos,ba-1)::aux ea l - in aux bl (Sort.list (fun l1 l2 -> fst l1 < fst l2) locs) + | [] -> if Int.equal pos el then [] else [(pos,el)] + | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l + in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) let ntn_loc loc (args,argslist,binderslist) = locs_of_notation loc diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 39ec8e74..b25d7082 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -1,274 +1,49 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - (identifier * identifier) list -> glob_constr -> aconstr - -(** Name of the special identifier used to encode recursive notations *) -val ldots_var : identifier - -(** Equality of glob_constr (warning: only partially implemented) *) -val eq_glob_constr : glob_constr -> glob_constr -> bool - -(** Re-interpret a notation as a glob_constr, taking care of binders *) - -val glob_constr_of_aconstr_with_binders : loc -> - ('a -> name -> 'a * name) -> - ('a -> aconstr -> glob_constr) -> 'a -> aconstr -> glob_constr - -val glob_constr_of_aconstr : loc -> aconstr -> glob_constr - -(** [match_aconstr] matches a glob_constr against a notation interpretation; - raise [No_match] if the matching fails *) - -exception No_match - -val match_aconstr : bool -> glob_constr -> interpretation -> - (glob_constr * subscopes) list * (glob_constr list * subscopes) list * - (glob_decl list * subscopes) list - -val match_aconstr_cases_pattern : cases_pattern -> interpretation -> - (cases_pattern * subscopes) list * (cases_pattern list * subscopes) list - -(** Substitution of kernel names in interpretation data *) - -val subst_interpretation : substitution -> interpretation -> interpretation - -(** {6 Concrete syntax for terms } *) - -type notation = string - -type explicitation = ExplByPos of int * identifier option | ExplByName of identifier - -type binder_kind = - | Default of binding_kind - | Generalized of binding_kind * binding_kind * bool - (** Inner binding, outer bindings, typeclass-specific flag - for implicit generalization of superclasses *) - -type abstraction_kind = AbsLambda | AbsPi - -type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) - -type prim_token = Numeral of Bigint.bigint | String of string - -type cases_pattern_expr = - | CPatAlias of loc * cases_pattern_expr * identifier - | CPatCstr of loc * reference * cases_pattern_expr list - | CPatCstrExpl of loc * reference * cases_pattern_expr list - | CPatAtom of loc * reference option - | CPatOr of loc * cases_pattern_expr list - | CPatNotation of loc * notation * cases_pattern_notation_substitution - | CPatPrim of loc * prim_token - | CPatRecord of Util.loc * (reference * cases_pattern_expr) list - | CPatDelimiters of loc * string * cases_pattern_expr - -and cases_pattern_notation_substitution = - cases_pattern_expr list * (** for constr subterms *) - cases_pattern_expr list list (** for recursive notations *) - -type constr_expr = - | CRef of reference - | CFix of loc * identifier located * fix_expr list - | CCoFix of loc * identifier located * cofix_expr list - | CArrow of loc * constr_expr * constr_expr - | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr - | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr - | CLetIn of loc * name located * constr_expr * constr_expr - | CAppExpl of loc * (proj_flag * reference) * constr_expr list - | CApp of loc * (proj_flag * constr_expr) * - (constr_expr * explicitation located option) list - | CRecord of loc * constr_expr option * (reference * constr_expr) list - | CCases of loc * case_style * constr_expr option * - (constr_expr * (name located option * constr_expr option)) list * - (loc * cases_pattern_expr list located list * constr_expr) list - | CLetTuple of loc * name located list * (name located option * constr_expr option) * - constr_expr * constr_expr - | CIf of loc * constr_expr * (name located option * constr_expr option) - * constr_expr * constr_expr - | CHole of loc * Evd.hole_kind option - | CPatVar of loc * (bool * patvar) - | CEvar of loc * existential_key * constr_expr list option - | CSort of loc * glob_sort - | CCast of loc * constr_expr * constr_expr cast_type - | CNotation of loc * notation * constr_notation_substitution - | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr - | CPrim of loc * prim_token - | CDelimiters of loc * string * constr_expr - -and fix_expr = - identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr - -and cofix_expr = - identifier located * local_binder list * constr_expr * constr_expr - -and recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option (** measure, relation *) - -(** Anonymous defs allowed ?? *) -and local_binder = - | LocalRawDef of name located * constr_expr - | LocalRawAssum of name located list * binder_kind * constr_expr - -and constr_notation_substitution = - constr_expr list * (** for constr subterms *) - constr_expr list list * (** for recursive notations *) - local_binder list list (** for binders subexpressions *) - -type typeclass_constraint = name located * binding_kind * constr_expr - -and typeclass_context = typeclass_constraint list - -type constr_pattern_expr = constr_expr - -(** Utilities on constr_expr *) - -val constr_loc : constr_expr -> loc - -val cases_pattern_expr_loc : cases_pattern_expr -> loc - -val local_binders_loc : local_binder list -> loc +(** Utilities on constr_expr *) val replace_vars_constr_expr : - (identifier * identifier) list -> constr_expr -> constr_expr + Id.t Id.Map.t -> constr_expr -> constr_expr -val free_vars_of_constr_expr : constr_expr -> Idset.t -val occur_var_constr_expr : identifier -> constr_expr -> bool - -val default_binder_kind : binder_kind +val free_vars_of_constr_expr : constr_expr -> Id.Set.t +val occur_var_constr_expr : Id.t -> constr_expr -> bool (** Specific function for interning "in indtype" syntax of "match" *) -val ids_of_cases_indtype : constr_expr -> identifier list - -val mkIdentC : identifier -> constr_expr -val mkRefC : reference -> constr_expr -val mkAppC : constr_expr * constr_expr list -> constr_expr -val mkCastC : constr_expr * constr_expr cast_type -> constr_expr -val mkLambdaC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr -val mkLetInC : name located * constr_expr * constr_expr -> constr_expr -val mkProdC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr - -val coerce_reference_to_id : reference -> identifier -val coerce_to_id : constr_expr -> identifier located -val coerce_to_name : constr_expr -> name located - -val split_at_annot : local_binder list -> identifier located option -> local_binder list * local_binder list - -val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr -val prod_constr_expr : constr_expr -> local_binder list -> constr_expr +val ids_of_cases_indtype : cases_pattern_expr -> Id.t list -(** Same as [abstract_constr_expr] and [prod_constr_expr], with location *) -val mkCLambdaN : loc -> local_binder list -> constr_expr -> constr_expr -val mkCProdN : loc -> local_binder list -> constr_expr -> constr_expr - -(** For binders parsing *) - -(** With let binders *) -val names_of_local_binders : local_binder list -> name located list - -(** Does not take let binders into account *) -val names_of_local_assums : local_binder list -> name located list +val split_at_annot : local_binder list -> Id.t located option -> local_binder list * local_binder list (** Used in typeclasses *) -val fold_constr_expr_with_binders : (identifier -> 'a -> 'a) -> +val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b (** Used in correctness and interface; absence of var capture not guaranteed in pattern-matching clauses and in binders of the form [x,y:T(x)] *) val map_constr_expr_with_binders : - (identifier -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> + (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> 'a -> constr_expr -> constr_expr -(** Concrete syntax for modules and module types *) - -type with_declaration_ast = - | CWith_Module of identifier list located * qualid located - | CWith_Definition of identifier list located * constr_expr - -type module_ast = - | CMident of qualid located - | CMapply of loc * module_ast * module_ast - | CMwith of loc * module_ast * with_declaration_ast - val ntn_loc : - Util.loc -> constr_notation_substitution -> string -> (int * int) list + Loc.t -> constr_notation_substitution -> string -> (int * int) list val patntn_loc : - Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list + Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list (** For cases pattern parsing errors *) -val error_invalid_pattern_notation : Util.loc -> 'a +val error_invalid_pattern_notation : Loc.t -> 'a -- cgit v1.2.3