diff options
Diffstat (limited to 'interp')
39 files changed, 12392 insertions, 0 deletions
diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml new file mode 100644 index 0000000000..9f778d99e9 --- /dev/null +++ b/interp/constrexpr.ml @@ -0,0 +1,173 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Libnames +open Decl_kinds + +(** {6 Concrete syntax for terms } *) + +(** [constr_expr] is the abstract syntax tree produced by the parser *) +type universe_decl_expr = (lident list, Glob_term.glob_constraint list) UState.gen_universe_decl + +type ident_decl = lident * universe_decl_expr option +type name_decl = lname * universe_decl_expr option + +type notation_entry = InConstrEntry | InCustomEntry of string +type notation_entry_level = InConstrEntrySomeLevel | InCustomEntryLevel of string * int +type notation_key = string +type notation = notation_entry_level * notation_key + +type 'a or_by_notation_r = + | AN of 'a + | ByNotation of (string * string option) + +type 'a or_by_notation = 'a or_by_notation_r CAst.t + +(* NB: the last string in [ByNotation] is actually a [Notation.delimiters], + but this formulation avoids a useless dependency. *) + +type explicitation = + | ExplByPos of int * Id.t option (* a reference to the n-th product starting from left *) + | ExplByName of Id.t + +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 *) + +(** Representation of decimal literals that appear in Coq scripts. + We now use raw strings following the format defined by + [NumTok.t] and a separate sign flag. + + Note that this representation is not unique, due to possible + multiple leading or trailing zeros, and -0 = +0, for instances. + The reason to keep the numeral exactly as it was parsed is that + specific notations can be declared for specific numerals + (e.g. [Notation "0" := False], or [Notation "00" := (nil,nil)], or + [Notation "2e1" := ...]). Those notations, which override the + generic interpretation as numeral, use the same representation of + numeral using the Numeral constructor. So the latter should be able + to record the form of the numeral which exactly matches the + notation. *) + +type sign = SPlus | SMinus +type raw_numeral = NumTok.t + +type prim_token = + | Numeral of sign * raw_numeral + | String of string + +type instance_expr = Glob_term.glob_level list + +type cases_pattern_expr_r = + | CPatAlias of cases_pattern_expr * lname + | CPatCstr of qualid + * cases_pattern_expr list option * cases_pattern_expr list + (** [CPatCstr (_, c, Some l1, l2)] represents [(@ c l1) l2] *) + | CPatAtom of qualid option + | CPatOr of cases_pattern_expr list + | CPatNotation of notation * cases_pattern_notation_substitution + * cases_pattern_expr list (** CPatNotation (_, n, l1 ,l2) represents + (notation n applied with substitution l1) + applied to arguments l2 *) + | CPatPrim of prim_token + | CPatRecord of (qualid * cases_pattern_expr) list + | CPatDelimiters of string * cases_pattern_expr + | CPatCast of cases_pattern_expr * constr_expr +and cases_pattern_expr = cases_pattern_expr_r CAst.t + +and cases_pattern_notation_substitution = + cases_pattern_expr list * (* for constr subterms *) + cases_pattern_expr list list (* for recursive notations *) + +and constr_expr_r = + | CRef of qualid * instance_expr option + | CFix of lident * fix_expr list + | CCoFix of lident * cofix_expr list + | CProdN of local_binder_expr list * constr_expr + | CLambdaN of local_binder_expr list * constr_expr + | CLetIn of lname * constr_expr * constr_expr option * constr_expr + | CAppExpl of (proj_flag * qualid * instance_expr option) * constr_expr list + | CApp of (proj_flag * constr_expr) * + (constr_expr * explicitation CAst.t option) list + | CRecord of (qualid * constr_expr) list + + (* representation of the "let" and "match" constructs *) + | CCases of Constr.case_style (* determines whether this value represents "let" or "match" construct *) + * constr_expr option (* return-clause *) + * case_expr list + * branch_expr list (* branches *) + + | CLetTuple of lname list * (lname option * constr_expr option) * + constr_expr * constr_expr + | CIf of constr_expr * (lname option * constr_expr option) + * constr_expr * constr_expr + | CHole of Evar_kinds.t option * Namegen.intro_pattern_naming_expr * Genarg.raw_generic_argument option + | CPatVar of Pattern.patvar + | CEvar of Glob_term.existential_name * (Id.t * constr_expr) list + | CSort of Glob_term.glob_sort + | CCast of constr_expr * constr_expr Glob_term.cast_type + | CNotation of notation * constr_notation_substitution + | CGeneralization of binding_kind * abstraction_kind option * constr_expr + | CPrim of prim_token + | CDelimiters of string * constr_expr +and constr_expr = constr_expr_r CAst.t + +and case_expr = constr_expr (* expression that is being matched *) + * lname option (* as-clause *) + * cases_pattern_expr option (* in-clause *) + +and branch_expr = + (cases_pattern_expr list list * constr_expr) CAst.t + +and fix_expr = + lident * recursion_order_expr option * + local_binder_expr list * constr_expr * constr_expr + +and cofix_expr = + lident * local_binder_expr list * constr_expr * constr_expr + +and recursion_order_expr_r = + | CStructRec of lident + | CWfRec of lident * constr_expr + | CMeasureRec of lident option * constr_expr * constr_expr option (** argument, measure, relation *) +and recursion_order_expr = recursion_order_expr_r CAst.t + +(* Anonymous defs allowed ?? *) +and local_binder_expr = + | CLocalAssum of lname list * binder_kind * constr_expr + | CLocalDef of lname * constr_expr * constr_expr option + | CLocalPattern of (cases_pattern_expr * constr_expr option) CAst.t + +and constr_notation_substitution = + constr_expr list * (* for constr subterms *) + constr_expr list list * (* for recursive notations *) + cases_pattern_expr list * (* for binders *) + local_binder_expr list list (* for binder lists (recursive notations) *) + +type constr_pattern_expr = constr_expr + +(** Concrete syntax for modules and module types *) + +type with_declaration_ast = + | CWith_Module of Id.t list CAst.t * qualid + | CWith_Definition of Id.t list CAst.t * universe_decl_expr option * constr_expr + +type module_ast_r = + | CMident of qualid + | CMapply of module_ast * module_ast + | CMwith of module_ast * with_declaration_ast +and module_ast = module_ast_r CAst.t diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml new file mode 100644 index 0000000000..443473d5b6 --- /dev/null +++ b/interp/constrexpr_ops.ml @@ -0,0 +1,645 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open Names +open Nameops +open Libnames +open Namegen +open Glob_term +open Constrexpr +open Notation +open Decl_kinds + +(***********************) +(* For binders parsing *) + +let binding_kind_eq bk1 bk2 = match bk1, bk2 with +| Explicit, Explicit -> 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 CLocalAssum(l,_,_)->l|_->[]) bl) + +let names_of_local_binders bl = + List.flatten (List.map (function CLocalAssum(l,_,_)->l|CLocalDef(l,_,_)->[l]|CLocalPattern _ -> assert false) bl) + +(**********************************************************************) +(* Functions on constr_expr *) + +(* Note: redundant Numeral representations, such as -0 and +0 (and others), + are considered different here. *) + +let prim_token_eq t1 t2 = match t1, t2 with +| Numeral (SPlus,n1), Numeral (SPlus,n2) +| Numeral (SMinus,n1), Numeral (SMinus,n2) -> NumTok.equal n1 n2 +| String s1, String s2 -> String.equal s1 s2 +| (Numeral ((SPlus|SMinus),_) | String _), _ -> 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_ast f { CAst.v = x } { CAst.v = y } = f x y + +let rec cases_pattern_expr_eq p1 p2 = + if CAst.(p1.v == p2.v) then true + else match CAst.(p1.v, p2.v) with + | CPatAlias(a1,i1), CPatAlias(a2,i2) -> + eq_ast Name.equal i1 i2 && cases_pattern_expr_eq a1 a2 + | CPatCstr(c1,a1,b1), CPatCstr(c2,a2,b2) -> + qualid_eq c1 c2 && + Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && + List.equal cases_pattern_expr_eq b1 b2 + | CPatAtom(r1), CPatAtom(r2) -> + Option.equal qualid_eq r1 r2 + | CPatOr a1, CPatOr a2 -> + List.equal cases_pattern_expr_eq a1 a2 + | CPatNotation (n1, s1, l1), CPatNotation (n2, s2, l2) -> + notation_eq 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) = + qualid_eq 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 CAst.(e1.v == e2.v) then true + else match CAst.(e1.v, e2.v) with + | CRef (r1,u1), CRef (r2,u2) -> qualid_eq r1 r2 && eq_universes u1 u2 + | CFix(id1,fl1), CFix(id2,fl2) -> + eq_ast Id.equal id1 id2 && + List.equal fix_expr_eq fl1 fl2 + | CCoFix(id1,fl1), CCoFix(id2,fl2) -> + eq_ast Id.equal id1 id2 && + List.equal cofix_expr_eq fl1 fl2 + | CProdN(bl1,a1), CProdN(bl2,a2) -> + List.equal local_binder_eq bl1 bl2 && + constr_expr_eq a1 a2 + | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> + List.equal local_binder_eq bl1 bl2 && + constr_expr_eq a1 a2 + | CLetIn(na1,a1,t1,b1), CLetIn(na2,a2,t2,b2) -> + eq_ast Name.equal na1 na2 && + constr_expr_eq a1 a2 && + Option.equal constr_expr_eq t1 t2 && + constr_expr_eq b1 b2 + | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> + Option.equal Int.equal proj1 proj2 && + qualid_eq 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 l1, CRecord l2 -> + let field_eq (r1, e1) (r2, e2) = + qualid_eq r1 r2 && constr_expr_eq e1 e2 + in + 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_ast Name.equal) n1 n2 && + Option.equal (eq_ast 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_ast 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 -> + Glob_ops.glob_sort_eq s1 s2 + | CCast(t1,c1), CCast(t2,c2) -> + constr_expr_eq t1 t2 && cast_expr_eq c1 c2 + | CNotation(n1, s1), CNotation(n2, s2) -> + notation_eq 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 + | (CRef _ | CFix _ | CCoFix _ | CProdN _ | CLambdaN _ | CLetIn _ | CAppExpl _ + | CApp _ | CRecord _ | CCases _ | CLetTuple _ | CIf _ | CHole _ + | CPatVar _ | CEvar _ | CSort _ | CCast _ | CNotation _ | CPrim _ + | CGeneralization _ | CDelimiters _ ), _ -> false + +and args_eq (a1,e1) (a2,e2) = + Option.equal (eq_ast 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_ast Name.equal) n1 n2 && + Option.equal cases_pattern_expr_eq p1 p2 + +and branch_expr_eq {CAst.v=(p1, e1)} {CAst.v=(p2, e2)} = + List.equal (List.equal cases_pattern_expr_eq) p1 p2 && + constr_expr_eq e1 e2 + +and fix_expr_eq (id1,r1,bl1,a1,b1) (id2,r2,bl2,a2,b2) = + (eq_ast Id.equal id1 id2) && + Option.equal 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_ast 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_r r1 r2 = match r1, r2 with + | CStructRec i1, CStructRec i2 -> eq_ast Id.equal i1 i2 + | CWfRec (i1,e1), CWfRec (i2,e2) -> + constr_expr_eq e1 e2 + | CMeasureRec (i1, e1, o1), CMeasureRec (i2, e2, o2) -> + Option.equal (eq_ast Id.equal) i1 i2 && + constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 + | _ -> false + +and recursion_order_expr_eq r1 r2 = eq_ast recursion_order_expr_eq_r r1 r2 + +and local_binder_eq l1 l2 = match l1, l2 with + | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> + eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 + | CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> + (* Don't care about the [binder_kind] *) + List.equal (eq_ast Name.equal) n1 n2 && constr_expr_eq e1 e2 + | _ -> false + +and constr_notation_substitution_eq (e1, el1, b1, bl1) (e2, el2, b2, bl2) = + List.equal constr_expr_eq e1 e2 && + List.equal (List.equal constr_expr_eq) el1 el2 && + List.equal cases_pattern_expr_eq b1 b2 && + 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 + +and cast_expr_eq c1 c2 = match c1, c2 with +| CastConv t1, CastConv t2 +| CastVM t1, CastVM t2 +| CastNative t1, CastNative t2 -> constr_expr_eq t1 t2 +| CastCoerce, CastCoerce -> true +| CastConv _, _ +| CastVM _, _ +| CastNative _, _ +| CastCoerce, _ -> false + +let constr_loc c = CAst.(c.loc) +let cases_pattern_expr_loc cp = CAst.(cp.loc) + +let local_binder_loc = let open CAst in function + | CLocalAssum ({ loc } ::_,_,t) + | CLocalDef ( { loc },t,None) -> Loc.merge_opt loc (constr_loc t) + | CLocalDef ( { loc },b,Some t) -> Loc.merge_opt loc (Loc.merge_opt (constr_loc b) (constr_loc t)) + | CLocalAssum ([],_,_) -> assert false + | CLocalPattern { loc } -> loc + +let local_binders_loc bll = match bll with + | [] -> None + | h :: l -> Loc.merge_opt (local_binder_loc h) (local_binder_loc (List.last bll)) + +(** Folds and maps *) +let is_constructor id = + try Globnames.isConstructRef + (Smartlocate.global_of_extended_global + (Nametab.locate_extended (qualid_of_ident id))) + with Not_found -> false + +let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with + | CPatRecord l -> + List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l + | CPatAlias (pat,{CAst.v=na}) -> Name.fold_right f na (cases_pattern_fold_names f a pat) + | CPatOr (patl) -> + List.fold_left (cases_pattern_fold_names f) a patl + | CPatCstr (_,patl1,patl2) -> + List.fold_left (cases_pattern_fold_names f) + (Option.fold_left (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 qid) + when qualid_is_ident qid && not (is_constructor @@ qualid_basename qid) -> + f (qualid_basename qid) a + | CPatPrim _ | CPatAtom _ -> a + | CPatCast ({CAst.loc},_) -> + CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" + (Pp.strbrk "Casts are not supported here.") + +let ids_of_pattern = + cases_pattern_fold_names Id.Set.add Id.Set.empty + +let ids_of_pattern_list = + List.fold_left + (List.fold_left (cases_pattern_fold_names Id.Set.add)) + Id.Set.empty + +let ids_of_cases_tomatch tms = + List.fold_right + (fun (_, ona, indnal) l -> + Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + indnal + (Option.fold_right (CAst.with_val (Name.fold_right Id.Set.add)) ona l)) + tms Id.Set.empty + +let rec fold_local_binders g f n acc b = let open CAst in function + | CLocalAssum (nal,bk,t)::l -> + let nal = List.(map (fun {v} -> v) nal) in + let n' = List.fold_right (Name.fold_right g) nal n in + f n (fold_local_binders g f n' acc b l) t + | CLocalDef ( { v = na },c,t)::l -> + Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t + | CLocalPattern { v = pat,t }::l -> + let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in + Option.fold_left (f n) acc t + | [] -> + f n acc b + +let fold_constr_expr_with_binders g f n acc = CAst.with_val (function + | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l + | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) + | CProdN (l,b) | CLambdaN (l,b) -> fold_local_binders g f n acc b l + | CLetIn (na,a,t,b) -> + f (Name.fold_right g (na.CAst.v) n) (Option.fold_left (f n) (f n acc a) t) b + | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b + | CCast (a,CastCoerce) -> f n acc a + | CNotation (_,(l,ll,bl,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 (CAst.make @@ CHole (None,IntroAnonymous,None)) bl) acc bll + | CGeneralization (_,_,c) -> f n acc c + | CDelimiters (_,a) -> f n acc a + | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> + acc + | CRecord l -> List.fold_left (fun acc (id, c) -> f n acc c) acc l + | CCases (sty,rtnpo,al,bl) -> + let ids = ids_of_cases_tomatch al in + let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in + let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in + List.fold_right (fun {CAst.v=(patl,rhs)} acc -> + let ids = ids_of_pattern_list patl in + f (Id.Set.fold g ids n) acc rhs) bl acc + | CLetTuple (nal,(ona,po),b,c) -> + let n' = List.fold_right (CAst.with_val (Name.fold_right g)) nal n in + f (Option.fold_right (CAst.with_val (Name.fold_right 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 (CAst.with_val (Name.fold_right g)) ona n)) acc po + | CFix (_,l) -> + let n' = List.fold_right (fun ( { CAst.v = id },_,_,_,_) -> g id) l n in + List.fold_right (fun (_,ro,lb,t,c) acc -> + fold_local_binders g f n' + (fold_local_binders g f n acc t lb) c lb) l acc + | CCoFix (_,_) -> + Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc + ) + +let free_vars_of_constr_expr c = + let rec aux bdvars l = function + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + let id = qualid_basename qid in + 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 [] Id.Set.empty c + +let names_of_constr_expr c = + let vars = ref Id.Set.empty in + let rec aux () () = function + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + let id = qualid_basename qid in vars := Id.Set.add id !vars + | c -> fold_constr_expr_with_binders (fun a () -> vars := Id.Set.add a !vars) aux () () c + in aux () () c; !vars + +let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) + +(* Used in correctness and interface *) +let map_binder g e nal = List.fold_right (CAst.with_val (Name.fold_right g)) nal e + +let map_local_binders f g e bl = + (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) + let open CAst in + let h (e,bl) = function + CLocalAssum(nal,k,ty) -> + (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) + | CLocalDef( { loc ; v = na } as cna ,c,ty) -> + (Name.fold_right g na e, CLocalDef(cna,f e c,Option.map (f e) ty)::bl) + | CLocalPattern { loc; v = pat,t } -> + let ids = ids_of_pattern pat in + (Id.Set.fold g ids e, CLocalPattern (make ?loc (pat,Option.map (f e) t))::bl) in + let (e,rbl) = List.fold_left h (e,[]) bl in + (e, List.rev rbl) + +let map_constr_expr_with_binders g f e = CAst.map (function + | CAppExpl (r,l) -> CAppExpl (r,List.map (f e) l) + | CApp ((p,a),l) -> + CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) + | CProdN (bl,b) -> + let (e,bl) = map_local_binders f g e bl in CProdN (bl,f e b) + | CLambdaN (bl,b) -> + let (e,bl) = map_local_binders f g e bl in CLambdaN (bl,f e b) + | CLetIn (na,a,t,b) -> + CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (na.CAst.v) e) b) + | CCast (a,c) -> CCast (f e a, Glob_ops.map_cast_type (f e) c) + | CNotation (n,(l,ll,bl,bll)) -> + (* This is an approximation because we don't know what binds what *) + CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, bl, + List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) + | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) + | CDelimiters (s,a) -> CDelimiters (s,f e a) + | CHole _ | CEvar _ | CPatVar _ | CSort _ + | CPrim _ | CRef _ as x -> x + | CRecord l -> CRecord (List.map (fun (id, c) -> (id, f e c)) l) + | CCases (sty,rtnpo,a,bl) -> + let bl = List.map (fun {CAst.v=(patl,rhs);loc} -> + let ids = ids_of_pattern_list patl in + CAst.make ?loc (patl,f (Id.Set.fold g ids e) rhs)) bl in + let ids = ids_of_cases_tomatch a in + let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in + CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) + | CLetTuple (nal,(ona,po),b,c) -> + let e' = List.fold_right (CAst.with_val (Name.fold_right g)) nal e in + let e'' = Option.fold_right (CAst.with_val (Name.fold_right g)) ona e in + CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) + | CIf (c,(ona,po),b1,b2) -> + let e' = Option.fold_right (CAst.with_val (Name.fold_right g)) ona e in + CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) + | CFix (id,dl) -> + CFix (id,List.map (fun (id,n,bl,t,d) -> + let (e',bl') = map_local_binders f g e bl in + let t' = f e' t in + (* Note: fix names should be inserted before the arguments... *) + let e'' = List.fold_left (fun e ({ CAst.v = id },_,_,_,_) -> g id e) e' dl in + let d' = f e'' d in + (id,n,bl',t',d')) dl) + | CCoFix (id,dl) -> + CCoFix (id,List.map (fun (id,bl,t,d) -> + let (e',bl') = map_local_binders f g e bl in + let t' = f e' t in + let e'' = List.fold_left (fun e ({ CAst.v = id },_,_,_) -> g id e) e' dl in + let d' = f e'' d in + (id,bl',t',d')) dl) + ) + +(* Used in constrintern *) +let rec replace_vars_constr_expr l r = + match r with + | { CAst.loc; v = CRef (qid,us) } as x when qualid_is_ident qid -> + let id = qualid_basename qid in + (try CAst.make ?loc @@ CRef (qualid_of_ident ?loc (Id.Map.find id l),us) + with Not_found -> x) + | cn -> map_constr_expr_with_binders Id.Map.remove replace_vars_constr_expr l cn + +(* 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 unloc loc = Option.cata Loc.unloc (0,0) loc in + let (bl, el) = unloc loc in + let locs = List.map unloc locs in + let rec aux pos = function + | [] -> 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,binders,binderslist) = + locs_of_notation ?loc + (List.map constr_loc (args@List.flatten argslist)@ + List.map cases_pattern_expr_loc binders@ + List.map local_binders_loc binderslist) + +let patntn_loc ?loc (args,argslist) = + locs_of_notation ?loc + (List.map cases_pattern_expr_loc (args@List.flatten argslist)) + +let error_invalid_pattern_notation ?loc () = + CErrors.user_err ?loc (str "Invalid notation for pattern.") + +(* Interpret the index of a recursion order annotation *) +let split_at_annot bl na = + let open CAst in + let names = List.map (fun { v } -> v) (names_of_local_assums bl) in + match na with + | None -> + begin match names with + | [] -> CErrors.user_err (Pp.str "A fixpoint needs at least one parameter.") + | _ -> ([], bl) + end + | Some { loc; v = id } -> + let rec aux acc = function + | CLocalAssum (bls, k, t) as x :: rest -> + let test { CAst.v = 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 + | _ -> CLocalAssum (l, k, t) :: acc + in + (List.rev ans, CLocalAssum (r, k, t) :: rest) + end + | CLocalDef ({ CAst.v = na },_,_) as x :: rest -> + if Name.equal (Name id) na then + CErrors.user_err ?loc + (Id.print id ++ str" must be a proper parameter and not a local definition.") + else + aux (x :: acc) rest + | CLocalPattern _ :: rest -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed after fix") + | [] -> + CErrors.user_err ?loc + (str "No parameter named " ++ Id.print id ++ str".") + in aux [] bl + +(** Pseudo-constructors *) + +let mkIdentC id = CAst.make @@ CRef (qualid_of_ident id,None) +let mkRefC r = CAst.make @@ CRef (r,None) +let mkCastC (a,k) = CAst.make @@ CCast (a,k) +let mkLambdaC (idl,bk,a,b) = CAst.make @@ CLambdaN ([CLocalAssum (idl,bk,a)],b) +let mkLetInC (id,a,t,b) = CAst.make @@ CLetIn (id,a,t,b) +let mkProdC (idl,bk,a,b) = CAst.make @@ CProdN ([CLocalAssum (idl,bk,a)],b) + +let mkAppC (f,l) = + let l = List.map (fun x -> (x,None)) l in + match CAst.(f.v) with + | CApp (g,l') -> CAst.make @@ CApp (g, l' @ l) + | _ -> CAst.make @@ CApp ((None, f), l) + +let mkProdCN ?loc bll c = + if bll = [] then c else + CAst.make ?loc @@ CProdN (bll,c) + +let mkLambdaCN ?loc bll c = + if bll = [] then c else + CAst.make ?loc @@ CLambdaN (bll,c) + +let mkCProdN ?loc bll c = + CAst.make ?loc @@ CProdN (bll,c) + +let mkCLambdaN ?loc bll c = + CAst.make ?loc @@ CLambdaN (bll,c) + +let coerce_reference_to_id qid = + if qualid_is_ident qid then qualid_basename qid + else + CErrors.user_err ?loc:qid.CAst.loc ~hdr:"coerce_reference_to_id" + (str "This expression should be a simple identifier.") + +let coerce_to_id = function + | { CAst.loc; v = CRef (qid,None) } when qualid_is_ident qid -> + CAst.make ?loc @@ qualid_basename qid + | { CAst.loc; _ } -> CErrors.user_err ?loc + ~hdr:"coerce_to_id" + (str "This expression should be a simple identifier.") + +let coerce_to_name = function + | { CAst.loc; v = CRef (qid,None) } when qualid_is_ident qid -> + CAst.make ?loc @@ Name (qualid_basename qid) + | { CAst.loc; v = CHole (None,IntroAnonymous,None) } -> CAst.make ?loc Anonymous + | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" + (str "This expression should be a name.") + +let mkCPatOr ?loc = function + | [pat] -> pat + | disjpat -> CAst.make ?loc @@ (CPatOr disjpat) + +let mkAppPattern ?loc p lp = + let open CAst in + make ?loc @@ (match p.v with + | CPatAtom (Some r) -> CPatCstr (r, None, lp) + | CPatCstr (r, None, l2) -> + CErrors.user_err ?loc:p.loc ~hdr:"compound_pattern" + (Pp.str "Nested applications not supported.") + | CPatCstr (r, l1, l2) -> CPatCstr (r, l1 , l2@lp) + | CPatNotation (n, s, l) -> CPatNotation (n , s, l@lp) + | _ -> CErrors.user_err + ?loc:p.loc ~hdr:"compound_pattern" + (Pp.str "Such pattern cannot have arguments.")) + +let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function + | CRef (r,None) -> + CPatAtom (Some r) + | CHole (None,IntroAnonymous,None) -> + CPatAtom None + | CLetIn ({CAst.loc;v=Name id},b,None,{ CAst.v = CRef (qid,None) }) + when qualid_is_ident qid && Id.equal id (qualid_basename qid) -> + CPatAlias (coerce_to_cases_pattern_expr b, CAst.(make ?loc @@ Name id)) + | CApp ((None,p),args) when List.for_all (fun (_,e) -> e=None) args -> + (mkAppPattern (coerce_to_cases_pattern_expr p) (List.map (fun (a,_) -> coerce_to_cases_pattern_expr a) args)).CAst.v + | CAppExpl ((None,r,i),args) -> + CPatCstr (r,Some (List.map coerce_to_cases_pattern_expr args),[]) + | CNotation (ntn,(c,cl,[],[])) -> + CPatNotation (ntn,(List.map coerce_to_cases_pattern_expr c, + List.map (List.map coerce_to_cases_pattern_expr) cl),[]) + | CPrim p -> + CPatPrim p + | CRecord l -> + CPatRecord (List.map (fun (r,p) -> (r,coerce_to_cases_pattern_expr p)) l) + | CDelimiters (s,p) -> + CPatDelimiters (s,coerce_to_cases_pattern_expr p) + | CCast (p,CastConv t) -> + CPatCast (coerce_to_cases_pattern_expr p,t) + | _ -> + CErrors.user_err ?loc ~hdr:"coerce_to_cases_pattern_expr" + (str "This expression should be coercible to a pattern.")) c + +(** Local universe and constraint declarations. *) + +let interp_univ_constraints env evd cstrs = + let interp (evd,cstrs) (u, d, u') = + let ul = Pretyping.interp_known_glob_level evd u in + let u'l = Pretyping.interp_known_glob_level evd u' in + let cstr = (ul,d,u'l) in + let cstrs' = Univ.Constraint.add cstr cstrs in + try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in + evd, cstrs' + with Univ.UniverseInconsistency e -> + CErrors.user_err ~hdr:"interp_constraint" + (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) + in + List.fold_left interp (evd,Univ.Constraint.empty) cstrs + +let interp_univ_decl env decl = + let open UState in + let pl : lident list = decl.univdecl_instance in + let evd = Evd.from_ctx (UState.make_with_initial_binders (Environ.universes env) pl) in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { univdecl_instance = pl; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints } + in evd, decl + +let interp_univ_decl_opt env l = + match l with + | None -> Evd.from_env env, UState.default_univ_decl + | Some decl -> interp_univ_decl env decl diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli new file mode 100644 index 0000000000..f1a8ed202f --- /dev/null +++ b/interp/constrexpr_ops.mli @@ -0,0 +1,135 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Libnames +open Constrexpr + +(** Constrexpr_ops: utilities on [constr_expr] *) + +(** {6 Equalities on [constr_expr] related types} *) + +val explicitation_eq : explicitation -> 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_expr -> local_binder_expr -> bool +(** Equality on [local_binder_expr]. 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 option +val cases_pattern_expr_loc : cases_pattern_expr -> Loc.t option +val local_binders_loc : local_binder_expr list -> Loc.t option + +(** {6 Constructors} *) + +(** {7 Term constructors} *) + +(** Basic form of the corresponding constructors *) + +val mkIdentC : Id.t -> constr_expr +val mkRefC : qualid -> constr_expr +val mkCastC : constr_expr * constr_expr Glob_term.cast_type -> constr_expr +val mkLambdaC : lname list * binder_kind * constr_expr * constr_expr -> constr_expr +val mkLetInC : lname * constr_expr * constr_expr option * constr_expr -> constr_expr +val mkProdC : lname list * binder_kind * constr_expr * constr_expr -> constr_expr + +val mkAppC : constr_expr * constr_expr list -> constr_expr +(** Basic form of application, collapsing nested applications *) + +(** Optimized constructors: does not add a constructor for an empty binder list *) + +val mkLambdaCN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr +val mkProdCN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr + +(** Aliases for the corresponding constructors; generally [mkLambdaCN] and + [mkProdCN] should be preferred *) + +val mkCLambdaN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr +val mkCProdN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr + +(** {7 Pattern constructors} *) + +(** Interpretation of a list of patterns as a disjunctive pattern (optimized) *) +val mkCPatOr : ?loc:Loc.t -> cases_pattern_expr list -> cases_pattern_expr + +val mkAppPattern : ?loc:Loc.t -> cases_pattern_expr -> cases_pattern_expr list -> cases_pattern_expr +(** Apply a list of pattern arguments to a pattern *) + +(** {6 Destructors}*) + +val coerce_reference_to_id : qualid -> Id.t +(** FIXME: nothing to do here *) + +val coerce_to_id : constr_expr -> lident +(** Destruct terms of the form [CRef (Ident _)]. *) + +val coerce_to_name : constr_expr -> lname +(** Destruct terms of the form [CRef (Ident _)] or [CHole _]. *) + +val coerce_to_cases_pattern_expr : constr_expr -> cases_pattern_expr + +(** {6 Binder manipulation} *) + +val default_binder_kind : binder_kind + +val names_of_local_binders : local_binder_expr list -> lname list +(** Retrieve a list of binding names from a list of binders. *) + +val names_of_local_assums : local_binder_expr list -> lname list +(** Same as [names_of_local_binder_exprs], but does not take the [let] bindings into + account. *) + +(** {6 Folds and maps} *) + +(** Used in typeclasses *) +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 : + (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> + 'a -> constr_expr -> constr_expr + +val replace_vars_constr_expr : + Id.t Id.Map.t -> constr_expr -> constr_expr + +val free_vars_of_constr_expr : constr_expr -> Id.Set.t +val occur_var_constr_expr : Id.t -> constr_expr -> bool + +(** Return all (non-qualified) names treating binders as names *) +val names_of_constr_expr : constr_expr -> Id.Set.t + +val split_at_annot : local_binder_expr list -> lident option -> local_binder_expr list * local_binder_expr list + +val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> notation -> (int * int) list +val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> notation -> (int * int) list + +(** For cases pattern parsing errors *) +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a + +(** Local universe and constraint declarations. *) +val interp_univ_decl : Environ.env -> universe_decl_expr -> + Evd.evar_map * UState.universe_decl + +val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> + Evd.evar_map * UState.universe_decl diff --git a/interp/constrextern.ml b/interp/constrextern.ml new file mode 100644 index 0000000000..488c9a740f --- /dev/null +++ b/interp/constrextern.ml @@ -0,0 +1,1332 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Pp +open CErrors +open Util +open Names +open Nameops +open Termops +open Libnames +open Globnames +open Namegen +open Impargs +open CAst +open Constrexpr +open Constrexpr_ops +open Notation_ops +open Glob_term +open Glob_ops +open Pattern +open Notation +open Detyping +open Decl_kinds + +module NamedDecl = Context.Named.Declaration +(*i*) + +(* Translation from glob_constr to front constr *) + +(**********************************************************************) +(* Parametrization *) + +(* This governs printing of local context of references *) +let print_arguments = ref false + +(* If true, prints local context of evars *) +let print_evar_arguments = Detyping.print_evar_arguments + +(* This governs printing of implicit arguments. When + [print_implicits] is on then [print_implicits_explicit_args] tells + how implicit args are printed. If on, implicit args are printed + with the form (id:=arg) otherwise arguments are printed normally and + the function is prefixed by "@" *) +let print_implicits = ref false +let print_implicits_explicit_args = ref false + +(* Tells if implicit arguments not known to be inferable from a rigid + position are systematically printed *) +let print_implicits_defensive = ref true + +(* This forces printing of coercions *) +let print_coercions = ref false + +(* This forces printing universe names of Type{.} *) +let print_universes = Detyping.print_universes + +(* This suppresses printing of primitive tokens (e.g. numeral) and notations *) +let print_no_symbol = ref false + +(**********************************************************************) +(* Turning notations and scopes on and off for printing *) +module IRuleSet = InterpRuleSet + +let inactive_notations_table = + Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty) +let inactive_scopes_table = + Summary.ref ~name:"inactive_scopes_table" CString.Set.empty + +let show_scope scopt = + match scopt with + | None -> str "" + | Some sc -> spc () ++ str "in scope" ++ spc () ++ str sc + +let _show_inactive_notations () = + begin + if CString.Set.is_empty !inactive_scopes_table + then + Feedback.msg_notice (str "No inactive notation scopes.") + else + let _ = Feedback.msg_notice (str "Inactive notation scopes:") in + CString.Set.iter (fun sc -> Feedback.msg_notice (str " " ++ str sc)) + !inactive_scopes_table + end; + if IRuleSet.is_empty !inactive_notations_table + then + Feedback.msg_notice (str "No individual inactive notations.") + else + let _ = Feedback.msg_notice (str "Inactive notations:") in + IRuleSet.iter + (function + | NotationRule (scopt, ntn) -> + Feedback.msg_notice (pr_notation ntn ++ show_scope scopt) + | SynDefRule kn -> Feedback.msg_notice (str (string_of_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn)))) + !inactive_notations_table + +let deactivate_notation nr = + match nr with + | SynDefRule kn -> + (* shouldn't we check wether it is well defined? *) + inactive_notations_table := IRuleSet.add nr !inactive_notations_table + | NotationRule (scopt, ntn) -> + if not (exists_notation_interpretation_in_scope scopt ntn) then + user_err ~hdr:"Notation" + (pr_notation ntn ++ spc () ++ str "does not exist" + ++ (match scopt with + | None -> spc () ++ str "in the empty scope." + | Some _ -> show_scope scopt ++ str ".")) + else + if IRuleSet.mem nr !inactive_notations_table then + Feedback.msg_warning + (str "Notation" ++ spc () ++ pr_notation ntn ++ spc () + ++ str "is already inactive" ++ show_scope scopt ++ str ".") + else inactive_notations_table := IRuleSet.add nr !inactive_notations_table + +let reactivate_notation nr = + try + inactive_notations_table := + IRuleSet.remove nr !inactive_notations_table + with Not_found -> + match nr with + | NotationRule (scopt, ntn) -> + Feedback.msg_warning (str "Notation" ++ spc () ++ pr_notation ntn ++ spc () + ++ str "is already active" ++ show_scope scopt ++ + str ".") + | SynDefRule kn -> + let s = string_of_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) in + Feedback.msg_warning + (str "Notation" ++ spc () ++ str s + ++ spc () ++ str "is already active.") + + +let deactivate_scope sc = + ignore (find_scope sc); (* ensures that the scope exists *) + if CString.Set.mem sc !inactive_scopes_table + then + Feedback.msg_warning (str "Notation Scope" ++ spc () ++ str sc ++ spc () + ++ str "is already inactive.") + else + inactive_scopes_table := CString.Set.add sc !inactive_scopes_table + +let reactivate_scope sc = + try + inactive_scopes_table := CString.Set.remove sc !inactive_scopes_table + with Not_found -> + Feedback.msg_warning (str "Notation Scope" ++ spc () ++ str sc ++ spc () + ++ str "is already active.") + +let is_inactive_rule nr = + IRuleSet.mem nr !inactive_notations_table || + match nr with + | NotationRule (Some sc, ntn) -> CString.Set.mem sc !inactive_scopes_table + | NotationRule (None, ntn) -> false + | SynDefRule _ -> false + +(* args: notation, scope, activate/deactivate *) +let toggle_scope_printing ~scope ~activate = + if activate then + reactivate_scope scope + else + deactivate_scope scope + +let toggle_notation_printing ?scope ~notation ~activate = + if activate then + reactivate_notation (NotationRule (scope, notation)) + else + deactivate_notation (NotationRule (scope, notation)) + +(* This governs printing of projections using the dot notation symbols *) +let print_projections = ref false + +let print_meta_as_hole = ref false + +let with_universes f = Flags.with_option print_universes f +let with_meta_as_hole f = Flags.with_option print_meta_as_hole f +let without_symbols f = Flags.with_option print_no_symbol f + +let without_specific_symbols l = + Flags.with_modified_ref inactive_notations_table + (fun tbl -> IRuleSet.(union (of_list l) tbl)) + +(**********************************************************************) +(* Control printing of records *) + +(* Set Record Printing flag *) +let get_record_print = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"record printing" + ~key:["Printing";"Records"] + ~value:true + +let is_record indsp = + try + let _ = Recordops.lookup_structure indsp in + true + with Not_found -> false + +let encode_record r = + let indsp = Nametab.global_inductive r in + if not (is_record indsp) then + user_err ?loc:r.CAst.loc ~hdr:"encode_record" + (str "This type is not a structure type."); + indsp + +module PrintingRecordRecord = + PrintingInductiveMake (struct + let encode _env = encode_record + let field = "Record" + let title = "Types leading to pretty-printing using record notation: " + let member_message s b = + str "Terms of " ++ s ++ + str + (if b then " are printed using record notation" + else " are not printed using record notation") + end) + +module PrintingRecordConstructor = + PrintingInductiveMake (struct + let encode _env = encode_record + let field = "Constructor" + let title = "Types leading to pretty-printing using constructor form: " + let member_message s b = + str "Terms of " ++ s ++ + str + (if b then " are printed using constructor form" + else " are not printed using constructor form") + end) + +module PrintingRecord = Goptions.MakeRefTable(PrintingRecordRecord) +module PrintingConstructor = Goptions.MakeRefTable(PrintingRecordConstructor) + +(**********************************************************************) +(* Various externalisation functions *) + +let insert_delimiters e = function + | None -> e + | Some sc -> CAst.make @@ CDelimiters (sc,e) + +let insert_pat_delimiters ?loc p = function + | None -> p + | Some sc -> CAst.make ?loc @@ CPatDelimiters (sc,p) + +let insert_pat_alias ?loc p = function + | Anonymous -> p + | Name _ as na -> CAst.make ?loc @@ CPatAlias (p,(CAst.make ?loc na)) + +let rec insert_coercion ?loc l c = match l with + | [] -> c + | ntn::l -> CAst.make ?loc @@ CNotation (ntn,([insert_coercion ?loc l c],[],[],[])) + +let rec insert_pat_coercion ?loc l c = match l with + | [] -> c + | ntn::l -> CAst.make ?loc @@ CPatNotation (ntn,([insert_pat_coercion ?loc l c],[]),[]) + +let add_lonely keyrule seen = + match keyrule with + | NotationRule (None,ntn) -> ntn::seen + | SynDefRule _ | NotationRule (Some _,_) -> seen + +(**********************************************************************) +(* conversion of references *) + +let extern_evar n l = CEvar (n,l) + +(** We allow customization of the global_reference printer. + For instance, in the debugger the tables of global references + may be inaccurate *) + +let default_extern_reference ?loc vars r = + Nametab.shortest_qualid_of_global ?loc vars r + +let my_extern_reference = ref default_extern_reference + +let set_extern_reference f = my_extern_reference := f +let get_extern_reference () = !my_extern_reference + +let extern_reference ?loc vars l = !my_extern_reference vars l + +(**********************************************************************) +(* 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 (Global.env()) ind) (CAst.make @@ CPatAtom None) l + +let add_cpatt_for_params ind l = + if !Flags.in_debugger then l else + Util.List.addn (Inductiveops.inductive_nparamdecls (Global.env()) ind) (DAst.make @@ PatVar Anonymous) 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, { CAst.v = 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 destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None +let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None + +let is_zero s = + let rec aux i = + Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) + in aux 0 +let is_zero n = is_zero n.NumTok.int && is_zero n.NumTok.frac + +let make_notation_gen loc ntn mknot mkprim destprim l bl = + match snd ntn,List.map destprim l with + (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) + | "- _", [Some (Numeral (SPlus,p))] when not (is_zero p) -> + assert (bl=[]); + mknot (loc,ntn,([mknot (loc,(InConstrEntrySomeLevel,"( _ )"),l,[])]),[]) + | _ -> + match decompose_notation_key ntn, l with + | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] -> + begin match NumTok.of_string x with + | Some n -> mkprim (loc, Numeral (SMinus,n)) + | None -> mknot (loc,ntn,l,bl) end + | (InConstrEntrySomeLevel,[Terminal x]), [] -> + begin match NumTok.of_string x with + | Some n -> mkprim (loc, Numeral (SPlus,n)) + | None -> mknot (loc,ntn,l,bl) end + | _ -> mknot (loc,ntn,l,bl) + +let make_notation loc ntn (terms,termlists,binders,binderlists as subst) = + if not (List.is_empty termlists) || not (List.is_empty binderlists) then + CAst.make ?loc @@ CNotation (ntn,subst) + else + make_notation_gen loc ntn + (fun (loc,ntn,l,bl) -> CAst.make ?loc @@ CNotation (ntn,(l,[],bl,[]))) + (fun (loc,p) -> CAst.make ?loc @@ CPrim p) + destPrim terms binders + +let make_pat_notation ?loc ntn (terms,termlists as subst) args = + if not (List.is_empty termlists) then (CAst.make ?loc @@ CPatNotation (ntn,subst,args)) else + make_notation_gen loc ntn + (fun (loc,ntn,l,_) -> CAst.make ?loc @@ CPatNotation (ntn,(l,[]),args)) + (fun (loc,p) -> CAst.make ?loc @@ CPatPrim p) + destPatPrim terms [] + +let mkPat ?loc qid l = CAst.make ?loc @@ + (* Normally irrelevant test with v8 syntax, but let's do it anyway *) + if List.is_empty l then CPatAtom (Some qid) else CPatCstr (qid,None,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 (Global.env()) 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 (custom,scopes as allscopes) vars pat = + try + if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; + let (na,sc,p) = uninterp_prim_token_cases_pattern pat in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + match availability_of_prim_token p sc scopes with + | None -> raise No_match + | Some key -> + let loc = cases_pattern_loc pat in + insert_pat_coercion ?loc coercion + (insert_pat_alias ?loc (insert_pat_delimiters ?loc (CAst.make ?loc @@ CPatPrim p) key) na) + with No_match -> + try + if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; + extern_notation_pattern allscopes [] vars pat + (uninterp_cases_pattern_notations scopes pat) + with No_match -> + let loc = pat.CAst.loc in + match DAst.get pat with + | PatVar (Name id) when entry_has_ident custom -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | pat -> + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + let allscopes = (InConstrEntrySomeLevel,scopes) in + let pat = match pat with + | PatVar (Name id) -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | PatVar (Anonymous) -> CAst.make ?loc (CPatAtom None) + | PatCstr(cstrsp,args,na) -> + let args = List.map (extern_cases_pattern_in_scope allscopes 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, args with + | [], [] -> acc + | proj :: q, pat :: tail -> + let acc = + match proj, pat with + | _, { CAst.v = CPatAtom None } -> + (* we don't want to have 'x := _' in our patterns *) + acc + | Some c, _ -> + ((extern_reference ?loc Id.Set.empty (ConstRef c), pat) :: acc) + | _ -> raise No_match in + ip q tail acc + | _ -> assert false + in + CPatRecord(List.rev (ip projs args [])) + with + Not_found | No_match | Exit -> + let c = extern_reference Id.Set.empty (ConstructRef cstrsp) in + if Constrintern.get_asymmetric_patterns () then + if pattern_printable_in_both_syntax cstrsp + then CPatCstr (c, None, args) + else CPatCstr (c, Some (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 (c, None, true_args) + | None -> CPatCstr (c, Some full_args, []) + in + insert_pat_alias ?loc (CAst.make ?loc p) na + in + insert_pat_coercion coercion pat + +and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) + (custom, (tmp_scope, scopes) as allscopes) lonely_seen vars = + function + | NotationRule (sc,ntn),key,need_delim -> + begin + match availability_of_entry_coercion custom (fst ntn) with + | None -> raise No_match + | Some coercion -> + let key = if need_delim || List.mem ntn lonely_seen then key else None in + let scopt = match key with Some _ -> sc | _ -> None in + let scopes' = Option.List.cons scopt scopes in + let l = + List.map (fun (c,(subentry,(scopt,scl))) -> + extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars c) + subst in + let ll = + List.map (fun (c,(subentry,(scopt,scl))) -> + let subscope = (subentry,(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 Constrintern.get_asymmetric_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 + insert_pat_coercion coercion + (insert_pat_delimiters ?loc + (make_pat_notation ?loc ntn (l,ll) l2') key) + end + | SynDefRule kn,key,need_delim -> + assert (key = None && need_delim = false); + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + let qid = Nametab.shortest_qualid_of_syndef ?loc vars kn in + let l1 = + List.rev_map (fun (c,(subentry,(scopt,scl))) -> + extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes)) vars c) + subst in + let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in + let l2' = if Constrintern.get_asymmetric_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); + insert_pat_coercion ?loc coercion (mkPat ?loc qid (List.rev_append l1 l2')) +and extern_notation_pattern allscopes lonely_seen vars t = function + | [] -> raise No_match + | (keyrule,pat,n as _rule,key,need_delim)::rules -> + try + if is_inactive_rule keyrule then raise No_match; + let loc = t.loc in + match DAst.get t with + | PatCstr (cstr,args,na) -> + let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in + let p = apply_notation_to_pattern ?loc (ConstructRef cstr) + (match_notation_constr_cases_pattern t pat) allscopes lonely_seen vars + (keyrule,key,need_delim) in + insert_pat_alias ?loc p na + | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None + | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident ?loc id)) + with + No_match -> + let lonely_seen = add_lonely keyrule lonely_seen in + extern_notation_pattern allscopes lonely_seen vars t rules + +let rec extern_notation_ind_pattern allscopes lonely_seen vars ind args = function + | [] -> raise No_match + | (keyrule,pat,n as _rule,key,need_delim)::rules -> + try + if is_inactive_rule keyrule then raise No_match; + apply_notation_to_pattern (IndRef ind) + (match_notation_constr_ind_pattern ind args pat) allscopes lonely_seen vars (keyrule,key,need_delim) + with + No_match -> + let lonely_seen = add_lonely keyrule lonely_seen in + extern_notation_ind_pattern allscopes lonely_seen vars ind args rules + +let extern_ind_pattern_in_scope (custom,scopes as allscopes) 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 (Global.env()) ind then + let c = extern_reference vars (IndRef ind) in + let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in + CAst.make @@ CPatCstr (c, Some (add_patt_for_params ind args), []) + else + try + if !Flags.raw_print || !print_no_symbol then raise No_match; + extern_notation_ind_pattern allscopes [] vars ind args + (uninterp_ind_pattern_notations scopes ind) + with No_match -> + let c = extern_reference vars (IndRef ind) in + let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in + match drop_implicits_in_patt (IndRef ind) 0 args with + |Some true_args -> CAst.make @@ CPatCstr (c, None, true_args) + |None -> CAst.make @@ CPatCstr (c, Some args, []) + +let extern_cases_pattern vars p = + extern_cases_pattern_in_scope (InConstrEntrySomeLevel,(None,[])) vars p + +(**********************************************************************) +(* Externalising applications *) + +let occur_name na aty = + match na with + | Name id -> occur_var_constr_expr id aty + | Anonymous -> false + +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + +let is_projection nargs = function + | 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 Some n + else None + with Not_found -> None) + | _ -> None + +let is_hole = function CHole _ | CEvar _ -> true | _ -> false + +let is_significant_implicit a = + not (is_hole (a.CAst.v)) + +let is_needed_for_correct_partial_application tail imp = + List.is_empty tail && not (maximal_insertion_of imp) + +exception Expl + +(* Implicit args indexes are in ascending order *) +(* inctx is useful only if there is a last argument to be deduced from ctxt *) +let explicitize inctx impl (cf,f) args = + let impl = if !Constrintern.parsing_explicit then [] else impl in + let n = List.length args in + let rec exprec q = function + | a::args, imp::impl when is_status_implicit imp -> + let tail = exprec (q+1) (args,impl) in + let visible = + !Flags.raw_print || + (!print_implicits && !print_implicits_explicit_args) || + (is_needed_for_correct_partial_application tail imp) || + (!print_implicits_defensive && + (not (is_inferable_implicit inctx n imp) || !Flags.beautify) && + is_significant_implicit (Lazy.force a)) + in + if visible then + (Lazy.force a,Some (make @@ ExplByName (name_of_implicit imp))) :: tail + else + tail + | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl) + | args, [] -> List.map (fun a -> (Lazy.force a,None)) args (*In case of polymorphism*) + | [], (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 -> + (* Careful: It is possible to have declared implicits ending + before the principal argument *) + let is_impl = + try is_status_implicit (List.nth impl (i-1)) + with Failure _ -> false + in + if is_impl + then raise Expl + else + let (args1,args2) = List.chop i args in + let (impl1,impl2) = try List.chop i impl with Failure _ -> 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 ((ip,f),args1@args2) + | None -> + let args = exprec 1 (args,impl) in + if List.is_empty args then f.CAst.v else + match f.CAst.v with + | CApp (g,args') -> + (* may happen with notations for a prefix of an n-ary + application *) + CApp (g,args'@args) + | _ -> CApp ((None, f), args) in + try expl () + with Expl -> + let f',us = match f with { CAst.v = CRef (f,us) } -> f,us | _ -> assert false in + let ip = if !print_projections then ip else None in + CAppExpl ((ip, f', us), List.map Lazy.force args) + +let is_start_implicit = function + | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp + | [] -> false + +let extern_global impl f us = + if not !Constrintern.parsing_explicit && is_start_implicit impl + then + CAppExpl ((None, f, us), []) + else + CRef (f,us) + +let extern_app inctx impl (cf,f) us args = + if List.is_empty args then + (* If coming from a notation "Notation a := @b" *) + CAppExpl ((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 + let args = List.map Lazy.force args in + CAppExpl ((is_projection (List.length args) cf,f,us), args) + else + explicitize inctx impl (cf, CAst.make @@ CRef (f,us)) args + +let rec fill_arg_scopes args subscopes (entry,(_,scopes) as all) = match args, subscopes with +| [], _ -> [] +| a :: args, scopt :: subscopes -> + (a, (entry, (scopt, scopes))) :: fill_arg_scopes args subscopes all +| a :: args, [] -> + (a, (entry, (None, scopes))) :: fill_arg_scopes args [] all + +let extern_args extern env args = + let map (arg, argscopes) = lazy (extern argscopes env arg) in + List.map map args + +let match_coercion_app c = match DAst.get c with + | GApp (r, args) -> + begin match DAst.get r with + | GRef (r,_) -> Some (c.CAst.loc, r, 0, args) + | _ -> None + end + | _ -> 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 - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> + (* We skip a coercion *) + 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 + (* Don't flatten App's in case of funclass so that + (atomic) notations on [a] work; should be compatible + since printer does not care whether App's are + collapsed or not and notations with an implicit + coercion using funclass either would have already + 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 List.is_empty l then a' else DAst.make ?loc @@ GApp (a',l) + | _ -> c + with Not_found -> c) + | _ -> c + +let rec flatten_application c = match DAst.get c with + | GApp (f, l) -> + begin match DAst.get f with + | GApp(a,l') -> + let loc = c.CAst.loc in + flatten_application (DAst.make ?loc @@ GApp (a,l'@l)) + | _ -> c + end + | a -> c + +(**********************************************************************) +(* mapping glob_constr to numerals (in presence of coercions, choose the *) +(* one with no delimiter if possible) *) + +let extern_possible_prim_token (custom,scopes) r = + let (sc,n) = uninterp_prim_token r in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + match availability_of_prim_token n sc scopes with + | None -> raise No_match + | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + +let extern_possible extern r = + try Some (extern r) with No_match -> None + +let extern_optimal extern r r' = + let c = extern_possible extern r in + let c' = if r==r' then None else extern_possible extern r' in + match c,c' with + | Some n, (Some ({ CAst.v = CDelimiters _}) | None) | _, Some n -> n + | _ -> raise No_match + +(* Helper function for safe and optimal printing of primitive tokens *) +(* such as those for Int63 *) +let extern_prim_token_delimiter_if_required n key_n scope_n scopes = + match availability_of_prim_token n scope_n scopes with + | Some None -> CPrim n + | None -> CDelimiters(key_n, CAst.make (CPrim n)) + | Some (Some key) -> CDelimiters(key, CAst.make (CPrim n)) + +(**********************************************************************) +(* mapping decl *) + +let extended_glob_local_binder_of_decl loc = function + | (p,bk,None,t) -> GLocalAssum (p,bk,t) + | (p,bk,Some x, t) -> + match DAst.get t with + | GHole (_, IntroAnonymous, None) -> GLocalDef (p,bk,x,None) + | _ -> GLocalDef (p,bk,x,Some t) + +let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u) + +(**********************************************************************) +(* mapping glob_constr to constr_expr *) + +let extern_glob_sort = function + | GSProp -> GSProp + | 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 extern_ref vars ref us = + extern_global (select_stronger_impargs (implicits_of_global ref)) + (extern_reference vars ref) (extern_universes us) + +let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) + +let rec extern inctx (custom,scopes as allscopes) vars r = + let r' = remove_coercions inctx r in + try + if !Flags.raw_print || !print_no_symbol then raise No_match; + extern_optimal (extern_possible_prim_token allscopes) r r' + with No_match -> + try + let r'' = flatten_application r' in + if !Flags.raw_print || !print_no_symbol then raise No_match; + extern_optimal + (fun r -> extern_notation allscopes [] vars r (uninterp_notations scopes r)) + r r'' + with No_match -> + let loc = r'.CAst.loc in + match DAst.get r' with + | GRef (ref,us) when entry_has_global custom -> CAst.make ?loc (extern_ref vars ref us) + + | GVar id when entry_has_ident custom -> CAst.make ?loc (extern_var ?loc id) + + | c -> + + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + + let scopes = (InConstrEntrySomeLevel, scopes) in + let c = match c with + + (* The remaining cases are only for the constr entry *) + + | GRef (ref,us) -> extern_ref vars ref us + + | GVar id -> extern_var ?loc id + + | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, IntroAnonymous, None) + + | GEvar (n,l) -> + extern_evar n (List.map (on_snd (extern false allscopes vars)) l) + + | GPatVar kind -> + if !print_meta_as_hole then CHole (None, IntroAnonymous, None) else + (match kind with + | Evar_kinds.SecondOrderPatVar n -> CPatVar n + | Evar_kinds.FirstOrderPatVar n -> CEvar (n,[])) + + | GApp (f,args) -> + (match DAst.get f with + | GRef (ref,us) -> + let subscopes = find_arguments_scope ref in + let args = fill_arg_scopes args subscopes scopes in + begin + try + if !Flags.raw_print then raise Exit; + let cstrsp = match ref with ConstructRef c -> c | _ -> raise Not_found in + let struc = Recordops.lookup_structure (fst cstrsp) in + if PrintingRecord.active (fst cstrsp) then + () + else if PrintingConstructor.active (fst cstrsp) then + raise Exit + else if not (get_record_print ()) then + raise Exit; + let projs = struc.Recordops.s_PROJ in + let locals = struc.Recordops.s_PROJKIND in + let rec cut args n = + if Int.equal n 0 then args + else + match args with + | [] -> raise No_match + | _ :: t -> cut t (n - 1) in + let args = cut args struc.Recordops.s_EXPECTEDPARAM in + let rec ip projs locs args acc = + match projs with + | [] -> acc + | None :: q -> raise No_match + | Some c :: q -> + match locs with + | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") + | (_, false) :: locs' -> + (* we don't want to print locals *) + ip q locs' args acc + | (_, true) :: locs' -> + match args with + | [] -> raise No_match + (* we give up since the constructor is not complete *) + | (arg, scopes) :: tail -> + let head = extern true scopes vars arg in + ip q locs' tail ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc) + in + CRecord (List.rev (ip projs locals args [])) + with + | Not_found | No_match | Exit -> + let args = extern_args (extern true) vars args in + extern_app inctx + (select_stronger_impargs (implicits_of_global ref)) + (Some ref,extern_reference ?loc vars ref) (extern_universes us) args + end + + | _ -> + explicitize inctx [] (None,sub_extern false scopes vars f) + (List.map (fun c -> lazy (sub_extern true scopes vars c)) args)) + + | GLetIn (na,b,t,c) -> + CLetIn (make ?loc na,sub_extern false scopes vars b, + Option.map (extern_typ scopes vars) t, + extern inctx scopes (add_vname vars na) c) + + | GProd (na,bk,t,c) -> + let t = extern_typ scopes vars t in + factorize_prod scopes (add_vname vars na) na bk t c + + | GLambda (na,bk,t,c) -> + let t = extern_typ scopes vars t in + factorize_lambda inctx scopes (add_vname vars na) na bk t c + + | GCases (sty,rtntypopt,tml,eqns) -> + let vars' = + List.fold_right (Name.fold_right 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, DAst.get tm with + | Anonymous, GVar id -> + begin match rtntypopt with + | None -> None + | Some ntn -> + if occur_glob_constr id ntn then + Some (CAst.make Anonymous) + else None + end + | Anonymous, _ -> None + | Name id, GVar id' when Id.equal id id' -> None + | Name _, _ -> Some (CAst.make na) in + (sub_extern false scopes vars tm, + na', + Option.map (fun {CAst.loc;v=(ind,nal)} -> + let args = List.map (fun x -> DAst.make @@ PatVar x) nal in + let fullargs = add_cpatt_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) (factorize_eqns eqns) in + CCases (sty,rtntypopt',tml,eqns) + + | GLetTuple (nal,(na,typopt),tm,b) -> + CLetTuple (List.map CAst.make nal, + (Option.map (fun _ -> (make 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 (c,(na,typopt),b1,b2) -> + CIf (sub_extern false scopes vars c, + (Option.map (fun _ -> (CAst.make 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 (fk,idv,blv,tyv,bv) -> + 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 bl = List.map (extended_glob_local_binder_of_decl ?loc) bl in + let (assums,ids,bl) = extern_local_binder scopes vars bl in + let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in + let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in + let n = + match nv.(i) with + | None -> None + | Some x -> Some (CAst.make @@ CStructRec (CAst.make @@ Name.get_id (List.nth assums x))) + in + ((CAst.make fi), n, bl, extern_typ scopes vars0 ty, + extern false scopes vars1 def)) idv + in + CFix (CAst.(make ?loc idv.(n)), Array.to_list listdecl) + | GCoFix n -> + let listdecl = + Array.mapi (fun i fi -> + let bl = List.map (extended_glob_local_binder_of_decl ?loc) blv.(i) in + let (_,ids,bl) = extern_local_binder scopes vars bl in + let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in + let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in + ((CAst.make fi),bl,extern_typ scopes vars0 tyv.(i), + sub_extern false scopes vars1 bv.(i))) idv + in + CCoFix (CAst.(make ?loc idv.(n)),Array.to_list listdecl)) + + | GSort s -> CSort (extern_glob_sort s) + + | GHole (e,naming,_) -> CHole (Some e, naming, None) (* TODO: extern tactics. *) + + | GCast (c, c') -> + CCast (sub_extern true scopes vars c, + map_cast_type (extern_typ scopes vars) c') + + | GInt i -> + extern_prim_token_delimiter_if_required + (Numeral (SPlus, NumTok.int (Uint63.to_string i))) + "int63" "int63_scope" (snd scopes) + + in insert_coercion coercion (CAst.make ?loc c) + +and extern_typ (subentry,(_,scopes)) = + extern true (subentry,(Notation.current_type_scope_name (),scopes)) + +and sub_extern inctx (subentry,(_,scopes)) = extern inctx (subentry,(None,scopes)) + +and factorize_prod scopes vars na bk aty c = + let store, get = set_temporary_memory () in + match na, DAst.get c with + | Name id, GCases (Constr.LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) + when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> + (match get () with + | [{CAst.v=(ids,disj_of_patl,b)}] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in + let b = extern_typ scopes vars b in + let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in + let binder = CLocalPattern (make ?loc:c.loc (p,None)) in + (match b.v with + | CProdN (bl,b) -> CProdN (binder::bl,b) + | _ -> CProdN ([binder],b)) + | _ -> assert false) + | _, _ -> + let c = extern_typ scopes vars c in + match na, c.v with + | Name id, CProdN (CLocalAssum(nal,Default bk',ty)::bl,b) + when binding_kind_eq bk bk' && constr_expr_eq aty ty + && not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> + CProdN (CLocalAssum(make na::nal,Default bk,aty)::bl,b) + | _, CProdN (bl,b) -> + CProdN (CLocalAssum([make na],Default bk,aty)::bl,b) + | _, _ -> + CProdN ([CLocalAssum([make na],Default bk,aty)],c) + +and factorize_lambda inctx scopes vars na bk aty c = + let store, get = set_temporary_memory () in + match na, DAst.get c with + | Name id, GCases (Constr.LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) + when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> + (match get () with + | [{CAst.v=(ids,disj_of_patl,b)}] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in + let b = sub_extern inctx scopes vars b in + let p = mkCPatOr (List.map (extern_cases_pattern_in_scope scopes vars) disjpat) in + let binder = CLocalPattern (make ?loc:c.loc (p,None)) in + (match b.v with + | CLambdaN (bl,b) -> CLambdaN (binder::bl,b) + | _ -> CLambdaN ([binder],b)) + | _ -> assert false) + | _, _ -> + let c = sub_extern inctx scopes vars c in + match c.v with + | CLambdaN (CLocalAssum(nal,Default bk',ty)::bl,b) + when binding_kind_eq bk bk' && constr_expr_eq aty ty + && not (occur_name na ty) (* avoid na in ty escapes scope *) -> + CLambdaN (CLocalAssum(make na::nal,Default bk,aty)::bl,b) + | CLambdaN (bl,b) -> + CLambdaN (CLocalAssum([make na],Default bk,aty)::bl,b) + | _ -> + CLambdaN ([CLocalAssum([make na],Default bk,aty)],c) + +and extern_local_binder scopes vars = function + [] -> ([],[],[]) + | b :: l -> + match DAst.get b with + | GLocalDef (na,bk,bd,ty) -> + let (assums,ids,l) = + extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in + (assums,na::ids, + CLocalDef(CAst.make na, extern false scopes vars bd, + Option.map (extern false scopes vars) ty) :: l) + + | GLocalAssum (na,bk,ty) -> + let ty = extern_typ scopes vars ty in + (match extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l with + (assums,ids,CLocalAssum(nal,k,ty')::l) + when constr_expr_eq ty ty' && + match na with Name id -> not (occur_var_constr_expr id ty') + | _ -> true -> + (na::assums,na::ids, + CLocalAssum(CAst.make na::nal,k,ty')::l) + | (assums,ids,l) -> + (na::assums,na::ids, + CLocalAssum([CAst.make na],Default bk,ty) :: l)) + + | GLocalPattern ((p,_),_,bk,ty) -> + let ty = + if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in + let p = mkCPatOr (List.map (extern_cases_pattern vars) p) in + let (assums,ids,l) = extern_local_binder scopes vars l in + (assums,ids, CLocalPattern(CAst.make @@ (p,ty)) :: l) + +and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = + let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in + make ?loc (pll,extern inctx scopes vars c) + +and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function + | [] -> raise No_match + | (keyrule,pat,n as _rule,key,need_delim)::rules -> + let loc = Glob_ops.loc_of_glob_constr t in + try + if is_inactive_rule keyrule then raise No_match; + (* Adjusts to the number of arguments expected by the notation *) + let (t,args,argsscopes,argsimpls) = match DAst.get t ,n with + | GApp (f,args), Some n + when List.length args >= n -> + let args1, args2 = List.chop n args in + let subscopes, impls = + match DAst.get f with + | GRef (ref,us) -> + let subscopes = + 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 Failure _ -> [] in + subscopes,impls + | _ -> + [], [] in + (if Int.equal n 0 then f else DAst.make @@ GApp (f,args1)), + args2, subscopes, impls + | GApp (f, args), None -> + begin match DAst.get f with + | GRef (ref,us) -> + let subscopes = find_arguments_scope ref in + let impls = + select_impargs_size + (List.length args) (implicits_of_global ref) in + f, args, subscopes, impls + | _ -> t, [], [], [] + end + | GRef (ref,us), Some 0 -> DAst.make @@ GApp (t,[]), [], [], [] + | _, None -> t, [], [], [] + | _ -> raise No_match in + (* Try matching ... *) + let terms,termlists,binders,binderlists = + match_notation_constr !print_universes t pat in + (* Try availability of interpretation ... *) + let e = + match keyrule with + | NotationRule (sc,ntn) -> + (match availability_of_entry_coercion custom (fst ntn) with + | None -> raise No_match + | Some coercion -> + let key = if need_delim || List.mem ntn lonely_seen then key else None in + let scopt = match key with Some _ -> sc | None -> None in + let scopes' = Option.List.cons scopt (snd scopes) in + let l = + List.map (fun (c,(subentry,(scopt,scl))) -> + extern (* assuming no overloading: *) true + (subentry,(scopt,scl@scopes')) vars c) + terms in + let ll = + List.map (fun (c,(subentry,(scopt,scl))) -> + List.map (extern true (subentry,(scopt,scl@scopes')) vars) c) + termlists in + let bl = + List.map (fun (bl,(subentry,(scopt,scl))) -> + mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)) + binders in + let bll = + List.map (fun (bl,(subentry,(scopt,scl))) -> + pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) + binderlists in + insert_coercion coercion (insert_delimiters (make_notation loc ntn (l,ll,bl,bll)) key)) + | SynDefRule kn -> + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + let l = + List.map (fun (c,(subentry,(scopt,scl))) -> + extern true (subentry,(scopt,scl@snd scopes)) vars c, None) + terms in + let a = CRef (Nametab.shortest_qualid_of_syndef ?loc vars kn,None) in + insert_coercion coercion (CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l)) in + if List.is_empty args then e + else + let args = fill_arg_scopes args argsscopes allscopes in + let args = extern_args (extern true) vars args in + CAst.make ?loc @@ explicitize false argsimpls (None,e) args + with + No_match -> + let lonely_seen = add_lonely keyrule lonely_seen in + extern_notation allscopes lonely_seen vars t rules + +let extern_glob_constr vars c = + extern false (InConstrEntrySomeLevel,(None,[])) vars c + +let extern_glob_type vars c = + extern_typ (InConstrEntrySomeLevel,(None,[])) vars c + +(******************************************************************) +(* Main translation function from constr -> constr_expr *) + +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 *) + (* bound variables. *) + (* Not "goal_concl_style" means do alpha-conversion avoiding only *) + (* 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 vars_of_env env else Id.Set.empty in + let r = Detyping.detype Detyping.Later ~lax:lax goal_concl_style avoid env sigma t in + let vars = vars_of_env env in + extern false (InConstrEntrySomeLevel,(scopt,[])) vars r + +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 ?(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 sigma t = + let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in + let r = Detyping.detype Detyping.Later goal_concl_style avoid env sigma t in + extern_glob_type (vars_of_env env) r + +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 vars_of_env env else Id.Set.empty 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 (InConstrEntrySomeLevel,(None,[])) vars r + +(******************************************************************) +(* Main translation function from pattern -> constr_expr *) + +let any_any_branch = + (* | _ => _ *) + CAst.make ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,IntroAnonymous,None)) + +let compute_displayed_name_in_pattern sigma avoid na c = + let open Namegen in + compute_displayed_name_in_gen (fun _ -> Patternops.noccurn_pattern) sigma avoid na c + +let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with + | PRef ref -> GRef (ref,None) + | PVar id -> GVar id + | PEvar (evk,l) -> + let test decl = function PVar id' -> Id.equal (NamedDecl.get_id decl) id' | _ -> false in + let l = Evd.evar_instance_array test (Evd.find sigma evk) l in + let id = match Evd.evar_ident evk sigma with + | None -> Id.of_string "__" + | Some id -> id + in + GEvar (id,List.map (on_snd (glob_of_pat avoid env sigma)) l) + | PRel n -> + let id = try match lookup_name_of_rel n env with + | Name id -> id + | Anonymous -> + 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 id + | PMeta None -> GHole (Evar_kinds.InternalHole, IntroAnonymous,None) + | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) + | PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None), + [glob_of_pat avoid env sigma c]) + | PApp (f,args) -> + GApp (glob_of_pat avoid env sigma f,Array.map_to_list (glob_of_pat avoid env sigma) args) + | PSoApp (n,args) -> + GApp (DAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), + List.map (glob_of_pat avoid env sigma) args) + | PProd (na,t,c) -> + let na',avoid' = compute_displayed_name_in_pattern sigma avoid na c in + let env' = Termops.add_name na' env in + GProd (na',Explicit,glob_of_pat avoid env sigma t,glob_of_pat avoid' env' sigma c) + | PLetIn (na,b,t,c) -> + let na',avoid' = Namegen.compute_displayed_let_name_in sigma Namegen.RenamingForGoal avoid na c in + let env' = Termops.add_name na' env in + GLetIn (na',glob_of_pat avoid env sigma b, Option.map (glob_of_pat avoid env sigma) t, + glob_of_pat avoid' env' sigma c) + | PLambda (na,t,c) -> + let na',avoid' = compute_displayed_name_in_pattern sigma avoid na c in + let env' = Termops.add_name na' env in + GLambda (na',Explicit,glob_of_pat avoid env sigma t, glob_of_pat avoid' env' sigma c) + | PIf (c,b1,b2) -> + GIf (glob_of_pat avoid env sigma c, (Anonymous,None), + glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2) + | PCase ({cip_style=Constr.LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> + let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in + GLetTuple (nal,(Anonymous,None),glob_of_pat avoid 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 avoid env sigma c)) bl in + simple_cases_matrix_of_branches ind bl' + | _, 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_tags with + | PMeta None, _, _ -> (Anonymous,None),None + | _, Some ind, Some nargs -> + return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) + | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") + in + GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) + | PFix ((ln,i),(lna,tl,bl)) -> + let def_avoid, def_env, lfi = + Array.fold_left + (fun (avoid, env, l) na -> + let id = Namegen.next_name_away na avoid in + (Id.Set.add id avoid, Name id :: env, id::l)) + (avoid, env, []) lna in + let n = Array.length tl in + let v = Array.map3 + (fun c t i -> Detyping.share_pattern_names glob_of_pat (i+1) [] def_avoid def_env sigma c (Patternops.lift_pattern n t)) + bl tl ln in + GRec(GFix (Array.map (fun i -> Some i) ln,i),Array.of_list (List.rev lfi), + Array.map (fun (bl,_,_) -> bl) v, + Array.map (fun (_,_,ty) -> ty) v, + Array.map (fun (_,bd,_) -> bd) v) + | PCoFix (ln,(lna,tl,bl)) -> + let def_avoid, def_env, lfi = + Array.fold_left + (fun (avoid, env, l) na -> + let id = Namegen.next_name_away na avoid in + (Id.Set.add id avoid, Name id :: env, id::l)) + (avoid, env, []) lna in + let ntys = Array.length tl in + let v = Array.map2 + (fun c t -> share_pattern_names glob_of_pat 0 [] def_avoid def_env sigma c (Patternops.lift_pattern ntys t)) + bl tl in + GRec(GCoFix ln,Array.of_list (List.rev lfi), + Array.map (fun (bl,_,_) -> bl) v, + Array.map (fun (_,_,ty) -> ty) v, + Array.map (fun (_,bd,_) -> bd) v) + | PSort Sorts.InSProp -> GSort GSProp + | PSort Sorts.InProp -> GSort GProp + | PSort Sorts.InSet -> GSort GSet + | PSort Sorts.InType -> GSort (GType []) + | PInt i -> GInt i + +let extern_constr_pattern env sigma pat = + extern true (InConstrEntrySomeLevel,(None,[])) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) + +let extern_rel_context where env sigma sign = + let a = detype_rel_context Detyping.Later where Id.Set.empty (names_of_rel_context env,env) sigma sign in + let vars = vars_of_env env in + let a = List.map (extended_glob_local_binder_of_decl) a in + pi3 (extern_local_binder (InConstrEntrySomeLevel,(None,[])) vars a) diff --git a/interp/constrextern.mli b/interp/constrextern.mli new file mode 100644 index 0000000000..f09b316cd6 --- /dev/null +++ b/interp/constrextern.mli @@ -0,0 +1,96 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Termops +open EConstr +open Environ +open Libnames +open Glob_term +open Pattern +open Constrexpr +open Notation_term +open Notation +open Ltac_pretype + +(** Translation of pattern, cases pattern, glob_constr and term into syntax + trees for printing *) + +val extern_cases_pattern : Id.Set.t -> 'a cases_pattern_g -> cases_pattern_expr +val extern_glob_constr : Id.Set.t -> 'a glob_constr_g -> constr_expr +val extern_glob_type : Id.Set.t -> 'a glob_constr_g -> 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. + ~lax is for debug printing, when the constr might not be well typed in + env, sigma +*) + +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:Loc.t -> Id.Set.t -> GlobRef.t -> qualid +val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr +val extern_sort : Evd.evar_map -> Sorts.t -> glob_sort +val extern_rel_context : constr option -> env -> Evd.evar_map -> + rel_context -> local_binder_expr list + +(** Printing options *) +val print_implicits : bool ref +val print_implicits_defensive : bool ref +val print_arguments : bool ref +val print_evar_arguments : bool ref +val print_coercions : bool ref +val print_universes : bool ref +val print_no_symbol : bool ref +val print_projections : bool ref + +(** Customization of the global_reference printer *) +val set_extern_reference : + (?loc:Loc.t -> Id.Set.t -> GlobRef.t -> qualid) -> unit +val get_extern_reference : + unit -> (?loc:Loc.t -> Id.Set.t -> GlobRef.t -> qualid) + +(** WARNING: The following functions are evil due to + side-effects. Think of the following case as used in the printer: + + without_specific_symbols [SynDefRule kn] (pr_glob_constr_env env) c + + vs + + without_specific_symbols [SynDefRule kn] pr_glob_constr_env env c + + which one is wrong? We should turn this kind of state into an + explicit argument. +*) + +(** This forces printing universe names of Type\{.\} *) +val with_universes : ('a -> 'b) -> 'a -> 'b + +(** 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 + +(** Fine-grained activation and deactivation of notation printing. + *) +val toggle_scope_printing : + scope:Notation_term.scope_name -> activate:bool -> unit + +val toggle_notation_printing : + ?scope:Notation_term.scope_name -> notation:Constrexpr.notation -> activate:bool -> unit + + diff --git a/interp/constrintern.ml b/interp/constrintern.ml new file mode 100644 index 0000000000..c0801067ce --- /dev/null +++ b/interp/constrintern.ml @@ -0,0 +1,2465 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open CAst +open Names +open Nameops +open Namegen +open Constr +open Context +open Libnames +open Globnames +open Impargs +open Glob_term +open Glob_ops +open Patternops +open Pretyping +open Cases +open Constrexpr +open Constrexpr_ops +open Notation_term +open Notation_ops +open Notation +open Inductiveops +open Decl_kinds +open Context.Rel.Declaration + +(** constr_expr -> glob_constr translation: + - it adds holes for implicit arguments + - it replaces notations by their value (scopes stuff are here) + - it recognizes global vars from local ones + - it prepares pattern matching 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 Id.t list (* list of params *) * bool (* true = check for possible capture *) + | Recursive + | Method + | Variable + +type var_internalization_data = + (* type of the "free" variable, for coqdoc, e.g. while typing the + constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) + 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) *) + 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) Id.Map.t + +type ltac_sign = { + ltac_vars : Id.Set.t; + ltac_bound : Id.Set.t; + ltac_extra : Genintern.Store.t; +} + +let interning_grammar = ref false + +(* Historically for parsing grammar rules, but in fact used only for + translator, v7 parsing, and unstrict tactic internalization *) +let for_grammar f x = + interning_grammar := true; + let a = f x in + interning_grammar := false; + a + +(**********************************************************************) +(* Locating reference, possibly via an abbreviation *) + +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) + +let is_global id = + try + let _ = locate_reference (qualid_of_ident id) in true + with Not_found -> + false + +(**********************************************************************) +(* Internalization errors *) + +type internalization_error = + | VariableCapture of Id.t * Id.t + | IllegalMetavariable + | NotAConstructor of qualid + | UnboundFixName of bool * Id.t + | NonLinearPattern of Id.t + | BadPatternsNumber of int * int + | NotAProjection of qualid + | NotAProjectionOf of qualid * qualid + | ProjectionsOfDifferentRecords of qualid * qualid + +exception InternalizationError of internalization_error Loc.located + +let explain_variable_capture id id' = + Id.print id ++ str " is dependent in the type of " ++ Id.print id' ++ + strbrk ": cannot interpret both of them with the same type" + +let explain_illegal_metavariable = + str "Metavariables allowed only in patterns" + +let explain_not_a_constructor qid = + str "Unknown constructor: " ++ pr_qualid qid + +let explain_unbound_fix_name is_cofix id = + str "The name" ++ spc () ++ Id.print id ++ + spc () ++ str "is not bound in the corresponding" ++ spc () ++ + str (if is_cofix then "co" else "") ++ str "fixpoint definition" + +let explain_non_linear_pattern id = + str "The variable " ++ Id.print id ++ str " is bound several times in pattern" + +let explain_bad_patterns_number n1 n2 = + str "Expecting " ++ int n1 ++ str (String.plural n1 " pattern") ++ + str " but found " ++ int n2 + +let explain_field_not_a_projection field_id = + pr_qualid field_id ++ str ": Not a projection" + +let explain_field_not_a_projection_of field_id inductive_id = + pr_qualid field_id ++ str ": Not a projection of inductive " ++ pr_qualid inductive_id + +let explain_projections_of_diff_records inductive1_id inductive2_id = + str "This record contains fields of both " ++ pr_qualid inductive1_id ++ + str " and " ++ pr_qualid inductive2_id + +let explain_internalization_error e = + let pp = match e with + | 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 + | NotAProjection field_id -> explain_field_not_a_projection field_id + | NotAProjectionOf (field_id, inductive_id) -> + explain_field_not_a_projection_of field_id inductive_id + | ProjectionsOfDifferentRecords (inductive1_id, inductive2_id) -> + explain_projections_of_diff_records inductive1_id inductive2_id + in pp ++ str "." + +let error_bad_inductive_type ?loc = + user_err ?loc (str + "This should be an inductive type applied to patterns.") + +let error_parameter_not_implicit ?loc = + user_err ?loc (str + "The parameters do not bind in patterns;" ++ spc () ++ str + "they must be replaced by '_'.") + +let error_ldots_var ?loc = + user_err ?loc (str "Special token " ++ Id.print ldots_var ++ + str " is for use in the Notation command.") + +(**********************************************************************) +(* Pre-computing the implicit arguments and arguments scopes needed *) +(* for interpretation *) + +let parsing_explicit = ref false + +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.filter is_status_implicit sub_impl in + List.map name_of_implicit sub_impl' + | Recursive | Method | Variable -> + (* Unable to know in advance what the implicit arguments will be *) + [] + +let compute_internalization_data env sigma ty typ impl = + let impl = compute_implicits_with_manual env sigma typ (is_implicit_args()) impl in + let expls_impl = compute_explicitable_implicit impl ty in + (ty, expls_impl, impl, compute_arguments_scope sigma typ) + +let compute_internalization_env env sigma ?(impls=empty_internalization_env) ty = + List.fold_left3 + (fun map id typ impl -> Id.Map.add id (compute_internalization_data env sigma ty typ impl) map) + impls + +(**********************************************************************) +(* Contracting "{ _ }" in notations *) + +let rec wildcards ntn n = + 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 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 Int.equal pos 0 then "" else String.sub ntn 0 pos in + let tl = + if Int.equal pos (String.length ntn) then "" + else String.sub ntn (pos+1) (String.length ntn - pos -1) in + hd ^ "{ _ }" ^ tl + +(* This contracts the special case of "{ _ }" for sumbool, sumor notations *) +(* Remark: expansion of squash at definition is done in metasyntax.ml *) +let contract_curly_brackets ntn (l,ll,bl,bll) = + match ntn with + | InCustomEntryLevel _,_ -> ntn,(l,ll,bl,bll) + | InConstrEntrySomeLevel, ntn -> + let ntn' = ref ntn in + let rec contract_squash n = function + | [] -> [] + | { CAst.v = CNotation ((InConstrEntrySomeLevel,"{ _ }"),([a],[],[],[])) } :: l -> + ntn' := expand_notation_string !ntn' n; + contract_squash n (a::l) + | a :: l -> + a::contract_squash (n+1) l in + let l = contract_squash 0 l in + (* side effect; don't inline *) + (InConstrEntrySomeLevel,!ntn'),(l,ll,bl,bll) + +let contract_curly_brackets_pat ntn (l,ll) = + match ntn with + | InCustomEntryLevel _,_ -> ntn,(l,ll) + | InConstrEntrySomeLevel, ntn -> + let ntn' = ref ntn in + let rec contract_squash n = function + | [] -> [] + | { CAst.v = CPatNotation ((InConstrEntrySomeLevel,"{ _ }"),([a],[]),[]) } :: l -> + ntn' := expand_notation_string !ntn' n; + contract_squash n (a::l) + | a :: l -> + a::contract_squash (n+1) l in + let l = contract_squash 0 l in + (* side effect; don't inline *) + (InConstrEntrySomeLevel,!ntn'),(l,ll) + +type intern_env = { + ids: Names.Id.Set.t; + unb: bool; + 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 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" + | [a] -> str "scope " ++ str a + | l -> str "scope stack " ++ + str "[" ++ prlist_with_sep pr_comma str l ++ str "]" + +let error_inconsistent_scope ?loc id scopes1 scopes2 = + user_err ?loc ~hdr:"set_var_scope" + (Id.print id ++ str " is here used in " ++ + pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++ + pr_scope_stack scopes1) + +let error_expect_binder_notation_type ?loc id = + user_err ?loc + (Id.print id ++ + str " is expected to occur in binding position in the right-hand side.") + +let set_var_scope ?loc id istermvar (tmp_scope,subscopes as scopes) ntnvars = + try + let used_as_binder,idscopes,typ = Id.Map.find id ntnvars in + if not istermvar then used_as_binder := true; + let () = if istermvar then + (* scopes have no effect on the interpretation of identifiers *) + begin match !idscopes with + | None -> idscopes := Some scopes + | Some (tmp_scope', subscopes') -> + let s' = make_current_scope tmp_scope' subscopes' in + let s = make_current_scope tmp_scope subscopes in + if not (List.equal String.equal s' s) then error_inconsistent_scope ?loc id s' s + end + in + match typ with + | Notation_term.NtnInternTypeOnlyBinder -> + if istermvar then error_expect_binder_notation_type ?loc id + | Notation_term.NtnInternTypeAny -> () + with Not_found -> + (* Not in a notation *) + () + +let set_type_scope env = {env with tmp_scope = Notation.current_type_scope_name ()} + +let reset_tmp_scope env = {env with tmp_scope = None} + +let set_env_scopes env (scopt,subscopes) = + {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} + +let mkGProd ?loc (na,bk,t) body = DAst.make ?loc @@ GProd (na, bk, t, body) +let mkGLambda ?loc (na,bk,t) body = DAst.make ?loc @@ GLambda (na, bk, t, body) + +(**********************************************************************) +(* Utilities for binders *) +let build_impls = function + |Implicit -> (function + |Name id -> Some (id, Impargs.Manual, (true,true)) + |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) + |Explicit -> fun _ -> None + +let impls_type_list ?(args = []) = + let rec aux acc c = match DAst.get c with + | GProd (na,bk,_,c) -> aux ((build_impls bk na)::acc) c + | _ -> (Variable,[],List.append args (List.rev acc),[]) + in aux [] + +let impls_term_list ?(args = []) = + let rec aux acc c = match DAst.get c with + | GLambda (na,bk,_,c) -> aux ((build_impls bk na)::acc) c + | GRec (fix_kind, nas, args, tys, bds) -> + let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in + let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in + aux acc' bds.(nb) + |_ -> (Variable,[],List.append args (List.rev acc),[]) + in aux [] + +(* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) +let rec check_capture ty = let open CAst in function + | { loc; v = Name id } :: { v = Name id' } :: _ when occur_glob_constr id ty -> + raise (InternalizationError (loc,VariableCapture (id,id'))) + | _::nal -> + check_capture ty nal + | [] -> + () + +let locate_if_hole ?loc na c = match DAst.get c with + | GHole (_,naming,arg) -> + (try match na with + | Name id -> glob_constr_of_notation_constr ?loc + (Reserve.find_reserved_type id) + | Anonymous -> raise Not_found + with Not_found -> DAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) + | _ -> c + +let reset_hidden_inductive_implicit_test env = + { env with impls = Id.Map.map (function + | (Inductive (params,_),b,c,d) -> (Inductive (params,false),b,c,d) + | x -> x) env.impls } + +let check_hidden_implicit_parameters ?loc id impls = + if Id.Map.exists (fun _ -> function + | (Inductive (indparams,check),_,_,_) when check -> Id.List.mem id indparams + | _ -> false) impls + then + user_err ?loc (Id.print id ++ strbrk " is already used as name of " ++ + strbrk "a parameter of the inductive type; bound variables in " ++ + strbrk "the type of a constructor shall use a different name.") + +let push_name_env ?(global_level=false) ntnvars implargs env = + let open CAst in + function + | { loc; v = Anonymous } -> + if global_level then + user_err ?loc (str "Anonymous variables not allowed"); + env + | { loc; v = Name id } -> + check_hidden_implicit_parameters ?loc id env.impls ; + if Id.Map.is_empty ntnvars && Id.equal id ldots_var + then error_ldots_var ?loc; + set_var_scope ?loc id false (env.tmp_scope,env.scopes) ntnvars; + if global_level then Dumpglob.dump_definition CAst.(make ?loc id) true "var" + else Dumpglob.dump_binding ?loc id; + {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 ntnvars + env {loc;v=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 + Implicit_quantifiers.combine_params_freevar ty + in + let ty' = intern_type {env with ids = ids; unb = true} ty in + let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in + let env' = List.fold_left + (fun env {loc;v=x} -> push_name_env ~global_level ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) + env fvs in + let bl = List.map + CAst.(map (fun id -> + (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) + fvs + in + let na = match na with + | Anonymous -> + if global_level then na + else + let name = + let id = + match ty with + | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> + qualid_basename qid + | _ -> default_non_dependent_ident + in Implicit_quantifiers.make_fresh ids' (Global.env ()) id + in Name name + | _ -> na + in (push_name_env ~global_level ntnvars (impls_type_list ty')(*?*) env' (make ?loc na)), (make ?loc (na,b',ty')) :: List.rev bl + +let intern_assumption intern ntnvars 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;v=na} as locna) -> + (push_name_env ntnvars impls env locna, + (make ?loc (na,k,locate_if_hole ?loc na ty))::bl)) + (env, []) nal + | Generalized (b,b',t) -> + let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b b' t ty in + env, b + +let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function + | GLocalAssum (na,bk,t) -> (na,bk,None,t) + | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) + | GLocalDef (na,bk,c,None) -> + let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,IntroAnonymous,None) in + (na,bk,Some c,t) + | GLocalPattern (_,_,_,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here") + ) + +let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd") + +let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = + let term = intern env def in + let ty = Option.map (intern env) ty in + (push_name_env ntnvars (impls_term_list term) env locna, + (na,Explicit,term,ty)) + +let intern_cases_pattern_as_binder ?loc ntnvars env p = + let il,disjpat = + let (il, subst_disjpat) = !intern_cases_pattern_fwd ntnvars (None,env.scopes) p in + let substl,disjpat = List.split subst_disjpat in + if not (List.for_all (fun subst -> Id.Map.equal Id.equal subst Id.Map.empty) substl) then + user_err ?loc (str "Unsupported nested \"as\" clause."); + il,disjpat + in + let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars (Variable,[],[],[]) env (make ?loc @@ Name id)) il env in + let na = alias_of_pat (List.hd disjpat) in + let ienv = Name.fold_right Id.Set.remove na env.ids in + let id = Namegen.next_name_away_with_default "pat" na ienv in + let na = make ?loc @@ Name id in + env,((disjpat,il),id),na + +let intern_local_binder_aux ?(global_level=false) intern ntnvars (env,bl) = function + | CLocalAssum(nal,bk,ty) -> + let env, bl' = intern_assumption intern ntnvars env nal bk ty in + let bl' = List.map (fun {loc;v=(na,c,t)} -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in + env, bl' @ bl + | CLocalDef( {loc; v=na} as locna,def,ty) -> + let env,(na,bk,def,ty) = intern_letin_binder intern ntnvars env (locna,def,ty) in + env, (DAst.make ?loc @@ GLocalDef (na,bk,def,ty)) :: bl + | CLocalPattern {loc;v=(p,ty)} -> + let tyc = + match ty with + | Some ty -> ty + | None -> CAst.make ?loc @@ CHole(None,IntroAnonymous,None) + in + let env, ((disjpat,il),id),na = intern_cases_pattern_as_binder ?loc ntnvars env p in + let bk = Default Explicit in + let _, bl' = intern_assumption intern ntnvars env [na] bk tyc in + let {v=(_,bk,t)} = List.hd bl' in + (env, (DAst.make ?loc @@ GLocalPattern((disjpat,List.map (fun x -> x.v) il),id,bk,t)) :: bl) + +let intern_generalization intern env ntnvars 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 + | Some AbsPi -> true + | Some _ -> false + | None -> + match Notation.current_type_scope_name () with + | Some type_scope -> + let is_type_scope = match env.tmp_scope with + | None -> false + | Some sc -> String.equal sc type_scope + in + is_type_scope || + String.List.mem type_scope env.scopes + | None -> false + in + if pi then + (fun {loc=loc';v=id} acc -> + DAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GProd (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) + else + (fun {loc=loc';v=id} acc -> + DAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) + in + List.fold_right (fun ({loc;v=id} as lid) (env, acc) -> + let env' = push_name_env ntnvars (Variable,[],[],[]) env CAst.(make @@ Name id) in + (env', abs lid acc)) fvs (env,c) + in c' + +let rec expand_binders ?loc mk bl c = + match bl with + | [] -> c + | b :: bl -> + match DAst.get b with + | GLocalDef (n, bk, b, oty) -> + expand_binders ?loc mk bl (DAst.make ?loc @@ GLetIn (n, b, oty, c)) + | GLocalAssum (n, bk, t) -> + expand_binders ?loc mk bl (mk ?loc (n,bk,t) c) + | GLocalPattern ((disjpat,ids), id, bk, ty) -> + let tm = DAst.make ?loc (GVar id) in + (* Distribute the disjunctive patterns over the shared right-hand side *) + let eqnl = List.map (fun pat -> CAst.make ?loc (ids,[pat],c)) disjpat in + let c = DAst.make ?loc @@ GCases (LetPatternStyle, None, [tm,(Anonymous,None)], eqnl) in + expand_binders ?loc mk bl (mk ?loc (Name id,Explicit,ty) c) + +(**********************************************************************) +(* Syntax extensions *) + +let option_mem_assoc id = function + | Some (id',c) -> Id.equal id id' + | None -> false + +let find_fresh_name renaming (terms,termlists,binders,binderlists) 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 *) + next_ident_away_from id (fun id -> Id.Set.mem id fvs3) + +let is_patvar c = + match DAst.get c with + | PatVar _ -> true + | _ -> false + +let is_patvar_store store pat = + match DAst.get pat with + | PatVar na -> ignore(store na); true + | _ -> false + +let out_patvar pat = + match pat.v with + | CPatAtom (Some qid) when qualid_is_ident qid -> + Name (qualid_basename qid) + | CPatAtom None -> Anonymous + | _ -> assert false + +let term_of_name = function + | Name id -> DAst.make (GVar id) + | Anonymous -> + let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in + DAst.make (GHole (Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=st }, IntroAnonymous, None)) + +let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) = function + | Anonymous -> (renaming,env), None, Anonymous + | Name id -> + let store,get = set_temporary_memory () in + try + (* We instantiate binder name with patterns which may be parsed as terms *) + let pat = coerce_to_cases_pattern_expr (fst (Id.Map.find id terms)) in + let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + let pat, na = match disjpat with + | [pat] when is_patvar_store store pat -> let na = get () in None, na + | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in + (renaming,env), pat, na + with Not_found -> + try + (* Trying to associate a pattern *) + let pat,(onlyident,scopes) = Id.Map.find id binders in + let env = set_env_scopes env scopes in + if onlyident then + (* Do not try to interpret a variable as a constructor *) + let na = out_patvar pat in + let env = push_name_env ntnvars (Variable,[],[],[]) env (make ?loc:pat.loc na) in + (renaming,env), None, na + else + (* Interpret as a pattern *) + let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + let pat, na = + match disjpat with + | [pat] when is_patvar_store store pat -> let na = get () in None, na + | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in + (renaming,env), pat, 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 avoid id in + let renaming' = + if Id.equal id id' then renaming else Id.Map.add id id' renaming + in + (renaming',env), None, Name id' + +type binder_action = +| AddLetIn of lname * constr_expr * constr_expr option +| AddTermIter of (constr_expr * subscopes) Names.Id.Map.t +| AddPreBinderIter of Id.t * local_binder_expr (* A binder to be internalized *) +| AddBinderIter of Id.t * extended_glob_local_binder (* A binder already internalized - used for generalized binders *) + +let dmap_with_loc f n = + CAst.map_with_loc (fun ?loc c -> f ?loc (DAst.get_thunk c)) n + +let error_cannot_coerce_wildcard_term ?loc () = + user_err ?loc Pp.(str "Cannot turn \"_\" into a term.") + +let error_cannot_coerce_disjunctive_pattern_term ?loc () = + user_err ?loc Pp.(str "Cannot turn a disjunctive pattern into a term.") + +let terms_of_binders bl = + let rec term_of_pat pt = dmap_with_loc (fun ?loc -> function + | PatVar (Name id) -> CRef (qualid_of_ident id, None) + | PatVar (Anonymous) -> error_cannot_coerce_wildcard_term ?loc () + | PatCstr (c,l,_) -> + let qid = qualid_of_path ?loc (Nametab.path_of_global (ConstructRef c)) in + let hole = CAst.make ?loc @@ CHole (None,IntroAnonymous,None) in + let params = List.make (Inductiveops.inductive_nparams (Global.env()) (fst c)) hole in + CAppExpl ((None,qid,None),params @ List.map term_of_pat l)) pt in + let rec extract_variables l = match l with + | bnd :: l -> + let loc = bnd.loc in + begin match DAst.get bnd with + | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None)) :: extract_variables l + | GLocalDef (Name id,_,_,_) -> extract_variables l + | GLocalDef (Anonymous,_,_,_) + | GLocalAssum (Anonymous,_,_) -> user_err Pp.(str "Cannot turn \"_\" into a term.") + | GLocalPattern (([u],_),_,_,_) -> term_of_pat u :: extract_variables l + | GLocalPattern ((_,_),_,_,_) -> error_cannot_coerce_disjunctive_pattern_term ?loc () + end + | [] -> [] in + extract_variables bl + +let flatten_generalized_binders_if_any y l = + match List.rev l with + | [] -> assert false + | a::l -> a, List.map (fun a -> AddBinderIter (y,a)) l (* if l not empty, this means we had a generalized binder *) + +let flatten_binders bl = + let dispatch = function + | CLocalAssum (nal,bk,t) -> List.map (fun na -> CLocalAssum ([na],bk,t)) nal + | a -> [a] in + List.flatten (List.map dispatch bl) + +let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = + let (terms,termlists,binders,binderlists) = 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,iteropt as subst') (renaming,env) c = + let subinfos = renaming,{env with tmp_scope = None} in + match c with + | NVar id when Id.equal id ldots_var -> + let rec aux_letin env = function + | [],terminator,_ -> aux (terms,None,None) (renaming,env) terminator + | AddPreBinderIter (y,binder)::rest,terminator,iter -> + let env,binders = intern_local_binder_aux intern ntnvars (env,[]) binder in + let binder,extra = flatten_generalized_binders_if_any y binders in + aux (terms,Some (y,binder),Some (extra@rest,terminator,iter)) (renaming,env) iter + | AddBinderIter (y,binder)::rest,terminator,iter -> + aux (terms,Some (y,binder),Some (rest,terminator,iter)) (renaming,env) iter + | AddTermIter nterms::rest,terminator,iter -> + aux (nterms,None,Some (rest,terminator,iter)) (renaming,env) iter + | AddLetIn (na,c,t)::rest,terminator,iter -> + let env,(na,_,c,t) = intern_letin_binder intern ntnvars env (na,c,t) in + DAst.make ?loc (GLetIn (na,c,t,aux_letin env (rest,terminator,iter))) in + aux_letin env (Option.get iteropt) + | NVar id -> subst_var subst' (renaming, env) id + | NList (x,y,iter,terminator,revert) -> + let l,(scopt,subscopes) = + (* All elements of the list are in scopes (scopt,subscopes) *) + try + let l,scopes = Id.Map.find x termlists in + (if revert then List.rev l else l),scopes + with Not_found -> + try + let (bl,(scopt,subscopes)) = Id.Map.find x binderlists in + let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in + terms_of_binders (if revert then bl' else List.rev bl'),(None,[]) + with Not_found -> + anomaly (Pp.str "Inconsistent substitution of recursive notation.") in + let l = List.map (fun a -> AddTermIter ((Id.Map.add y (a,(scopt,subscopes)) terms))) l in + aux (terms,None,Some (l,terminator,iter)) subinfos (NVar ldots_var) + | NHole (knd, naming, arg) -> + let knd = match knd with + | Evar_kinds.BinderType (Name id as na) -> + let na = + try (coerce_to_name (fst (Id.Map.find id terms))).v + 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 mk_env id (c, (tmp_scope, subscopes)) map = + let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in + try + let gc = intern nenv c in + Id.Map.add id (gc, None) map + with Nametab.GlobalizationError _ -> map + in + let mk_env' (c, (onlyident,(tmp_scope,subscopes))) = + let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in + if onlyident then + let na = out_patvar c in term_of_name na, None + else + let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in + match disjpat with + | [pat] -> (glob_constr_of_cases_pattern (Global.env()) pat, None) + | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () + in + let terms = Id.Map.fold mk_env terms Id.Map.empty in + let binders = Id.Map.map mk_env' binders in + let bindings = Id.Map.fold Id.Map.add terms binders in + Some (Genintern.generic_substitute_notation bindings arg) + in + DAst.make ?loc @@ GHole (knd, naming, arg) + | NBinderList (x,y,iter,terminator,revert) -> + (try + (* All elements of the list are in scopes (scopt,subscopes) *) + let (bl,(scopt,subscopes)) = Id.Map.find x binderlists in + (* We flatten binders so that we can interpret them at substitution time *) + let bl = flatten_binders bl in + let bl = if revert then List.rev bl else bl in + (* We isolate let-ins which do not contribute to the repeated pattern *) + let l = List.map (function | CLocalDef (na,c,t) -> AddLetIn (na,c,t) + | binder -> AddPreBinderIter (y,binder)) bl in + (* We stack the binders to iterate or let-ins to insert *) + aux (terms,None,Some (l,terminator,iter)) subinfos (NVar ldots_var) + with Not_found -> + anomaly (Pp.str "Inconsistent substitution of recursive notation.")) + | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt -> + let binder = snd (Option.get binderopt) in + expand_binders ?loc mkGProd [binder] (aux subst' (renaming,env) c') + | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> + let binder = snd (Option.get binderopt) in + expand_binders ?loc mkGLambda [binder] (aux subst' (renaming,env) 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,disjpat,na = traverse_binder intern_pat ntnvars subst avoid subinfos na in + let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + DAst.make ?loc @@ GProd (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) + | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') + when Name.equal na na' -> + let subinfos,disjpat,na = traverse_binder intern_pat ntnvars subst avoid subinfos na in + let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + DAst.make ?loc @@ GLambda (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) + | t -> + glob_constr_of_notation_constr_with_binders ?loc + (traverse_binder intern_pat ntnvars subst avoid) (aux subst') subinfos t + and subst_var (terms, binderopt, _terminopt) (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 + let pat,(onlyident,scopes) = Id.Map.find id binders in + let env = set_env_scopes env scopes in + (* We deactivate impls to avoid the check on hidden parameters *) + (* and since we are only interested in the pattern as a term *) + let env = reset_hidden_inductive_implicit_test env in + if onlyident then + term_of_name (out_patvar pat) + else + let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + match disjpat with + | [pat] -> glob_constr_of_cases_pattern (Global.env()) pat + | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") + with Not_found -> + try + match binderopt with + | Some (x,binder) when Id.equal x id -> + let terms = terms_of_binders [binder] in + assert (List.length terms = 1); + intern env (List.hd terms) + | _ -> raise Not_found + with Not_found -> + DAst.make ?loc ( + try + GVar (Id.Map.find id renaming) + with Not_found -> + (* Happens for local notation joint with inductive/fixpoint defs *) + GVar id) + in aux (terms,None,None) infos c + +(* Turning substitution coming from parsing and based on production + into a substitution for interpretation and based on binding/constr + distinction *) + +let cases_pattern_of_name {loc;v=na} = + let atom = match na with Name id -> Some (qualid_of_ident ?loc id) | Anonymous -> None in + CAst.make ?loc (CPatAtom atom) + +let split_by_type ids subst = + let bind id scl l s = + match l with + | [] -> assert false + | a::l -> l, Id.Map.add id (a,scl) s in + let (terms,termlists,binders,binderlists),subst = + List.fold_left (fun ((terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists')) (id,((_,scl),typ)) -> + match typ with + | NtnTypeConstr -> + let terms,terms' = bind id scl terms terms' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder NtnBinderParsedAsConstr (AsIdentOrPattern | AsStrictPattern) -> + let a,terms = match terms with a::terms -> a,terms | _ -> assert false in + let binders' = Id.Map.add id (coerce_to_cases_pattern_expr a,(false,scl)) binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder NtnBinderParsedAsConstr AsIdent -> + let a,terms = match terms with a::terms -> a,terms | _ -> assert false in + let binders' = Id.Map.add id (cases_pattern_of_name (coerce_to_name a),(true,scl)) binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _ as x) -> + let onlyident = (x = NtnParsedAsIdent) in + let binders,binders' = bind id (onlyident,scl) binders binders' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeConstrList -> + let termlists,termlists' = bind id scl termlists termlists' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') + | NtnTypeBinderList -> + let binderlists,binderlists' = bind id scl binderlists binderlists' in + (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists')) + (subst,(Id.Map.empty,Id.Map.empty,Id.Map.empty,Id.Map.empty)) ids in + assert (terms = [] && termlists = [] && binders = [] && binderlists = []); + subst + +let split_by_type_pat ?loc ids subst = + let bind id (_,scopes) l s = + match l with + | [] -> assert false + | a::l -> l, Id.Map.add id (a,scopes) s in + let (terms,termlists),subst = + List.fold_left (fun ((terms,termlists),(terms',termlists')) (id,(scl,typ)) -> + match typ with + | NtnTypeConstr | NtnTypeBinder _ -> + let terms,terms' = bind id scl terms terms' in + (terms,termlists),(terms',termlists') + | NtnTypeConstrList -> + let termlists,termlists' = bind id scl termlists termlists' in + (terms,termlists),(terms',termlists') + | NtnTypeBinderList -> error_invalid_pattern_notation ?loc ()) + (subst,(Id.Map.empty,Id.Map.empty)) ids in + assert (terms = [] && termlists = []); + subst + +let make_subst ids l = + let fold accu (id, scopes) a = Id.Map.add id (a, scopes) accu in + List.fold_left2 fold Id.Map.empty ids l + +let intern_notation intern env ntnvars loc ntn fullargs = + (* Adjust to parsing of { } *) + let ntn,fullargs = contract_curly_brackets ntn fullargs in + (* Recover interpretation { } *) + let ((ids,c),df) = interp_notation ?loc ntn (env.tmp_scope,env.scopes) in + Dumpglob.dump_notation_location (ntn_loc ?loc fullargs ntn) ntn df; + (* Dispatch parsing substitution to an interpretation substitution *) + let subst = split_by_type ids fullargs in + (* Instantiate the notation *) + instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst (Id.Map.empty, env) c + +(**********************************************************************) +(* Discriminating between bound variables and global references *) + +let string_of_ty = function + | Inductive _ -> "ind" + | Recursive -> "def" + | Method -> "meth" + | Variable -> "var" + +let gvar (loc, id) us = match us with +| None -> DAst.make ?loc @@ GVar id +| Some _ -> + user_err ?loc (str "Variable " ++ Id.print id ++ + str " cannot have a universe instance") + +let intern_var env (ltacvars,ntnvars) namedctx loc id us = + (* Is [id] a notation variable *) + if Id.Map.mem id ntnvars then + begin + if not (Id.Map.mem id env.impls) then set_var_scope ?loc id true (env.tmp_scope,env.scopes) ntnvars; + gvar (loc,id) us, [], [], [] + end + else + (* Is [id] registered with implicit arguments *) + try + let ty,expl_impls,impls,argsc = Id.Map.find id env.impls in + let expl_impls = List.map + (fun id -> CAst.make ?loc @@ CRef (qualid_of_ident ?loc id,None), Some (make ?loc @@ ExplByName id)) expl_impls in + let tys = string_of_ty ty in + Dumpglob.dump_reference ?loc "<>" (Id.to_string id) tys; + gvar (loc,id) us, 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 Id.Set.mem id env.ids || Id.Set.mem id ltacvars.ltac_vars + then + gvar (loc,id) us, [], [], [] + else if Id.equal id ldots_var + (* Is [id] the special variable for recursive notations? *) + then if Id.Map.is_empty ntnvars + then error_ldots_var ?loc + else gvar (loc,id) us, [], [], [] + 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 ~hdr:"intern_var" + (str "variable " ++ Id.print id ++ str " should be bound to a term.") + else + (* Is [id] a goal or section variable *) + let _ = Environ.lookup_named_ctxt id namedctx in + try + (* [id] a section variable *) + (* Redundant: could be done in intern_qualid *) + let ref = VarRef id in + 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"; + DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] + with e when CErrors.noncritical e -> + (* [id] a goal variable *) + gvar (loc,id) us, [], [], [] + +let find_appl_head_data c = + match DAst.get c with + | GRef (ref,_) -> + let impls = implicits_of_global ref in + let scopes = find_arguments_scope ref in + c, impls, scopes, [] + | GApp (r, l) -> + begin match DAst.get r with + | GRef (ref,_) when l != [] -> + let n = List.length l in + let impls = implicits_of_global ref in + let scopes = find_arguments_scope ref in + c, List.map (drop_first_implicits n) impls, + List.skipn_at_least n scopes,[] + | _ -> c,[],[],[] + end + | _ -> c,[],[],[] + +let error_not_enough_arguments ?loc = + user_err ?loc (str "Abbreviation is not applied enough.") + +let check_no_explicitation l = + 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 (str"Unexpected explicitation of the argument of an abbreviation.") + +let dump_extended_global loc = function + | 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 qid = + let r = Nametab.locate_extended qid in dump_extended_global qid.CAst.loc r; r + +let intern_reference qid = + let r = + try intern_extended_global_of_qualid qid + with Not_found -> Nametab.error_global_not_found qid + in + Smartlocate.global_of_extended_global r + +let sort_info_of_level_info (info: level_info) : (Libnames.qualid * int) option = + match info with + | UAnonymous -> None + | UUnknown -> None + | UNamed id -> Some (id, 0) + +let glob_sort_of_level (level: glob_level) : glob_sort = + match level with + | GSProp -> GSProp + | GProp -> GProp + | GSet -> GSet + | GType info -> GType [sort_info_of_level_info info] + +(* Is it a global reference or a syntactic definition? *) +let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = + let loc = qid.loc in + match intern_extended_global_of_qualid qid with + | TrueGlobal (VarRef _) when no_secvar -> + (* Rule out section vars since these should have been found by intern_var *) + raise Not_found + | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), Some ref, args + | SynDef sp -> + let (ids,c) = Syntax_def.search_syntactic_definition ?loc 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 + check_no_explicitation args1; + let terms = make_subst ids (List.map fst args1) in + let subst = (terms, Id.Map.empty, Id.Map.empty, Id.Map.empty) in + let infos = (Id.Map.empty, env) in + let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in + let loc = c.loc in + let err () = + user_err ?loc (str "Notation " ++ pr_qualid qid + ++ str " cannot have a universe instance," + ++ str " its expanded head does not start with a reference") + in + let c = match us, DAst.get c with + | None, _ -> c + | Some _, GRef (ref, None) -> DAst.make ?loc @@ GRef (ref, us) + | Some _, GApp (r, arg) -> + let loc' = r.CAst.loc in + begin match DAst.get r with + | GRef (ref, None) -> + DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) + | _ -> err () + end + | Some [s], GSort (GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) + | Some [_old_level], GSort _new_sort -> + (* TODO: add old_level and new_sort to the error message *) + user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) + | Some _, _ -> err () + in + c, None, args2 + +let warn_nonprimitive_projection = + CWarnings.create ~name:"nonprimitive-projection-syntax" ~category:"syntax" ~default:CWarnings.Disabled + Pp.(fun f -> pr_qualid f ++ str " used as a primitive projection but is not one.") + +let error_nonprojection_syntax ?loc qid = + CErrors.user_err ?loc ~hdr:"nonprojection-syntax" Pp.(pr_qualid qid ++ str" is not a projection.") + +let check_applied_projection isproj realref qid = + match isproj with + | None -> () + | Some projargs -> + let is_prim = match realref with + | None | Some (IndRef _ | ConstructRef _ | VarRef _) -> false + | Some (ConstRef c) -> + if Recordops.is_primitive_projection c then true + else if Recordops.is_projection c then false + else error_nonprojection_syntax ?loc:qid.loc qid + (* TODO check projargs, note we will need implicit argument info *) + in + if not is_prim then warn_nonprimitive_projection ?loc:qid.loc qid + +let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us args qid = + let loc = qid.CAst.loc in + if qualid_is_ident qid then + try + let res = intern_var env lvar namedctx loc (qualid_basename qid) us in + check_applied_projection isproj None qid; + res, args + with Not_found -> + try + let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in + check_applied_projection isproj realref qid; + 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 + (* check_applied_projection ?? *) + (gvar (loc,qualid_basename qid) us, [], [], []), args + else Nametab.error_global_not_found qid + else + let r,realref,args2 = + try intern_qualid qid intern env ntnvars us args + with Not_found -> Nametab.error_global_not_found qid + in + check_applied_projection isproj realref qid; + let x, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), args2 + +let interp_reference vars r = + let (r,_,_,_),_ = + intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) + {ids = Id.Set.empty; unb = false ; + tmp_scope = None; scopes = []; impls = empty_internalization_env} + Environ.empty_named_context_val + (vars, Id.Map.empty) None [] r + in r + +(**********************************************************************) +(** {5 Cases } *) + +(** Private internalization patterns *) +type 'a raw_cases_pattern_expr_r = + | RCPatAlias of 'a raw_cases_pattern_expr * lname + | RCPatCstr of GlobRef.t + * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list + (** [RCPatCstr (loc, c, l1, l2)] represents [((@ c l1) l2)] *) + | RCPatAtom of (lident * (Notation_term.tmp_scope_name option * Notation_term.scope_name list)) option + | RCPatOr of 'a raw_cases_pattern_expr list +and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t + +(** {6 Elementary 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 = + (* 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_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))) + +(* @return the first variable that occurs twice in a pattern + +naive n^2 algo *) +let rec has_duplicate = function + | [] -> None + | x::l -> if Id.List.mem x l then (Some x) else has_duplicate l + +let loc_of_multiple_pattern pl = + Loc.merge_opt (cases_pattern_expr_loc (List.hd pl)) (cases_pattern_expr_loc (List.last pl)) + +let loc_of_lhs lhs = + Loc.merge_opt (loc_of_multiple_pattern (List.hd lhs)) (loc_of_multiple_pattern (List.last lhs)) + +let check_linearity lhs ids = + match has_duplicate ids with + | Some id -> + raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id)) + | None -> + () + +(* 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 not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p))) + +let check_or_pat_variables loc ids idsl = + let eq_id {v=id} {v=id'} = Id.equal id id' in + (* Collect remaining patterns which do not have the same variables as the first pattern *) + let idsl = List.filter (fun ids' -> not (List.eq_set eq_id ids ids')) idsl in + match idsl with + | ids'::_ -> + (* Look for an [id] which is either in [ids] and not in [ids'] or in [ids'] and not in [ids] *) + let ids'' = List.subtract eq_id ids ids' in + let ids'' = if ids'' = [] then List.subtract eq_id ids' ids else ids'' in + user_err ?loc + (strbrk "The components of this disjunctive pattern must bind the same variables (" ++ + Id.print (List.hd ids'').v ++ strbrk " is not bound in all patterns).") + | [] -> () + +(** 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 env cstr) then false else + (Int.equal n (Inductiveops.constructor_nalldecls env cstr) || + (error_wrong_numarg_constructor ?loc env cstr + (Inductiveops.constructor_nrealargs env cstr))) + +open Declarations + +(* Similar to Cases.adjust_local_defs but on RCPat *) +let insert_local_defs_in_pattern (ind,j) l = + let (mib,mip) = Global.lookup_inductive ind in + if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then + (* Optimisation *) l + else + let (ctx, _) = mip.mind_nf_lc.(j-1) in + let decls = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in + let rec aux decls args = + match decls, args with + | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args + | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) + | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args + | _ -> assert false in + aux decls l + +let add_local_defs_and_check_length loc env g pl args = match g with + | ConstructRef cstr -> + (* We consider that no variables corresponding to local binders + have been given in the "explicit" arguments, which come from a + "@C args" notation or from a custom user notation *) + let pl' = insert_local_defs_in_pattern cstr pl in + let maxargs = Inductiveops.constructor_nalldecls env cstr in + if List.length pl' + List.length args > maxargs then + error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs env cstr); + (* Two possibilities: either the args are given with explict + variables for local definitions, then we give the explicit args + extended with local defs, so that there is nothing more to be + added later on; or the args are not enough to have all arguments, + which a priori means local defs to add in the [args] part, so we + postpone the insertion of local defs in the explicit args *) + (* Note: further checks done later by check_constructor_length *) + if List.length pl' + List.length args = maxargs then pl' else pl + | _ -> pl + +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,(DAst.make @@ RCPatAtom 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,(DAst.make @@ RCPatAtom 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 env c in + let nargs' = Inductiveops.constructor_nalldecls env c in + let impls_st = implicits_of_global (ConstructRef c) in + add_implicits_check_length (error_wrong_numarg_constructor ?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 c in + let nalldecls = inductive_nalldecls env c in + let impls_st = implicits_of_global (IndRef c) in + add_implicits_check_length (error_wrong_numarg_inductive ?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 (Global.env()) ind + else Inductiveops.inductive_nparams (Global.env()) ind in + assert (nparams <= List.length args); + let params,args = List.chop nparams args in + List.iter (fun c -> match DAst.get c with + | PatVar Anonymous -> () + | PatVar _ | PatCstr(_,_,_) -> error_parameter_not_implicit ?loc:c.CAst.loc) params; + args + +let find_constructor loc add_params ref = + let (ind,_ as 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 ~hdr:"find_constructor" error + | ConstRef _ | VarRef _ -> + let error = str "This reference is not a constructor." in + user_err ?loc ~hdr:"find_constructor" error + in + cstr, match add_params with + | Some nb_args -> + let env = Global.env () in + let nb = + if Int.equal nb_args (Inductiveops.constructor_nrealdecls env cstr) + then Inductiveops.inductive_nparamdecls env ind + else Inductiveops.inductive_nparams env ind + in + List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) + | None -> [] + +let find_pattern_variable qid = + if qualid_is_ident qid then qualid_basename qid + else raise (InternalizationError(qid.CAst.loc,NotAConstructor qid)) + +let check_duplicate loc fields = + let eq (ref1, _) (ref2, _) = qualid_eq ref1 ref2 in + let dups = List.duplicates eq fields in + match dups with + | [] -> () + | (r, _) :: _ -> + user_err ?loc (str "This record defines several times the field " ++ + pr_qualid r ++ str ".") + +let inductive_of_record loc record = + let inductive = IndRef (inductive_of_constructor record.Recordops.s_CONST) in + Nametab.shortest_qualid_of_global ?loc Id.Set.empty inductive + +(** [sort_fields ~complete loc fields completer] expects a list + [fields] of field assignments [f = e1; g = e2; ...], where [f, g] + are fields of a record and [e1] are "values" (either terms, when + interning a record construction, or patterns, when intering record + pattern-matching). It will sort the fields according to the record + declaration order (which is important when type-checking them in + presence of dependencies between fields). If the parameter + [complete] is true, we require the assignment to be complete: all + the fields of the record must be present in the + assignment. Otherwise the record assignment may be partial + (in a pattern, we may match on some fields only), and we call the + function [completer] to fill the missing fields; the returned + field assignment list is always complete. *) +let sort_fields ~complete loc fields completer = + match fields with + | [] -> None + | (first_field_ref, first_field_value):: other_fields -> + let (first_field_glob_ref, record) = + try + let gr = locate_reference first_field_ref in + (gr, Recordops.find_projection gr) + with Not_found -> + raise (InternalizationError(loc, NotAProjection first_field_ref)) + in + (* the number of parameters *) + let nparams = record.Recordops.s_EXPECTEDPARAM in + (* the reference constructor of the record *) + let base_constructor = + let global_record_id = ConstructRef record.Recordops.s_CONST in + try Nametab.shortest_qualid_of_global ?loc Id.Set.empty global_record_id + with Not_found -> + anomaly (str "Environment corruption for records.") in + let () = check_duplicate loc fields in + let (end_index, (* one past the last field index *) + first_field_index, (* index of the first field of the record *) + proj_list) (* list of projections *) + = + (* eliminate the first field from the projections, + but keep its index *) + let rec build_proj_list projs proj_kinds idx ~acc_first_idx acc = + match projs with + | [] -> (idx, acc_first_idx, acc) + | (Some field_glob_id) :: projs -> + let field_glob_ref = ConstRef field_glob_id in + let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in + begin match proj_kinds with + | [] -> anomaly (Pp.str "Number of projections mismatch.") + | (_, regular) :: proj_kinds -> + (* "regular" is false when the field is defined + by a let-in in the record declaration + (its value is fixed from other fields). *) + if first_field && not regular && complete then + user_err ?loc (str "No local fields allowed in a record construction.") + else if first_field then + build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc + else if not regular && complete then + (* skip non-regular fields *) + build_proj_list projs proj_kinds idx ~acc_first_idx acc + else + build_proj_list projs proj_kinds (idx+1) ~acc_first_idx + ((idx, field_glob_id) :: acc) + end + | None :: projs -> + if complete then + (* we don't want anonymous fields *) + user_err ?loc (str "This record contains anonymous fields.") + else + (* anonymous arguments don't appear in proj_kinds *) + build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc + in + build_proj_list record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 ~acc_first_idx:0 [] + in + (* now we want to have all fields assignments indexed by their place in + the constructor *) + let rec index_fields fields remaining_projs acc = + match fields with + | (field_ref, field_value) :: fields -> + let field_glob_ref = try locate_reference field_ref + with Not_found -> + user_err ?loc ~hdr:"intern" + (str "The field \"" ++ pr_qualid field_ref ++ str "\" does not exist.") in + let this_field_record = try Recordops.find_projection field_glob_ref + with Not_found -> + let inductive_ref = inductive_of_record loc record in + raise (InternalizationError(loc, NotAProjectionOf (field_ref, inductive_ref))) + in + let remaining_projs, (field_index, _) = + let the_proj (idx, glob_id) = GlobRef.equal field_glob_ref (ConstRef glob_id) in + try CList.extract_first the_proj remaining_projs + with Not_found -> + let ind1 = inductive_of_record loc record in + let ind2 = inductive_of_record loc this_field_record in + raise (InternalizationError(loc, ProjectionsOfDifferentRecords (ind1, ind2))) + in + index_fields fields remaining_projs ((field_index, field_value) :: acc) + | [] -> + (* the order does not matter as we sort them next, + List.rev_* is just for efficiency *) + let remaining_fields = + let complete_field (idx, field_ref) = (idx, + completer idx field_ref record.Recordops.s_CONST) in + List.rev_map complete_field remaining_projs in + List.rev_append remaining_fields acc + in + let unsorted_indexed_fields = + index_fields other_fields proj_list + [(first_field_index, first_field_value)] in + let sorted_indexed_fields = + let cmp_by_index (i, _) (j, _) = Int.compare i j in + List.sort cmp_by_index unsorted_indexed_fields in + let sorted_fields = List.map snd sorted_indexed_fields in + Some (nparams, base_constructor, sorted_fields) + +(** {6 Manage multiple aliases} *) + +type alias = { + alias_ids : lident 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 {loc;v=na} = + match na with + | Anonymous -> aliases + | Name id -> + let alias_ids = aliases.alias_ids @ [make ?loc id] in + let alias_map = match aliases.alias_ids with + | [] -> aliases.alias_map + | {v=id'} :: _ -> Id.Map.add id id' aliases.alias_map + in + { alias_ids; alias_map; } + +let alias_of als = match als.alias_ids with +| [] -> Anonymous +| {v=id} :: _ -> Name id + +(** {6 Expanding notations } + + @returns a raw_case_pattern_expr : + - no notations and syntactic definition + - global reference and identifeir instead of reference + +*) + +let is_zero s = + let rec aux i = + Int.equal (String.length s) i || ((s.[i] == '0' || s.[i] == '_') && aux (i+1)) + in aux 0 +let is_zero n = is_zero n.NumTok.int && is_zero n.NumTok.frac + +let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2 + +let product_of_cases_patterns aliases idspl = + (* each [pl] is a disjunction of patterns over common identifiers [ids] *) + (* We stepwise build a disjunction of patterns [ptaill] over common [ids'] *) + 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) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) + idspl (aliases.alias_ids,[aliases.alias_map,[]]) + +let rec subst_pat_iterator y t = DAst.(map (function + | RCPatAtom id as p -> + begin match id with Some ({v=x},_) when Id.equal x y -> DAst.get t | _ -> p end + | RCPatCstr (id,l1,l2) -> + RCPatCstr (id,List.map (subst_pat_iterator y t) l1, + List.map (subst_pat_iterator y t) l2) + | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) + | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) + +let is_non_zero c = match c with +| { CAst.v = CPrim (Numeral (SPlus, p)) } -> not (is_zero p) +| _ -> false + +let is_non_zero_pat c = match c with +| { CAst.v = CPatPrim (Numeral (SPlus, p)) } -> not (is_zero p) +| _ -> false + +let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"no parameters in constructors" + ~key:["Asymmetric";"Patterns"] + ~value:false + +let drop_notations_pattern looked_for genv = + (* 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 + (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) + let rec rcp_of_glob scopes x = DAst.(map (function + | GVar id -> RCPatAtom (Some (CAst.make ?loc:x.loc id,scopes)) + | GHole (_,_,_) -> RCPatAtom (None) + | GRef (g,_) -> RCPatCstr (g,[],[]) + | GApp (r, l) -> + begin match DAst.get r with + | GRef (g,_) -> + let allscs = find_arguments_scope g in + let allscs = simple_adjust_scopes (List.length l) allscs in (* TO CHECK *) + RCPatCstr (g, List.map2 (fun sc a -> rcp_of_glob (sc,snd scopes) a) allscs l,[]) + | _ -> + CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr.") + end + | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x + in + let rec drop_syndef top scopes qid pats = + try + match Nametab.locate_extended qid with + | SynDef sp -> + let filter (vars,a) = + try match a with + | NRef g -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) + 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 scopes) argscs pats) + | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr, this deactivates *) + test_kind top g; + let () = assert (List.is_empty vars) in + Some (g, List.map (in_pat false scopes) pats, []) + | NApp (NRef g,args) -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) + test_kind top g; + let nvars = List.length vars in + if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; + let pats1,pats2 = List.chop nvars pats in + let subst = make_subst vars pats1 in + let idspl1 = List.map (in_not false qid.loc scopes (subst, Id.Map.empty) []) args in + let (_,argscs) = find_remaining_scopes pats1 pats2 g in + Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) + | _ -> raise Not_found + with Not_found -> None in + Syntax_def.search_filtered_syntactic_definition filter sp + | TrueGlobal g -> + test_kind top g; + Dumpglob.add_glob ?loc:qid.loc g; + let (_,argscs) = find_remaining_scopes [] pats g in + Some (g,[],List.map2 (fun x -> in_pat false (x,snd scopes)) argscs pats) + with Not_found -> None + and in_pat top scopes pt = + let open CAst in + let loc = pt.loc in + match pt.v with + | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) + | CPatRecord l -> + let sorted_fields = + sort_fields ~complete:false loc l (fun _idx fieldname constructor -> CAst.make ?loc @@ CPatAtom None) in + begin match sorted_fields with + | None -> DAst.make ?loc @@ RCPatAtom None + | Some (n, head, pl) -> + let pl = + if get_asymmetric_patterns () then pl else + let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in + List.rev_append pars pl in + match drop_syndef top scopes head pl with + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) + | None -> raise (InternalizationError (loc,NotAConstructor head)) + end + | CPatCstr (head, None, pl) -> + begin + match drop_syndef top scopes head pl with + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) + | None -> raise (InternalizationError (loc,NotAConstructor head)) + end + | CPatCstr (qid, Some expl_pl, pl) -> + let g = try Nametab.locate qid + with Not_found -> + raise (InternalizationError (loc,NotAConstructor qid)) in + if expl_pl == [] then + (* Convention: (@r) deactivates all further implicit arguments and scopes *) + DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) + else + (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) + (* but not scopes in expl_pl *) + let (argscs1,_) = find_remaining_scopes expl_pl pl g in + DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) + | CPatNotation ((InConstrEntrySomeLevel,"- _"),([a],[]),[]) when is_non_zero_pat a -> + let p = match a.CAst.v with CPatPrim (Numeral (_, p)) -> p | _ -> assert false in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (SMinus,p)) scopes in + rcp_of_glob scopes pat + | CPatNotation ((InConstrEntrySomeLevel,"( _ )"),([a],[]),[]) -> + in_pat top scopes a + | CPatNotation (ntn,fullargs,extrargs) -> + let ntn,(terms,termlists) = contract_curly_brackets_pat ntn fullargs in + let ((ids',c),df) = Notation.interp_notation ?loc ntn scopes in + let (terms,termlists) = split_by_type_pat ?loc ids' (terms,termlists) in + Dumpglob.dump_notation_location (patntn_loc ?loc fullargs ntn) ntn df; + in_not top loc scopes (terms,termlists) extrargs c + | CPatDelimiters (key, e) -> + in_pat top (None,find_delimiters_scope ?loc key::snd scopes) e + | CPatPrim p -> + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (test_kind false) p scopes in + rcp_of_glob scopes pat + | CPatAtom (Some id) -> + begin + match drop_syndef top scopes id [] with + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) + | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) + end + | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None + | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) + | CPatCast (_,_) -> + (* We raise an error if the pattern contains a cast, due to + current restrictions on casts in patterns. Cast in patterns + are supportted only in local binders and only at top + level. In fact, they are currently eliminated by the + parser. The only reason why they are in the + [cases_pattern_expr] type is that the parser needs to factor + the "(c : t)" notation with user defined notations (such as + the pair). In the long term, we will try to support such + casts everywhere, and use them to print the domains of + lambdas in the encoding of match in constr. This check is + here and not in the parser because it would require + duplicating the levels of the [pattern] rule. *) + CErrors.user_err ?loc ~hdr:"drop_notations_pattern" + (Pp.strbrk "Casts are not supported in this pattern.") + and in_pat_sc scopes x = in_pat false (x,snd scopes) + and in_not top loc scopes (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 (scopt,subscopes@snd scopes) a + with Not_found -> + if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((make ?loc id),scopes)) else + anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") + end + | NRef g -> + ensure_kind top loc g; + let (_,argscs) = find_remaining_scopes [] args g in + DAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) + | NApp (NRef g,pl) -> + ensure_kind top loc g; + let (argscs1,argscs2) = find_remaining_scopes pl args g in + let pl = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl in + let pl = add_local_defs_and_check_length loc genv g pl args in + DAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) + | NList (x,y,iter,terminator,revert) -> + if not (List.is_empty args) then user_err ?loc + (strbrk "Application of arguments to a recursive notation not supported in patterns."); + (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 scopes fullsubst [] terminator in + List.fold_right (fun a t -> + let nsubst = Id.Map.add y (a, (scopt, subscopes)) subst in + let u = in_not false loc scopes (nsubst, substlist) [] iter in + subst_pat_iterator ldots_var t u) + (if revert 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 + DAst.make ?loc @@ RCPatAtom None + | t -> error_invalid_pattern_notation ?loc () + in in_pat true + +let rec intern_pat genv ntnvars aliases pat = + let intern_cstr_with_all_args loc c with_letin idslpl1 pl2 = + let idslpl2 = List.map (intern_pat genv ntnvars empty_alias) pl2 in + let (ids',pll) = product_of_cases_patterns aliases (idslpl1@idslpl2) in + let pl' = List.map (fun (asubst,pl) -> + (asubst, DAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in + ids',pl' in + let loc = pat.loc in + match DAst.get pat with + | RCPatAlias (p, id) -> + let aliases' = merge_aliases aliases id in + intern_pat genv ntnvars aliases' p + | RCPatCstr (head, expl_pl, pl) -> + if get_asymmetric_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 (Some ({loc;v=id},scopes)) -> + let aliases = merge_aliases aliases (make ?loc @@ Name id) in + set_var_scope ?loc id false scopes ntnvars; + (aliases.alias_ids,[aliases.alias_map, DAst.make ?loc @@ PatVar (alias_of aliases)]) (* TO CHECK: aura-t-on id? *) + | RCPatAtom (None) -> + let { alias_ids = ids; alias_map = asubst; } = aliases in + (ids, [asubst, DAst.make ?loc @@ PatVar (alias_of aliases)]) + | RCPatOr pl -> + assert (not (List.is_empty pl)); + let pl' = List.map (intern_pat genv ntnvars 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 ntnvars scopes aliases pat = + intern_pat genv ntnvars aliases + (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) genv scopes pat) + +let _ = + intern_cases_pattern_fwd := + fun ntnvars scopes p -> intern_cases_pattern (Global.env ()) ntnvars scopes empty_alias p + +let intern_ind_pattern genv ntnvars scopes pat = + let no_not = + try + drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) genv scopes pat + with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ?loc + in + let loc = no_not.CAst.loc in + match DAst.get no_not with + | RCPatCstr (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 idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in + (with_letin, + match product_of_cases_patterns empty_alias idslpl with + | ids,[asubst,pl] -> (c,ids,asubst,chop_params_pattern loc c pl with_letin) + | _ -> error_bad_inductive_type ?loc) + | x -> error_bad_inductive_type ?loc + +(**********************************************************************) +(* Utilities for application *) + +let merge_impargs l args = + let test x = function + | (_, Some {v=y}) -> explicitation_eq x y + | _ -> false + in + List.fold_right (fun a l -> + match a with + | (_, Some {v=ExplByName id as x}) when + List.exists (test x) args -> l + | _ -> a::l) + l args + +let get_implicit_name n imps = + Some (Impargs.name_of_implicit (List.nth imps (n-1))) + +let set_hole_implicit i b c = + let loc = c.CAst.loc in + match DAst.get c with + | GRef (r, _) -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),IntroAnonymous,None) + | GApp (r, _) -> + let loc = r.CAst.loc in + begin match DAst.get r with + | GRef (r, _) -> + Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),IntroAnonymous,None) + | _ -> anomaly (Pp.str "Only refs have implicits.") + end + | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),IntroAnonymous,None) + | _ -> anomaly (Pp.str "Only refs have implicits.") + +let exists_implicit_name id = + 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 + | None -> (eargs,a::rargs) + | Some {loc;v=pos} -> + let id = match pos with + | ExplByName id -> + if not (exists_implicit_name id imps) then + user_err ?loc + (str "Wrong argument name: " ++ Id.print id ++ str "."); + if Id.Map.mem id eargs then + user_err ?loc (str "Argument name " ++ Id.print id + ++ str " occurs more than once."); + id + | ExplByPos (p,_id) -> + let id = + try + let imp = List.nth imps (p-1) in + if not (is_status_implicit imp) then failwith "imp"; + name_of_implicit imp + with Failure _ (* "nth" | "imp" *) -> + user_err ?loc + (str"Wrong argument position: " ++ int p ++ str ".") + in + if Id.Map.mem id eargs then + user_err ?loc (str"Argument at position " ++ int p ++ + str " is mentioned more than once."); + id in + (Id.Map.add id (loc, a) eargs, rargs) + in aux args + +(**********************************************************************) +(* Main loop *) + +let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = + let rec intern env = CAst.with_loc_val (fun ?loc -> function + | CRef (ref,us) -> + let (c,imp,subscopes,l),_ = + intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) + lvar us [] ref + in + apply_impargs c env imp subscopes l loc + + | CFix ({ CAst.loc = locid; v = iddef}, dl) -> + let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in + let dl = Array.of_list dl in + let n = + try List.index0 Id.equal iddef lf + with Not_found -> + raise (InternalizationError (locid,UnboundFixName (false,iddef))) + in + let idl_temp = Array.map + (fun (id,recarg,bl,ty,_) -> + let recarg = Option.map (function { CAst.v = v } -> match v with + | CStructRec i -> i + | _ -> anomaly Pp.(str "Non-structural recursive argument in non-program fixpoint")) recarg + in + let before, after = split_at_annot bl recarg in + let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in + let n = Option.map (fun _ -> List.count (fun c -> match DAst.get c with + | GLocalAssum _ -> true + | _ -> false (* remove let-ins *)) + rbefore) recarg in + let (env',rbl) = List.fold_left intern_local_binder (env',rbefore) after in + let bl = List.rev (List.map glob_local_binder_of_extended rbl) in + (n, bl, 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 (_,bli,tyi,_) = idl_temp.(i) in + let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in + push_name_env ntnvars (impls_type_list ~args:fix_args tyi) + en (CAst.make @@ Name name)) 0 env' lf in + (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in + DAst.make ?loc @@ + GRec (GFix + (Array.map (fun (ro,_,_,_) -> ro) idl,n), + Array.of_list lf, + Array.map (fun (_,bl,_,_) -> bl) idl, + Array.map (fun (_,_,ty,_) -> ty) idl, + Array.map (fun (_,_,_,bd) -> bd) idl) + + | CCoFix ({ CAst.loc = locid; v = iddef }, dl) -> + let lf = List.map (fun ({CAst.v = id},_,_,_) -> id) dl in + let dl = Array.of_list dl in + let n = + try List.index0 Id.equal iddef lf + with Not_found -> + raise (InternalizationError (locid,UnboundFixName (true,iddef))) + in + let idl_tmp = Array.map + (fun ({ CAst.loc; v = id },bl,ty,_) -> + let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in + (List.rev (List.map glob_local_binder_of_extended 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 (bli,tyi,_) = idl_tmp.(i) in + let cofix_args = List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli in + push_name_env ntnvars (impls_type_list ~args:cofix_args tyi) + en (CAst.make @@ Name name)) 0 env' lf in + (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in + DAst.make ?loc @@ + GRec (GCoFix n, + Array.of_list lf, + Array.map (fun (bl,_,_) -> bl) idl, + Array.map (fun (_,ty,_) -> ty) idl, + Array.map (fun (_,_,bd) -> bd) idl) + | CProdN ([],c2) -> anomaly (Pp.str "The AST is malformed, found prod without binders.") + | CProdN (bl,c2) -> + let (env',bl) = List.fold_left intern_local_binder (env,[]) bl in + expand_binders ?loc mkGProd bl (intern_type env' c2) + | CLambdaN ([],c2) -> anomaly (Pp.str "The AST is malformed, found lambda without binders.") + | CLambdaN (bl,c2) -> + let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope env,[]) bl in + expand_binders ?loc mkGLambda bl (intern env' c2) + | CLetIn (na,c1,t,c2) -> + let inc1 = intern (reset_tmp_scope env) c1 in + let int = Option.map (intern_type env) t in + DAst.make ?loc @@ + GLetIn (na.CAst.v, inc1, int, + intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) + | CNotation ((InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> + let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in + intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) + | CNotation ((InConstrEntrySomeLevel,"( _ )"),([a],[],[],[])) -> intern env a + | CNotation (ntn,args) -> + intern_notation intern env ntnvars loc ntn args + | CGeneralization (b,a,c) -> + intern_generalization intern env ntnvars loc b a c + | CPrim p -> + fst (Notation.interp_prim_token ?loc p (env.tmp_scope,env.scopes)) + | CDelimiters (key, e) -> + intern {env with tmp_scope = None; + scopes = find_delimiters_scope ?loc key :: env.scopes} e + | CAppExpl ((isproj,ref,us), args) -> + let (f,_,args_scopes,_),args = + let args = List.map (fun a -> (a,None)) args in + intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) + lvar us args ref + in + (* Rem: GApp(_,f,[]) stands for @f *) + if args = [] then DAst.make ?loc @@ GApp (f,[]) else + smart_gapp f loc (intern_args env args_scopes (List.map fst args)) + + | CApp ((isproj,f), args) -> + let isproj,f,args = match f.CAst.v with + (* Compact notations like "t.(f args') args" *) + | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args + (* Don't compact "(f args') args" to resolve implicits separately *) + | _ -> isproj,f,args in + let (c,impargs,args_scopes,l),args = + match f.CAst.v with + | CRef (ref,us) -> + intern_applied_reference ~isproj intern env + (Environ.named_context_val globalenv) lvar us args ref + | CNotation (ntn,([],[],[],[])) -> + assert (Option.is_empty isproj); + let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in + let x, impl, scopes, l = find_appl_head_data c in + (x,impl,scopes,l), args + | _ -> assert (Option.is_empty isproj); (intern env f,[],[],[]), args in + apply_impargs c env impargs args_scopes + (merge_impargs l args) loc + + | CRecord fs -> + let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in + let fields = + sort_fields ~complete:true loc fs + (fun _idx fieldname constructorname -> + let open Evar_kinds in + let fieldinfo : Evar_kinds.record_field = + {fieldname=fieldname; recordname=inductive_of_constructor constructorname} + in + CAst.make ?loc @@ CHole (Some + (Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with + Evar_kinds.qm_obligation=st; + Evar_kinds.qm_record_field=Some fieldinfo + }) , IntroAnonymous, None)) + in + begin + match fields with + | None -> user_err ?loc ~hdr:"intern" (str"No constructor inference.") + | Some (n, constrname, args) -> + let pars = List.make n (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) in + let app = CAst.make ?loc @@ CAppExpl ((None, constrname,None), List.rev_append pars args) in + intern env app + end + | CCases (sty, rtnpo, tms, eqns) -> + let as_in_vars = List.fold_left (fun acc (_,na,inb) -> + (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na)) + 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,aliases,match_from_in = List.fold_right + (fun citm (inds,ex_ids,asubst,matchs) -> + let ((tm,ind),extra_id,(ind_ids,alias_subst,match_td)) = + intern_case_item env forbidden_vars citm in + (tm,ind)::inds, + Id.Set.union ind_ids (Option.fold_right Id.Set.add extra_id ex_ids), + merge_subst alias_subst asubst, + List.rev_append match_td matchs) + tms ([],Id.Set.empty,Id.Map.empty,[]) in + let env' = Id.Set.fold + (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (CAst.make @@ 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 + | [] -> [] + | (_, c) :: q when is_patvar c -> aux q + | l -> l + in aux match_from_in in + let rtnpo = Option.map (replace_vars_constr_expr aliases) rtnpo in + let rtnpo = match stripped_match_from_in with + | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) + | l -> + (* Build a return predicate by expansion of the patterns of the "in" clause *) + let thevars, thepats = List.split l in + let sub_rtn = (* Some (GSort (Loc.ghost,GType None)) *) None in + let sub_tms = List.map (fun id -> (DAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in + let main_sub_eqn = CAst.make @@ + ([],thepats, (* "|p1,..,pn" *) + Option.cata (intern_type env') + (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,IntroAnonymous,None)) + rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in + let catch_all_sub_eqn = + if List.for_all (irrefutable globalenv) thepats then [] else + [CAst.make @@ ([],List.make (List.length thepats) (DAst.make @@ PatVar Anonymous), (* "|_,..,_" *) + DAst.make @@ GHole(Evar_kinds.ImpossibleCase,IntroAnonymous,None))] (* "=> _" *) in + Some (DAst.make @@ GCases(RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) + in + let eqns' = List.map (intern_eqn (List.length tms) env) eqns in + DAst.make ?loc @@ + GCases (sty, rtnpo, tms, List.flatten eqns') + | CLetTuple (nal, (na,po), b, c) -> + let env' = reset_tmp_scope env 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 ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') + (CAst.make na') in + intern_type env'' u) po in + DAst.make ?loc @@ + GLetTuple (List.map (fun { CAst.v } -> v) nal, (na', p'), b', + intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) + | CIf (c, (na,po), b1, b2) -> + 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 ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) + (CAst.make na') in + intern_type env'' p) po in + DAst.make ?loc @@ + GIf (c', (na', p'), intern env b1, intern env b2) + | CHole (k, naming, solve) -> + let k = match k with + | None -> + let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in + (match naming with + | IntroIdentifier id -> Evar_kinds.NamedHole id + | _ -> Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=st; }) + | Some k -> k + in + let solve = match solve with + | None -> None + | Some gen -> + let (ltacvars, ntnvars) = lvar in + (* Preventively declare notation variables in ltac as non-bindings *) + Id.Map.iter (fun x (used_as_binder,_,_) -> used_as_binder := false) ntnvars; + let extra = ltacvars.ltac_extra in + (* We inform ltac that the interning vars and the notation vars are bound *) + (* but we could instead rely on the "intern_sign" *) + let lvars = Id.Set.union ltacvars.ltac_bound ltacvars.ltac_vars in + let lvars = Id.Set.union lvars (Id.Map.domain ntnvars) in + let ltacvars = Id.Set.union lvars env.ids in + (* Propagating enough information for mutual interning with tac-in-term *) + let intern_sign = { + Genintern.intern_ids = env.ids; + Genintern.notation_variable_status = ntnvars + } in + let ist = { + Genintern.genv = globalenv; + ltacvars; + extra; + intern_sign; + } in + let (_, glb) = Genintern.generic_intern ist gen in + Some glb + in + DAst.make ?loc @@ + GHole (k, naming, solve) + (* Parsing pattern variables *) + | CPatVar n when pattern_mode -> + DAst.make ?loc @@ + GPatVar (Evar_kinds.SecondOrderPatVar n) + | CEvar (n, []) when pattern_mode -> + DAst.make ?loc @@ + GPatVar (Evar_kinds.FirstOrderPatVar n) + (* end *) + (* Parsing existential variables *) + | CEvar (n, l) -> + DAst.make ?loc @@ + GEvar (n, List.map (on_snd (intern env)) l) + | CPatVar _ -> + raise (InternalizationError (loc,IllegalMetavariable)) + (* end *) + | CSort s -> + DAst.make ?loc @@ + GSort s + | CCast (c1, c2) -> + DAst.make ?loc @@ + GCast (intern env c1, map_cast_type (intern_type env) c2) + ) + and intern_type env = intern (set_type_scope env) + + and intern_local_binder env bind : intern_env * Glob_term.extended_glob_local_binder list = + intern_local_binder_aux intern ntnvars env bind + + (* Expands a multiple pattern into a disjunction of multiple patterns *) + and intern_multiple_pattern env n pl = + let idsl_pll = List.map (intern_cases_pattern globalenv ntnvars (None,env.scopes) empty_alias) pl in + let loc = loc_of_multiple_pattern pl in + check_number_of_pattern loc n pl; + product_of_cases_patterns empty_alias idsl_pll + + (* Expands a disjunction of multiple pattern *) + and intern_disjunctive_multiple_pattern env loc n 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 + check_or_pat_variables loc ids (List.tl idsl); + (ids,List.flatten mpl') + + (* Expands a pattern-matching clause [lhs => rhs] *) + and intern_eqn n env {loc;v=(lhs,rhs)} = + let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in + (* Linearity implies the order in ids is irrelevant *) + let eqn_ids = List.map (fun x -> x.v) eqn_ids in + check_linearity lhs eqn_ids; + 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 + let rhs' = intern {env with ids = env_ids} rhs in + CAst.make ?loc (eqn_ids,pl,rhs')) pll + + and intern_case_item env forbidden_names_for_gen (tm,na,t) = + (* the "match" part *) + let tm' = intern env tm in + (* the "as" part *) + let extra_id,na = + let loc = tm'.CAst.loc in + match DAst.get tm', na with + | GVar id, None when not (Id.Map.mem id (snd lvar)) -> Some id, CAst.make ?loc @@ Name id + | GRef (VarRef id, _), None -> Some id, CAst.make ?loc @@ Name id + | _, None -> None, CAst.make Anonymous + | _, Some ({ CAst.loc; v = na } as lna) -> None, lna in + (* the "in" part *) + let match_td,typ = match t with + | Some t -> + let with_letin,(ind,ind_ids,alias_subst,l) = + intern_ind_pattern globalenv ntnvars (None,env.scopes) 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 + | { CAst.v = Anonymous } -> l + | { CAst.loc; v = (Name y as x) } -> (y, DAst.make ?loc @@ PatVar x) :: l in + match case_rel_ctxt,arg_pats with + (* LetIn in the rel_context *) + | LocalDef _ :: t, l when not with_letin -> + canonize_args t l forbidden_names match_acc ((CAst.make Anonymous)::var_acc) + | [],[] -> + (add_name match_acc na, var_acc) + | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> + begin match DAst.get c with + | PatVar x -> + let loc = c.CAst.loc in + canonize_args t tt forbidden_names + (add_name match_acc CAst.(make ?loc x)) (CAst.make ?loc x::var_acc) + | _ -> + let fresh = + Namegen.next_name_away_with_default_using_types "iV" cano_name.binder_name forbidden_names (EConstr.of_constr ty) in + canonize_args t tt (Id.Set.add fresh forbidden_names) + ((fresh,c)::match_acc) ((CAst.make ?loc:(cases_pattern_loc c) @@ Name fresh)::var_acc) + end + | _ -> assert false in + let _,args_rel = + List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in + canonize_args args_rel l forbidden_names_for_gen [] [] in + (Id.Set.of_list (List.map (fun id -> id.CAst.v) ind_ids),alias_subst,match_to_do), + Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) + | None -> + (Id.Set.empty,Id.Map.empty,[]), None in + (tm',(na.CAst.v, typ)), extra_id, match_td + + and intern_impargs c env l subscopes args = + let eargs, rargs = extract_explicit_arg l args in + if !parsing_explicit then + if Id.Map.is_empty eargs then intern_args env subscopes rargs + else user_err Pp.(str "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 + match (impl,rargs) with + | (imp::impl', rargs) when is_status_implicit imp -> + begin try + let id = name_of_implicit imp 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 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 *) + [] + else + (DAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) + (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) + ) :: aux (n+1) impl' subscopes' eargs rargs + end + | (imp::impl', a::rargs') -> + intern enva a :: aux (n+1) impl' subscopes' eargs rargs' + | (imp::impl', []) -> + if not (Id.Map.is_empty eargs) then + (let (id,(loc,_)) = Id.Map.choose eargs in + user_err ?loc (str "Not enough non implicit \ + arguments to accept the argument bound to " ++ + Id.print id ++ str".")); + [] + | ([], rargs) -> + 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 (List.filter (fun (_,x) -> x == None) 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 -> + let loc' = f.CAst.loc in + match DAst.get f with + | GApp (g, args) -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ GApp (g, args@l) + | _ -> DAst.make ?loc:(Loc.merge_opt (loc_of_glob_constr f) loc) @@ GApp (f, l) + + and intern_args env subscopes = function + | [] -> [] + | a::args -> + let (enva,subscopes) = apply_scope_env env subscopes in + (intern enva a) :: (intern_args env subscopes args) + + in + try + intern env c + with + InternalizationError (loc,e) -> + user_err ?loc ~hdr:"internalize" + (explain_internalization_error e) + +(**************************************************************************) +(* Functions to translate constr_expr into glob_constr *) +(**************************************************************************) + +let extract_ids env = + List.fold_right Id.Set.add + (Termops.ids_of_rel_context (Environ.rel_context env)) + Id.Set.empty + +let scope_of_type_kind sigma = function + | IsType -> Notation.current_type_scope_name () + | OfType typ -> compute_type_scope sigma typ + | WithoutTypeConstraint -> None + +let empty_ltac_sign = { + ltac_vars = Id.Set.empty; + ltac_bound = Id.Set.empty; + ltac_extra = Genintern.Store.empty; +} + +let intern_gen kind env sigma + ?(impls=empty_internalization_env) ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) + c = + let tmp_scope = scope_of_type_kind sigma kind in + internalize env {ids = extract_ids env; unb = false; + tmp_scope = tmp_scope; scopes = []; + impls = impls} + pattern_mode (ltacvars, Id.Map.empty) c + +let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c +let intern_type env sigma c = intern_gen IsType env sigma c +let intern_pattern globalenv patt = + try + intern_cases_pattern globalenv Id.Map.empty (None,[]) empty_alias patt + with + InternalizationError (loc,e) -> + user_err ?loc ~hdr:"internalize" (explain_internalization_error e) + + +(*********************************************************************) +(* Functions to parse and interpret constructions *) + +(* All evars resolved *) + +let interp_gen kind env sigma ?(impls=empty_internalization_env) c = + let c = intern_gen kind ~impls env sigma c in + understand ~expected_type:kind env sigma c + +let interp_constr env sigma ?(impls=empty_internalization_env) c = + interp_gen WithoutTypeConstraint env sigma c + +let interp_type env sigma ?(impls=empty_internalization_env) c = + interp_gen IsType env sigma ~impls c + +let interp_casted_constr env sigma ?(impls=empty_internalization_env) c typ = + interp_gen (OfType typ) env sigma ~impls c + +(* Not all evars expected to be resolved *) + +let interp_open_constr env sigma c = + understand_tcc env sigma (intern_constr env sigma c) + +(* Not all evars expected to be resolved and computation of implicit args *) + +let interp_constr_evars_gen_impls ?(program_mode=false) env sigma + ?(impls=empty_internalization_env) expected_type c = + let c = intern_gen expected_type ~impls env sigma c in + let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in + let flags = { Pretyping.all_no_fail_flags with program_mode } in + let sigma, c = understand_tcc ~flags env sigma ~expected_type c in + sigma, (c, imps) + +let interp_constr_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls ?program_mode env sigma ~impls WithoutTypeConstraint c + +let interp_casted_constr_evars_impls ?program_mode env evdref ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen_impls ?program_mode env evdref ~impls (OfType typ) c + +let interp_type_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls ?program_mode env sigma ~impls IsType c + +(* Not all evars expected to be resolved, with side-effect on evars *) + +let interp_constr_evars_gen ?(program_mode=false) env sigma ?(impls=empty_internalization_env) expected_type c = + let c = intern_gen expected_type ~impls env sigma c in + let flags = { Pretyping.all_no_fail_flags with program_mode } in + understand_tcc ~flags env sigma ~expected_type c + +let interp_constr_evars ?program_mode env evdref ?(impls=empty_internalization_env) c = + interp_constr_evars_gen ?program_mode env evdref WithoutTypeConstraint ~impls c + +let interp_casted_constr_evars ?program_mode env sigma ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen ?program_mode env sigma ~impls (OfType typ) c + +let interp_type_evars ?program_mode env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen ?program_mode env sigma IsType ~impls c + +(* Miscellaneous *) + +let intern_constr_pattern env sigma ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = + let c = intern_gen (if as_type then IsType else WithoutTypeConstraint) + ~pattern_mode:true ~ltacvars env sigma c in + pattern_of_glob_constr c + +let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) + { Genintern.intern_ids = ids; Genintern.notation_variable_status = vl } c = + let tmp_scope = scope_of_type_kind sigma kind in + let impls = empty_internalization_env in + internalize env {ids; unb = false; tmp_scope; scopes = []; impls} + pattern_mode (ltacvars, vl) c + +let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = + let ids = extract_ids env in + (* [vl] is intended to remember the scope of the free variables of [a] *) + let vl = Id.Map.map (fun typ -> (ref false, ref None, typ)) nenv.ninterp_var_type in + let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in + let c = internalize env {ids; unb = false; tmp_scope = None; scopes = []; impls} + false (empty_ltac_sign, vl) a in + (* Splits variables into those that are binding, bound, or both *) + (* Translate and check that [c] has all its free variables bound in [vars] *) + let a, reversible = notation_constr_of_glob_constr nenv c in + (* binding and bound *) + let out_scope = function None -> None,[] | Some (a,l) -> a,l in + let unused = match reversible with NonInjective ids -> ids | _ -> [] in + let vars = Id.Map.mapi (fun id (used_as_binder, sc, typ) -> + (!used_as_binder && not (List.mem_f Id.equal id unused), out_scope !sc)) vl in + (* Returns [a] and the ordered list of variables with their scopes *) + vars, a, reversible + +(* Interpret binders and contexts *) + +let interp_binder env sigma na t = + let t = intern_gen IsType env sigma t in + let t' = locate_if_hole ?loc:(loc_of_glob_constr t) na t in + understand ~expected_type:IsType env sigma t' + +let interp_binder_evars env sigma na t = + let t = intern_gen IsType env sigma t in + let t' = locate_if_hole ?loc:(loc_of_glob_constr t) na t in + understand_tcc env sigma ~expected_type:IsType t' + +let my_intern_constr env lvar acc c = + internalize env acc false lvar c + +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 + (fun (lenv, bl) b -> + let (env, bl) = intern_local_binder_aux ~global_level (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in + (env, bl)) + ({ids = extract_ids env; unb = false; + tmp_scope = None; scopes = []; impls = impl_env}, []) binders in + (lenv.impls, List.map glob_local_binder_of_extended bl) + with InternalizationError (loc,e) -> + user_err ?loc ~hdr:"internalize" (explain_internalization_error e) + +let interp_glob_context_evars ?(program_mode=false) env sigma k bl = + let open EConstr in + let flags = { Pretyping.all_no_fail_flags with program_mode } in + let env, sigma, par, _, impls = + List.fold_left + (fun (env,sigma,params,n,impls) (na, k, b, t) -> + let t' = + if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t + else t + in + let sigma, t = understand_tcc ~flags env sigma ~expected_type:IsType t' in + match b with + None -> + let r = Retyping.relevance_of_type env sigma t in + let d = LocalAssum (make_annot na r,t) in + let impls = + 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, sigma, d::params, succ n, impls) + | Some b -> + let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in + let r = Retyping.relevance_of_type env sigma t in + let d = LocalDef (make_annot na r, c, t) in + (push_rel d env, sigma, d::params, n, impls)) + (env,sigma,[],k+1,[]) (List.rev bl) + in sigma, ((env, par), impls) + +let interp_context_evars ?program_mode ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = + let int_env,bl = intern_context global_level env impl_env params in + let sigma, x = interp_glob_context_evars ?program_mode env sigma shift bl in + sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli new file mode 100644 index 0000000000..0d4bc91f57 --- /dev/null +++ b/interp/constrintern.mli @@ -0,0 +1,191 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Evd +open Environ +open Libnames +open Glob_term +open Pattern +open EConstr +open Constrexpr +open Notation_term +open Pretyping + +(** Translation from front abstract syntax of term to untyped terms (glob_constr) *) + +(** The translation performs: + + - resolution of names : + - check all variables are bound + - make absolute the references to global objets + - resolution of symbolic notations using scopes + - insertion of implicit arguments + + To interpret implicit arguments and arg scopes of recursive variables + while internalizing inductive types and recursive definitions, and also + projection while typing records. + + the third and fourth arguments associate a list of implicit + positions and scopes to identifiers declared in the [rel_context] + of [env] *) + +type var_internalization_type = + | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) + | Recursive + | Method + | Variable + +type var_internalization_data = + var_internalization_type * + (* type of the "free" variable, for coqdoc, e.g. while typing the + constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) + + Id.t list * + (* 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) *) + + Impargs.implicit_status list * (* signature of impargs of the variable *) + Notation_term.scope_name option list (* subscopes of the args of the variable *) + +(** A map of free variables to their implicit arguments and scopes *) +type internalization_env = var_internalization_data Id.Map.t + +val empty_internalization_env : internalization_env + +val compute_internalization_data : env -> evar_map -> var_internalization_type -> + types -> Impargs.manual_explicitation list -> var_internalization_data + +val compute_internalization_env : env -> evar_map -> ?impls:internalization_env -> var_internalization_type -> + Id.t list -> types list -> Impargs.manual_explicitation list list -> + internalization_env + +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 *) + ltac_extra : Genintern.Store.t; + (** Arbitrary payload *) +} + +val empty_ltac_sign : ltac_sign + +(** {6 Internalization performs interpretation of global names and notations } *) + +val intern_constr : env -> evar_map -> constr_expr -> glob_constr +val intern_type : env -> evar_map -> constr_expr -> glob_constr + +val intern_gen : typing_constraint -> env -> evar_map -> + ?impls:internalization_env -> ?pattern_mode:bool -> ?ltacvars:ltac_sign -> + constr_expr -> glob_constr + +val intern_pattern : env -> cases_pattern_expr -> + lident list * (Id.t Id.Map.t * cases_pattern) list + +val intern_context : bool -> env -> internalization_env -> local_binder_expr list -> internalization_env * glob_decl list + +(** {6 Composing internalization with type inference (pretyping) } *) + +(** Main interpretation functions, using type class inference, + expecting evars and pending problems to be all resolved *) + +val interp_constr : env -> evar_map -> ?impls:internalization_env -> + constr_expr -> constr Evd.in_evar_universe_context + +val interp_casted_constr : env -> evar_map -> ?impls:internalization_env -> + constr_expr -> types -> constr Evd.in_evar_universe_context + +val interp_type : env -> evar_map -> ?impls:internalization_env -> + constr_expr -> types Evd.in_evar_universe_context + +(** Main interpretation function expecting all postponed problems to + be resolved, but possibly leaving evars. *) + +val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr + +(** Accepting unresolved evars *) + +val interp_constr_evars : ?program_mode:bool -> env -> evar_map -> + ?impls:internalization_env -> constr_expr -> evar_map * constr + +val interp_casted_constr_evars : ?program_mode:bool -> env -> evar_map -> + ?impls:internalization_env -> constr_expr -> types -> evar_map * constr + +val interp_type_evars : ?program_mode:bool -> env -> evar_map -> + ?impls:internalization_env -> constr_expr -> evar_map * types + +(** Accepting unresolved evars and giving back the manual implicit arguments *) + +val interp_constr_evars_impls : ?program_mode:bool -> env -> evar_map -> + ?impls:internalization_env -> constr_expr -> + evar_map * (constr * Impargs.manual_implicits) + +val interp_casted_constr_evars_impls : ?program_mode:bool -> env -> evar_map -> + ?impls:internalization_env -> constr_expr -> types -> + evar_map * (constr * Impargs.manual_implicits) + +val interp_type_evars_impls : ?program_mode:bool -> env -> evar_map -> + ?impls:internalization_env -> constr_expr -> + evar_map * (types * Impargs.manual_implicits) + +(** Interprets constr patterns *) + +val intern_constr_pattern : + env -> evar_map -> ?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 *) +val intern_reference : qualid -> GlobRef.t + +(** Expands abbreviations (syndef); raise an error if not existing *) +val interp_reference : ltac_sign -> qualid -> glob_constr + +(** Interpret binders *) + +val interp_binder : env -> evar_map -> Name.t -> constr_expr -> + types Evd.in_evar_universe_context + +val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * types + +(** Interpret contexts: returns extended env and context *) + +val interp_context_evars : + ?program_mode:bool -> ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> + env -> evar_map -> local_binder_expr list -> + evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) + +(** Locating references of constructions, possibly via a syntactic definition + (these functions do not modify the glob file) *) + +val locate_reference : Libnames.qualid -> GlobRef.t +val is_global : Id.t -> bool + +(** 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 : env -> ?impls:internalization_env -> + notation_interp_env -> constr_expr -> + (bool * subscopes) Id.Map.t * notation_constr * reversibility_status + +(** Idem but to glob_constr (weaker check of binders) *) + +val intern_core : typing_constraint -> + env -> evar_map -> ?pattern_mode:bool -> ?ltacvars:ltac_sign -> + Genintern.intern_variable_status -> constr_expr -> + glob_constr + +(** Globalization options *) +val parsing_explicit : bool ref + +(** Globalization leak for Grammar *) +val for_grammar : ('a -> 'b) -> 'a -> 'b + +(** Placeholder for global option, should be moved to a parameter *) +val get_asymmetric_patterns : unit -> bool diff --git a/interp/declare.ml b/interp/declare.ml new file mode 100644 index 0000000000..76b4bab2ce --- /dev/null +++ b/interp/declare.ml @@ -0,0 +1,579 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This module is about the low-level declaration of logical objects *) + +open Pp +open CErrors +open Util +open Names +open Libnames +open Globnames +open Constr +open Declarations +open Entries +open Libobject +open Lib +open Impargs +open Safe_typing +open Cooking +open Decls +open Decl_kinds + +(** flag for internal message display *) +type internal_flag = + | UserAutomaticRequest (* kernel action, a message is displayed *) + | InternalTacticRequest (* kernel action, no message is displayed *) + | UserIndividualRequest (* user action, a message is displayed *) + +(** Declaration of constants and parameters *) + +type constant_obj = { + cst_decl : global_declaration option; + (** [None] when the declaration is a side-effect and has already been defined + in the global environment. *) + cst_kind : logical_kind; + cst_locl : bool; +} + +type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind + +(* At load-time, the segment starting from the module name to the discharge *) +(* section (if Remark or Fact) is needed to access a construction *) +let load_constant i ((sp,kn), obj) = + if Nametab.exists_cci sp then + alreadydeclared (Id.print (basename sp) ++ str " already exists"); + let con = Global.constant_of_delta_kn kn in + Nametab.push (Nametab.Until i) sp (ConstRef con); + add_constant_kind con obj.cst_kind + +(* Opening means making the name without its module qualification available *) +let open_constant i ((sp,kn), obj) = + (* Never open a local definition *) + if obj.cst_locl then () + else + let con = Global.constant_of_delta_kn kn in + Nametab.push (Nametab.Exactly i) sp (ConstRef con) + +let exists_name id = + variable_exists id || Global.exists_objlabel (Label.of_id id) + +let check_exists sp = + let id = basename sp in + if exists_name id then alreadydeclared (Id.print id ++ str " already exists") + +let cache_constant ((sp,kn), obj) = + let id = basename sp in + let kn' = + match obj.cst_decl with + | None -> + if Global.exists_objlabel (Label.of_id (basename sp)) + then Constant.make1 kn + else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") + | Some decl -> + let () = check_exists sp in + Global.add_constant ~in_section:(Lib.sections_are_opened ()) id decl + in + assert (Constant.equal kn' (Constant.make1 kn)); + Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); + let cst = Global.lookup_constant kn' in + add_section_constant (Declareops.constant_is_polymorphic cst) kn' cst.const_hyps; + add_constant_kind (Constant.make1 kn) obj.cst_kind + +let discharge_constant ((sp, kn), obj) = + let con = Constant.make1 kn in + let from = Global.lookup_constant con in + let modlist = replacement_context () in + let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in + let abstract = (named_of_variable_context hyps, subst, uctx) in + let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in + Some { obj with cst_decl = Some new_decl; } + +(* Hack to reduce the size of .vo: we keep only what load/open needs *) +let dummy_constant cst = { + cst_decl = None; + cst_kind = cst.cst_kind; + cst_locl = cst.cst_locl; +} + +let classify_constant cst = Substitute (dummy_constant cst) + +let (inConstant : constant_obj -> obj) = + declare_object { (default_object "CONSTANT") with + cache_function = cache_constant; + load_function = load_constant; + open_function = open_constant; + classify_function = classify_constant; + subst_function = ident_subst_function; + discharge_function = discharge_constant } + +let declare_scheme = ref (fun _ _ -> assert false) +let set_declare_scheme f = declare_scheme := f + +let update_tables c = + declare_constant_implicits c; + Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) + +let register_side_effect (c, role) = + let o = inConstant { + cst_decl = None; + cst_kind = IsProof Theorem; + cst_locl = false; + } in + let id = Label.to_id (Constant.label c) in + ignore(add_leaf id o); + update_tables c; + match role with + | Subproof -> () + | Schema (ind, kind) -> !declare_scheme kind [|ind,c|] + +let declare_constant_common id cst = + let o = inConstant cst in + let _, kn as oname = add_leaf id o in + pull_to_head oname; + let c = Global.constant_of_delta_kn kn in + update_tables c; + c + +let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types + ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = + { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); + const_entry_secctx = None; + const_entry_type = types; + const_entry_universes = univs; + const_entry_opaque = opaque; + const_entry_feedback = None; + const_entry_inline_code = inline} + +let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = + let is_poly de = match de.const_entry_universes with + | Monomorphic_entry _ -> false + | Polymorphic_entry _ -> true + in + let in_section = Lib.sections_are_opened () in + let export, decl = (* We deal with side effects *) + match cd with + | DefinitionEntry de when + export_seff || + not de.const_entry_opaque || + is_poly de -> + (* This globally defines the side-effects in the environment. We mark + exported constants as being side-effect not to redeclare them at + caching time. *) + let de, export = Global.export_private_constants ~in_section de in + export, ConstantEntry (PureEntry, DefinitionEntry de) + | _ -> [], ConstantEntry (EffectEntry, cd) + in + let () = List.iter register_side_effect export in + let cst = { + cst_decl = Some decl; + cst_kind = kind; + cst_locl = local; + } in + declare_constant_common id cst + +let declare_definition ?(internal=UserIndividualRequest) + ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) + id ?types (body,univs) = + let cb = + definition_entry ?types ~univs ~opaque body + in + declare_constant ~internal ~local id + (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) + +(** Declaration of section variables and local definitions *) +type section_variable_entry = + | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) + +type variable_declaration = DirPath.t * section_variable_entry * logical_kind + +let cache_variable ((sp,_),o) = + match o with + | Inl ctx -> Global.push_context_set false ctx + | Inr (id,(p,d,mk)) -> + (* Constr raisonne sur les noms courts *) + if variable_exists id then + alreadydeclared (Id.print id ++ str " already exists"); + + let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) + | SectionLocalAssum ((ty,ctx),poly,impl) -> + let () = Global.push_named_assum ((id,ty,poly),ctx) in + let impl = if impl then Implicit else Explicit in + impl, true, poly, ctx + | SectionLocalDef (de) -> + let (de, eff) = Global.export_private_constants ~in_section:true de in + let () = List.iter register_side_effect eff in + (* The body should already have been forced upstream because it is a + section-local definition, but it's not enforced by typing *) + let (body, uctx), () = Future.force de.const_entry_body in + let poly, univs = match de.const_entry_universes with + | Monomorphic_entry uctx -> false, uctx + | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx + in + let univs = Univ.ContextSet.union uctx univs in + (* We must declare the universe constraints before type-checking the + term. *) + let () = Global.push_context_set (not poly) univs in + let se = { + secdef_body = body; + secdef_secctx = de.const_entry_secctx; + secdef_feedback = de.const_entry_feedback; + secdef_type = de.const_entry_type; + } in + let () = Global.push_named_def (id, se) in + Explicit, de.const_entry_opaque, + poly, univs in + Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); + add_section_variable id impl poly ctx; + add_variable_data id (p,opaq,ctx,poly,mk) + +let discharge_variable (_,o) = match o with + | Inr (id,_) -> + if variable_polymorphic id then None + else Some (Inl (variable_context id)) + | Inl _ -> Some o + +type variable_obj = + (Univ.ContextSet.t, Id.t * variable_declaration) union + +let inVariable : variable_obj -> obj = + declare_object { (default_object "VARIABLE") with + cache_function = cache_variable; + discharge_function = discharge_variable; + classify_function = (fun _ -> Dispose) } + +(* for initial declaration *) +let declare_variable id obj = + let oname = add_leaf id (inVariable (Inr (id,obj))) in + declare_var_implicits id; + Notation.declare_ref_arguments_scope Evd.empty (VarRef id); + oname + +(** Declaration of inductive blocks *) +let declare_inductive_argument_scopes kn mie = + List.iteri (fun i {mind_entry_consnames=lc} -> + Notation.declare_ref_arguments_scope Evd.empty (IndRef (kn,i)); + for j=1 to List.length lc do + Notation.declare_ref_arguments_scope Evd.empty (ConstructRef ((kn,i),j)); + done) mie.mind_entry_inds + +let inductive_names sp kn mie = + let (dp,_) = repr_path sp in + let kn = Global.mind_of_delta_kn kn in + let names, _ = + List.fold_left + (fun (names, n) ind -> + let ind_p = (kn,n) in + let names, _ = + List.fold_left + (fun (names, p) l -> + let sp = + Libnames.make_path dp l + in + ((sp, ConstructRef (ind_p,p)) :: names, p+1)) + (names, 1) ind.mind_entry_consnames in + let sp = Libnames.make_path dp ind.mind_entry_typename + in + ((sp, IndRef ind_p) :: names, n+1)) + ([], 0) mie.mind_entry_inds + in names + +let load_inductive i ((sp,kn),mie) = + let names = inductive_names sp kn mie in + List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names + +let open_inductive i ((sp,kn),mie) = + let names = inductive_names sp kn mie in + List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names + +let cache_inductive ((sp,kn),mie) = + let names = inductive_names sp kn mie in + List.iter check_exists (List.map fst names); + let id = basename sp in + let kn' = Global.add_mind id mie in + assert (MutInd.equal kn' (MutInd.make1 kn)); + let mind = Global.lookup_mind kn' in + add_section_kn (Declareops.inductive_is_polymorphic mind) kn' mind.mind_hyps; + List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names + +let discharge_inductive ((sp,kn),mie) = + let mind = Global.mind_of_delta_kn kn in + let mie = Global.lookup_mind mind in + let repl = replacement_context () in + let info = section_segment_of_mutual_inductive mind in + Some (Discharge.process_inductive info repl mie) + +let dummy_one_inductive_entry mie = { + mind_entry_typename = mie.mind_entry_typename; + mind_entry_arity = mkProp; + mind_entry_template = false; + mind_entry_consnames = mie.mind_entry_consnames; + mind_entry_lc = [] +} + +(* Hack to reduce the size of .vo: we keep only what load/open needs *) +let dummy_inductive_entry m = { + mind_entry_params = []; + mind_entry_record = None; + mind_entry_finite = Declarations.BiFinite; + mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; + mind_entry_universes = default_univ_entry; + mind_entry_variance = None; + mind_entry_private = None; +} + +(* reinfer subtyping constraints for inductive after section is dischared. *) +let rebuild_inductive mind_ent = + let env = Global.env () in + InferCumulativity.infer_inductive env mind_ent + +let inInductive : mutual_inductive_entry -> obj = + declare_object {(default_object "INDUCTIVE") with + cache_function = cache_inductive; + load_function = load_inductive; + open_function = open_inductive; + classify_function = (fun a -> Substitute (dummy_inductive_entry a)); + subst_function = ident_subst_function; + discharge_function = discharge_inductive; + rebuild_function = rebuild_inductive } + +let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c + +let load_prim _ p = cache_prim p + +let subst_prim (subst,(p,c)) = Mod_subst.subst_proj_repr subst p, Mod_subst.subst_constant subst c + +let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) + +let inPrim : (Projection.Repr.t * Constant.t) -> obj = + declare_object { + (default_object "PRIMPROJS") with + cache_function = cache_prim ; + load_function = load_prim; + subst_function = subst_prim; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_prim } + +let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) + +let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = + let id = Label.to_id label in + let univs, u = match univs with + | Monomorphic_entry _ -> + (* Global constraints already defined through the inductive *) + default_univ_entry, Univ.Instance.empty + | Polymorphic_entry (nas, ctx) -> + Polymorphic_entry (nas, ctx), Univ.UContext.instance ctx + in + let term = Vars.subst_instance_constr u term in + let types = Vars.subst_instance_constr u types in + let entry = definition_entry ~types ~univs term in + let cst = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in + let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in + declare_primitive_projection p cst + + +let declare_projections univs mind = + let env = Global.env () in + let mib = Environ.lookup_mind mind env in + match mib.mind_record with + | PrimRecord info -> + let iter_ind i (_, labs, _, _) = + let ind = (mind, i) in + let projs = Inductiveops.compute_projections env ind in + Array.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs + in + let () = Array.iteri iter_ind info in + true + | FakeRecord -> false + | NotRecord -> false + +(* for initial declaration *) +let declare_mind mie = + let id = match mie.mind_entry_inds with + | ind::_ -> ind.mind_entry_typename + | [] -> anomaly (Pp.str "cannot declare an empty list of inductives.") in + let (sp,kn as oname) = add_leaf id (inInductive mie) in + let mind = Global.mind_of_delta_kn kn in + let isprim = declare_projections mie.mind_entry_universes mind in + declare_mib_implicits mind; + declare_inductive_argument_scopes mind mie; + oname, isprim + +(* Declaration messages *) + +let pr_rank i = pr_nth (i+1) + +let fixpoint_message indexes l = + Flags.if_verbose Feedback.msg_info (match l with + | [] -> anomaly (Pp.str "no recursive definition.") + | [id] -> Id.print id ++ str " is recursively defined" ++ + (match indexes with + | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" + | _ -> mt ()) + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are recursively defined" ++ + match indexes with + | Some a -> spc () ++ str "(decreasing respectively on " ++ + prvect_with_sep pr_comma pr_rank a ++ + str " arguments)" + | None -> mt ())) + +let cofixpoint_message l = + Flags.if_verbose Feedback.msg_info (match l with + | [] -> anomaly (Pp.str "No corecursive definition.") + | [id] -> Id.print id ++ str " is corecursively defined" + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are corecursively defined")) + +let recursive_message isfix i l = + (if isfix then fixpoint_message i else cofixpoint_message) l + +let definition_message id = + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") + +let assumption_message id = + (* Changing "assumed" to "declared", "assuming" referring more to + the type of the object than to the name of the object (see + discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") + +(** Monomorphic universes need to survive sections. *) + +let input_universe_context : Univ.ContextSet.t -> Libobject.obj = + declare_object @@ local_object "Monomorphic section universes" + ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) + ~discharge:(fun (_, x) -> Some x) + +let declare_universe_context poly ctx = + if poly then + (Global.push_context_set true ctx; Lib.add_section_context ctx) + else + Lib.add_anonymous_leaf (input_universe_context ctx) + +(** Global universes are not substitutive objects but global objects + bound at the *library* or *module* level. The polymorphic flag is + used to distinguish universes declared in polymorphic sections, which + are discharged and do not remain in scope. *) + +type universe_source = + | BoundUniv (* polymorphic universe, bound in a function (this will go away someday) *) + | QualifiedUniv of Id.t (* global universe introduced by some global value *) + | UnqualifiedUniv (* other global universe *) + +type universe_name_decl = universe_source * (Id.t * Univ.Level.UGlobal.t) list + +let check_exists sp = + if Nametab.exists_universe sp then + alreadydeclared (str "Universe " ++ Id.print (basename sp) ++ str " already exists") + else () + +let qualify_univ i dp src id = + match src with + | BoundUniv | UnqualifiedUniv -> + i, Libnames.make_path dp id + | QualifiedUniv l -> + let dp = DirPath.repr dp in + Nametab.map_visibility succ i, Libnames.make_path (DirPath.make (l::dp)) id + +let do_univ_name ~check i dp src (id,univ) = + let i, sp = qualify_univ i dp src id in + if check then check_exists sp; + Nametab.push_universe i sp univ + +let cache_univ_names ((sp, _), (src, univs)) = + let depth = sections_depth () in + let dp = pop_dirpath_n depth (dirpath sp) in + List.iter (do_univ_name ~check:true (Nametab.Until 1) dp src) univs + +let load_univ_names i ((sp, _), (src, univs)) = + List.iter (do_univ_name ~check:false (Nametab.Until i) (dirpath sp) src) univs + +let open_univ_names i ((sp, _), (src, univs)) = + List.iter (do_univ_name ~check:false (Nametab.Exactly i) (dirpath sp) src) univs + +let discharge_univ_names = function + | _, (BoundUniv, _) -> None + | _, ((QualifiedUniv _ | UnqualifiedUniv), _ as x) -> Some x + +let input_univ_names : universe_name_decl -> Libobject.obj = + declare_object + { (default_object "Global universe name state") with + cache_function = cache_univ_names; + load_function = load_univ_names; + open_function = open_univ_names; + discharge_function = discharge_univ_names; + subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); + classify_function = (fun a -> Substitute a) } + +let declare_univ_binders gr pl = + if Global.is_polymorphic gr then + () + else + let l = match gr with + | ConstRef c -> Label.to_id @@ Constant.label c + | IndRef (c, _) -> Label.to_id @@ MutInd.label c + | VarRef id -> anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") + | ConstructRef _ -> + anomaly ~label:"declare_univ_binders" + Pp.(str "declare_univ_binders on an constructor reference") + in + let univs = Id.Map.fold (fun id univ univs -> + match Univ.Level.name univ with + | None -> assert false (* having Prop/Set/Var as binders is nonsense *) + | Some univ -> (id,univ)::univs) pl [] + in + Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) + +let do_universe poly l = + let in_section = Lib.sections_are_opened () in + let () = + if poly && not in_section then + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic universes outside sections") + in + let l = List.map (fun {CAst.v=id} -> (id, UnivGen.new_univ_global ())) l in + let ctx = List.fold_left (fun ctx (_,qid) -> Univ.LSet.add (Univ.Level.make qid) ctx) + Univ.LSet.empty l, Univ.Constraint.empty + in + let () = declare_universe_context poly ctx in + let src = if poly then BoundUniv else UnqualifiedUniv in + Lib.add_anonymous_leaf (input_univ_names (src, l)) + +let do_constraint poly l = + let open Univ in + let u_of_id x = + let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in + Lib.is_polymorphic_univ level, level + in + let in_section = Lib.sections_are_opened () in + let () = + if poly && not in_section then + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic constraints outside sections") + in + let check_poly p p' = + if poly then () + else if p || p' then + user_err ~hdr:"Constraint" + (str "Cannot declare a global constraint on " ++ + str "a polymorphic universe, use " + ++ str "Polymorphic Constraint instead") + in + let constraints = List.fold_left (fun acc (l, d, r) -> + let p, lu = u_of_id l and p', ru = u_of_id r in + check_poly p p'; + Constraint.add (lu, d, ru) acc) + Constraint.empty l + in + let uctx = ContextSet.add_constraints constraints ContextSet.empty in + declare_universe_context poly uctx diff --git a/interp/declare.mli b/interp/declare.mli new file mode 100644 index 0000000000..8f1e73c88c --- /dev/null +++ b/interp/declare.mli @@ -0,0 +1,91 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Entries +open Decl_kinds + +(** This module provides the official functions to declare new variables, + parameters, constants and inductive types. Using the following functions + will add the entries in the global environment (module [Global]), will + register the declarations in the library (module [Lib]) --- so that the + reset works properly --- and will fill some global tables such as + [Nametab] and [Impargs]. *) + +(** Declaration of local constructions (Variable/Hypothesis/Local) *) + +type section_variable_entry = + | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) + +type variable_declaration = DirPath.t * section_variable_entry * logical_kind + +val declare_variable : variable -> variable_declaration -> Libobject.object_name + +(** Declaration of global constructions + i.e. Definition/Theorem/Axiom/Parameter/... *) + +type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind + +type internal_flag = + | UserAutomaticRequest + | InternalTacticRequest + | UserIndividualRequest + +(* Defaut definition entries, transparent with no secctx or proj information *) +val definition_entry : ?fix_exn:Future.fix_exn -> + ?opaque:bool -> ?inline:bool -> ?types:types -> + ?univs:Entries.universes_entry -> + ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry + +(** [declare_constant id cd] declares a global declaration + (constant/parameter) with name [id] in the current section; it returns + the full path of the declaration + + internal specify if the constant has been created by the kernel or by the + user, and in the former case, if its errors should be silent *) +val declare_constant : + ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t + +val declare_definition : + ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> + ?local:bool -> Id.t -> ?types:constr -> + constr Entries.in_universes_entry -> Constant.t + +(** Since transparent constants' side effects are globally declared, we + * need that *) +val set_declare_scheme : + (string -> (inductive * Constant.t) array -> unit) -> unit + +(** [declare_mind me] declares a block of inductive types with + their constructors in the current section; it returns the path of + the whole block and a boolean indicating if it is a primitive record. *) +val declare_mind : mutual_inductive_entry -> Libobject.object_name * bool + +(** Declaration messages *) + +val definition_message : Id.t -> unit +val assumption_message : Id.t -> unit +val fixpoint_message : int array option -> Id.t list -> unit +val cofixpoint_message : Id.t list -> unit +val recursive_message : bool (** true = fixpoint *) -> + int array option -> Id.t list -> unit + +val exists_name : Id.t -> bool + +(** Global universe contexts, names and constraints *) +val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit + +val declare_universe_context : polymorphic -> Univ.ContextSet.t -> unit + +val do_universe : polymorphic -> lident list -> unit +val do_constraint : polymorphic -> (Glob_term.glob_level * Univ.constraint_type * Glob_term.glob_level) list -> + unit diff --git a/interp/discharge.ml b/interp/discharge.ml new file mode 100644 index 0000000000..1efd13adb1 --- /dev/null +++ b/interp/discharge.ml @@ -0,0 +1,118 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Term +open Constr +open Vars +open Declarations +open Cooking +open Entries + +(********************************) +(* Discharging mutual inductive *) + +(* Replace + + Var(y1)..Var(yq):C1..Cq |- Ij:Bj + Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti + + by + + |- Ij: (y1..yq:C1..Cq)Bj + I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] +*) + +let abstract_inductive decls nparamdecls inds = + let ntyp = List.length inds in + let ndecls = Context.Named.length decls in + let args = Context.Named.to_instance mkVar (List.rev decls) in + let args = Array.of_list args in + let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in + let inds' = + List.map + (function (tname,arity,template,cnames,lc) -> + let lc' = List.map (substl subs) lc in + let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b decls) lc' in + let arity' = Termops.it_mkNamedProd_wo_LetIn arity decls in + (tname,arity',template,cnames,lc'')) + inds in + let nparamdecls' = nparamdecls + Array.length args in +(* To be sure to be the same as before, should probably be moved to process_inductive *) + let params' = let (_,arity,_,_,_) = List.hd inds' in + let (params,_) = decompose_prod_n_assum nparamdecls' arity in + params + in + let ind'' = + List.map + (fun (a,arity,template,c,lc) -> + let _, short_arity = decompose_prod_n_assum nparamdecls' arity in + let shortlc = + List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in + { mind_entry_typename = a; + mind_entry_arity = short_arity; + mind_entry_template = template; + mind_entry_consnames = c; + mind_entry_lc = shortlc }) + inds' + in (params',ind'') + +let refresh_polymorphic_type_of_inductive (_,mip) = + match mip.mind_arity with + | RegularArity s -> s.mind_user_arity, false + | TemplateArity ar -> + let ctx = List.rev mip.mind_arity_ctxt in + mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true + +let process_inductive info modlist mib = + let section_decls = Lib.named_of_variable_context info.Lib.abstr_ctx in + let nparamdecls = Context.Rel.length mib.mind_params_ctxt in + let subst, ind_univs = + match mib.mind_universes with + | Monomorphic ctx -> Univ.empty_level_subst, Monomorphic_entry ctx + | Polymorphic auctx -> + let subst, auctx = Lib.discharge_abstract_universe_context info auctx in + let nas = Univ.AUContext.names auctx in + let auctx = Univ.AUContext.repr auctx in + subst, Polymorphic_entry (nas, auctx) + in + let variance = match mib.mind_variance with + | None -> None + | Some _ -> Some (InferCumulativity.dummy_variance ind_univs) + in + let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in + let inds = + Array.map_to_list + (fun mip -> + let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in + let arity = discharge ty in + let lc = Array.map discharge mip.mind_user_lc in + (mip.mind_typename, + arity, template, + Array.to_list mip.mind_consnames, + Array.to_list lc)) + mib.mind_packets in + let section_decls' = Context.Named.map discharge section_decls in + let (params',inds') = abstract_inductive section_decls' nparamdecls inds in + let record = match mib.mind_record with + | PrimRecord info -> + Some (Some (Array.map (fun (x,_,_,_) -> x) info)) + | FakeRecord -> Some None + | NotRecord -> None + in + { mind_entry_record = record; + mind_entry_finite = mib.mind_finite; + mind_entry_params = params'; + mind_entry_inds = inds'; + mind_entry_private = mib.mind_private; + mind_entry_variance = variance; + mind_entry_universes = ind_univs + } + diff --git a/interp/discharge.mli b/interp/discharge.mli new file mode 100644 index 0000000000..f7408937cf --- /dev/null +++ b/interp/discharge.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Declarations +open Entries +open Opaqueproof + +val process_inductive : + Lib.abstr_info -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/interp/doc.tex b/interp/doc.tex new file mode 100644 index 0000000000..4ce5811da3 --- /dev/null +++ b/interp/doc.tex @@ -0,0 +1,14 @@ + +\newpage +\section*{The interpretation of Coq front abstract syntax of terms} + +\ocwsection \label{interp} +This chapter describes the translation from \Coq\ context-dependent +front abstract syntax of terms (\verb=front=) to and from the +context-free, untyped, globalized form of constructions (\verb=glob_constr=). + +The modules translating back and forth the front abstract syntax are +organized as follows. + +\bigskip +\begin{center}\epsfig{file=interp.dep.ps}\end{center} diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml new file mode 100644 index 0000000000..a537b4848c --- /dev/null +++ b/interp/dumpglob.ml @@ -0,0 +1,275 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util + +(* Dump of globalization (to be used by coqdoc) *) + +let glob_file = ref Pervasives.stdout + +let open_glob_file f = + glob_file := Pervasives.open_out f + +let close_glob_file () = + Pervasives.close_out !glob_file + +type glob_output_t = + | NoGlob + | StdOut + | MultFiles + | Feedback + | File of string + +let glob_output = ref NoGlob + +let dump () = !glob_output != NoGlob + +let noglob () = glob_output := NoGlob + +let dump_to_dotglob () = glob_output := MultFiles + +let dump_into_file f = + if String.equal f "stdout" then + (glob_output := StdOut; glob_file := Pervasives.stdout) + else + (glob_output := File f; open_glob_file f) + +let feedback_glob () = glob_output := Feedback + +let dump_string s = + if dump () && !glob_output != Feedback then + Pervasives.output_string !glob_file s + +let start_dump_glob ~vfile ~vofile = + match !glob_output with + | MultFiles -> + open_glob_file (Filename.chop_extension vofile ^ ".glob"); + output_string !glob_file "DIGEST "; + output_string !glob_file (Digest.to_hex (Digest.file vfile)); + output_char !glob_file '\n' + | File f -> + open_glob_file f; + output_string !glob_file "DIGEST NO\n" + | NoGlob | Feedback | StdOut -> + () + +let end_dump_glob () = + match !glob_output with + | MultFiles | File _ -> close_glob_file () + | NoGlob | Feedback | StdOut -> () + +let previous_state = ref MultFiles +let pause () = previous_state := !glob_output; glob_output := NoGlob +let continue () = glob_output := !previous_state + +open Decl_kinds +open Declarations + +let type_of_logical_kind = function + | IsDefinition def -> + (match def with + | Definition | Let -> "def" + | Coercion -> "coe" + | SubClass -> "subclass" + | CanonicalStructure -> "canonstruc" + | Example -> "ex" + | Fixpoint -> "def" + | CoFixpoint -> "def" + | Scheme -> "scheme" + | StructureComponent -> "proj" + | IdentityCoercion -> "coe" + | Instance -> "inst" + | Method -> "meth") + | IsAssumption a -> + (match a with + | Definitional -> "defax" + | Logical -> "prfax" + | Conjectural -> "prfax") + | IsProof th -> + (match th with + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary -> "thm") + | IsPrimitive -> "prim" + +let type_of_global_ref gr = + if Typeclasses.is_class gr then + "class" + else + match gr with + | Globnames.ConstRef cst -> + type_of_logical_kind (Decls.constant_kind cst) + | Globnames.VarRef v -> + "var" ^ type_of_logical_kind (Decls.variable_kind v) + | Globnames.IndRef ind -> + let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in + if mib.Declarations.mind_record <> Declarations.NotRecord then + begin match mib.Declarations.mind_finite with + | Finite -> "indrec" + | BiFinite -> "rec" + | CoFinite -> "corec" + end + else + begin match mib.Declarations.mind_finite with + | Finite -> "ind" + | BiFinite -> "variant" + | CoFinite -> "coind" + end + | Globnames.ConstructRef _ -> "constr" + +let remove_sections dir = + let cwd = Lib.cwd_except_section () in + if Libnames.is_dirpath_prefix_of cwd dir then + (* Not yet (fully) discharged *) + cwd + else + (* Theorem/Lemma outside its outer section of definition *) + dir + +let interval loc = + let loc1,loc2 = Loc.unloc loc in + loc1, loc2-1 + +let dump_ref ?loc filepath modpath ident ty = + match !glob_output with + | Feedback -> + Option.iter (fun loc -> + Feedback.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) + ) loc + | NoGlob -> () + | _ -> Option.iter (fun loc -> + let bl,el = interval loc in + dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" + bl el filepath modpath ident ty) + ) loc + +let dump_reference ?loc modpath ident ty = + let filepath = Names.DirPath.to_string (Lib.library_dp ()) in + dump_ref ?loc filepath modpath ident ty + +let dump_modref ?loc mp ty = + 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 = + dump_ref ?loc (Names.DirPath.to_string dp) "<>" "<>" ty + +let cook_notation (from,df) sc = + (* We encode notations so that they are space-free and still human-readable *) + (* - all spaces are replaced by _ *) + (* - all _ denoting a non-terminal symbol are replaced by x *) + (* - all terminal tokens are surrounded by single quotes, including '_' *) + (* which already denotes terminal _ *) + (* - all single quotes in terminal tokens are doubled *) + (* - characters < 32 are represented by '^A, '^B, '^C, etc *) + (* The output is decoded in function Index.prepare_entry of coqdoc *) + let ntn = Bytes.make (String.length df * 5) '_' in + let j = ref 0 in + let l = String.length df - 1 in + let i = ref 0 in + let open Bytes in (* Bytes.set *) + while !i <= l do + assert (df.[!i] != ' '); + if df.[!i] == '_' && (Int.equal !i l || df.[!i+1] == ' ') then + (* Next token is a non-terminal *) + (set ntn !j 'x'; incr j; incr i) + else begin + (* Next token is a terminal *) + set ntn !j '\''; incr j; + 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 (set ntn !j '\''; incr j); + set ntn !j df.[!i]; incr j; incr i + end + done; + set ntn !j '\''; incr j + end; + if !i <= l then (set ntn !j '_'; incr j; incr i) + done; + let df = Bytes.sub_string ntn 0 !j in + let df_sc = match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df in + let from_df_sc = match from with Constrexpr.InCustomEntryLevel (from,_) -> ":" ^ from ^ df_sc | Constrexpr.InConstrEntrySomeLevel -> ":" ^ df_sc in + from_df_sc + +let dump_notation_location posl df (((path,secpath),_),sc) = + if dump () then + 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 l -> + dump_ref ~loc:(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 () 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,l = Names.KerName.repr kn in + Names.MPdot (mp,l) + +let add_glob_kn ?loc kn = + if dump () 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 ?loc ty secpath id = Option.iter (fun loc -> + if !glob_output = Feedback then + Feedback.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) + ) loc + +let dump_definition {CAst.loc;v=id} sec s = + dump_def ?loc s (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) + +let dump_constraint { CAst.loc; v = n } sec ty = + match n with + | Names.Name id -> dump_definition CAst.(make ?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 ?loc ty "<>" mp + +let dump_notation (loc,(df,_)) sc sec = Option.iter (fun loc -> + (* 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 ~loc:location "not" (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc) + ) loc diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli new file mode 100644 index 0000000000..554da7603f --- /dev/null +++ b/interp/dumpglob.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val open_glob_file : string -> unit +val close_glob_file : unit -> unit + +val start_dump_glob : vfile:string -> vofile:string -> unit +val end_dump_glob : unit -> unit + +val dump : unit -> bool + +val noglob : unit -> 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 + +val add_glob : ?loc:Loc.t -> Names.GlobRef.t -> unit +val add_glob_kn : ?loc:Loc.t -> Names.KerName.t -> unit + +val dump_definition : Names.lident -> bool -> string -> unit +val dump_moddef : ?loc:Loc.t -> Names.ModPath.t -> string -> unit +val dump_modref : ?loc:Loc.t -> Names.ModPath.t -> string -> unit +val dump_reference : ?loc:Loc.t -> string -> string -> string -> unit +val dump_libref : ?loc: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:Loc.t -> Names.Id.Set.elt -> unit +val dump_notation : + (Constrexpr.notation * Notation.notation_location) Loc.located -> + Notation_term.scope_name option -> bool -> unit + +val dump_constraint : Names.lname -> bool -> string -> unit + +val dump_string : string -> unit + +val type_of_global_ref : Names.GlobRef.t -> string diff --git a/interp/dune b/interp/dune new file mode 100644 index 0000000000..e9ef7ba99a --- /dev/null +++ b/interp/dune @@ -0,0 +1,6 @@ +(library + (name interp) + (synopsis "Coq's Syntactic Interpretation for AST [notations, implicits]") + (public_name coq.interp) + (wrapped false) + (libraries pretyping)) diff --git a/interp/genintern.ml b/interp/genintern.ml new file mode 100644 index 0000000000..1b736b7977 --- /dev/null +++ b/interp/genintern.ml @@ -0,0 +1,103 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Mod_subst +open Genarg + +module Store = Store.Make () + +type intern_variable_status = { + intern_ids : Id.Set.t; + notation_variable_status : + (bool ref * Notation_term.subscopes option ref * + Notation_term.notation_var_internalization_type) + Id.Map.t +} + +type glob_sign = { + ltacvars : Id.Set.t; + genv : Environ.env; + extra : Store.t; + intern_sign : intern_variable_status; +} + +let empty_intern_sign = { + intern_ids = Id.Set.empty; + notation_variable_status = Id.Map.empty; +} + +let empty_glob_sign env = { + ltacvars = Id.Set.empty; + genv = env; + extra = Store.empty; + intern_sign = empty_intern_sign; +} + +(** 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_term.glob_constr * Constrexpr.constr_expr option +type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern + +type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb +type 'glb subst_fun = substitution -> 'glb -> 'glb +type 'glb ntn_subst_fun = glob_constr_and_expr Id.Map.t -> '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 NtnSubstObj = +struct + type ('raw, 'glb, 'top) obj = 'glb ntn_subst_fun + let name = "notation_subst" + let default _ = None +end + +module Intern = Register (InternObj) +module Subst = Register (SubstObj) +module NtnSubst = Register (NtnSubstObj) + +let intern = Intern.obj +let register_intern0 = Intern.register0 + +let generic_intern ist (GenArg (Rawwit wit, v)) = + let (ist, v) = intern wit ist v in + (ist, in_gen (glbwit wit) v) + +(** Substitution functions *) + +let substitute = Subst.obj +let register_subst0 = Subst.register0 + +let generic_substitute subs (GenArg (Glbwit wit, v)) = + in_gen (glbwit wit) (substitute wit subs v) + +let () = Hook.set Detyping.subst_genarg_hook generic_substitute + +(** Notation substitution *) + +let substitute_notation = NtnSubst.obj +let register_ntn_subst0 = NtnSubst.register0 + +let generic_substitute_notation env (GenArg (Glbwit wit, v)) = + let v = substitute_notation wit env v in + in_gen (glbwit wit) v diff --git a/interp/genintern.mli b/interp/genintern.mli new file mode 100644 index 0000000000..4100f39029 --- /dev/null +++ b/interp/genintern.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Mod_subst +open Genarg + +module Store : Store.S + +type intern_variable_status = { + intern_ids : Id.Set.t; + notation_variable_status : + (bool ref * Notation_term.subscopes option ref * + Notation_term.notation_var_internalization_type) + Id.Map.t +} + +type glob_sign = { + ltacvars : Id.Set.t; + genv : Environ.env; + extra : Store.t; + intern_sign : intern_variable_status; +} + +val empty_glob_sign : Environ.env -> glob_sign + +(** 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_term.glob_constr * Constrexpr.constr_expr option +type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern + +(** {5 Internalization functions} *) + +type ('raw, 'glb) intern_fun = glob_sign -> '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 + +(** {5 Notation functions} *) + +type 'glb ntn_subst_fun = glob_constr_and_expr Id.Map.t -> 'glb -> 'glb + +val substitute_notation : ('raw, 'glb, 'top) genarg_type -> 'glb ntn_subst_fun + +val generic_substitute_notation : glob_generic_argument ntn_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 + +val register_ntn_subst0 : ('raw, 'glb, 'top) genarg_type -> + 'glb ntn_subst_fun -> unit diff --git a/interp/impargs.ml b/interp/impargs.ml new file mode 100644 index 0000000000..d83a0ce918 --- /dev/null +++ b/interp/impargs.ml @@ -0,0 +1,796 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Pp +open Util +open Names +open Constr +open Globnames +open Declarations +open Decl_kinds +open Lib +open Libobject +open EConstr +open Reductionops +open Constrexpr +open Namegen + +module NamedDecl = Context.Named.Declaration + +(*s Flags governing the computation of implicit arguments *) + +type implicits_flags = { + auto : bool; (* automatic or manual only *) + strict : bool; (* true = strict *) + strongly_strict : bool; (* true = strongly strict *) + reversible_pattern : bool; + contextual : bool; (* true = contextual *) + maximal : bool +} + +let implicit_args = ref { + auto = false; + strict = true; + strongly_strict = false; + reversible_pattern = false; + contextual = false; + maximal = false; +} + +let make_implicit_args flag = + implicit_args := { !implicit_args with auto = flag } + +let make_strict_implicit_args flag = + implicit_args := { !implicit_args with strict = flag } + +let make_strongly_strict_implicit_args flag = + implicit_args := { !implicit_args with strongly_strict = flag } + +let make_reversible_pattern_implicit_args flag = + implicit_args := { !implicit_args with reversible_pattern = flag } + +let make_contextual_implicit_args flag = + implicit_args := { !implicit_args with contextual = flag } + +let make_maximal_implicit_args flag = + implicit_args := { !implicit_args with maximal = flag } + +let is_implicit_args () = !implicit_args.auto +let is_strict_implicit_args () = !implicit_args.strict +let is_strongly_strict_implicit_args () = !implicit_args.strongly_strict +let is_reversible_pattern_implicit_args () = !implicit_args.reversible_pattern +let is_contextual_implicit_args () = !implicit_args.contextual +let is_maximal_implicit_args () = !implicit_args.maximal + +let with_implicit_protection f x = + let oflags = !implicit_args in + try + let rslt = f x in + implicit_args := oflags; + rslt + with reraise -> + let reraise = CErrors.push reraise in + let () = implicit_args := oflags in + iraise reraise + +let set_maximality imps b = + (* Force maximal insertion on ending implicits (compatibility) *) + let is_set x = match x with None -> false | _ -> true in + b || List.for_all is_set imps + +(*s Computation of implicit arguments *) + +(* We remember various information about why an argument is + inferable as implicit + +- [DepRigid] means that the implicit argument can be found by + unification along a rigid path (we do not print the arguments of + this kind if there is enough arguments to infer them) + +- [DepFlex] means that the implicit argument can be found by unification + along a collapsable path only (e.g. as x in (P x) where P is another + argument) (we do (defensively) print the arguments of this kind) + +- [DepFlexAndRigid] means that the least argument from which the + implicit argument can be inferred is following a collapsable path + but there is a greater argument from where the implicit argument is + inferable following a rigid path (useful to know how to print a + partial application) + +- [Manual] means the argument has been explicitly set as implicit. + + We also consider arguments inferable from the conclusion but it is + operational only if [conclusion_matters] is true. +*) + +type argument_position = + | Conclusion + | Hyp of int + +let argument_position_eq p1 p2 = match p1, p2 with +| Conclusion, Conclusion -> true +| Hyp h1, Hyp h2 -> Int.equal h1 h2 +| _ -> false + +let explicitation_eq = Constrexpr_ops.explicitation_eq + +type implicit_explanation = + | DepRigid of argument_position + | DepFlex of argument_position + | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position + | Manual + +let argument_less = function + | Hyp n, Hyp n' -> n<n' + | Hyp _, Conclusion -> true + | Conclusion, _ -> false + +let update pos rig st = + let e = + if rig then + match st with + | None -> DepRigid pos + | Some (DepRigid n as x) -> + if argument_less (pos,n) then DepRigid pos else x + | Some (DepFlexAndRigid (fpos,rpos) as x) -> + if argument_less (pos,fpos) || argument_position_eq pos fpos then DepRigid pos else + if argument_less (pos,rpos) then DepFlexAndRigid (fpos,pos) else x + | Some (DepFlex fpos) -> + if argument_less (pos,fpos) || argument_position_eq pos fpos then DepRigid pos + else DepFlexAndRigid (fpos,pos) + | Some Manual -> assert false + else + match st with + | None -> DepFlex pos + | Some (DepRigid rpos as x) -> + if argument_less (pos,rpos) then DepFlexAndRigid (pos,rpos) else x + | Some (DepFlexAndRigid (fpos,rpos) as x) -> + if argument_less (pos,fpos) then DepFlexAndRigid (pos,rpos) else x + | Some (DepFlex fpos as x) -> + if argument_less (pos,fpos) then DepFlex pos else x + | Some Manual -> assert false + in Some e + +(* modified is_rigid_reference with a truncated env *) +let is_flexible_reference env sigma bound depth f = + match kind sigma f with + | Rel n when n >= bound+depth -> (* inductive type *) false + | Rel n when n >= depth -> (* previous argument *) true + | Rel n -> (* since local definitions have been expanded *) false + | Const (kn,_) -> + let cb = Environ.lookup_constant kn env in + (match cb.const_body with Def _ -> true | _ -> false) + | Var id -> + env |> Environ.lookup_named id |> NamedDecl.is_local_def + | Ind _ | Construct _ -> false + | _ -> true + +let push_lift d (e,n) = (push_rel d e,n+1) + +let is_reversible_pattern sigma bound depth f l = + isRel sigma f && let n = destRel sigma f in (n < bound+depth) && (n >= depth) && + Array.for_all (fun c -> isRel sigma c && destRel sigma c < depth) l && + Array.distinct l + +(* Precondition: rels in env are for inductive types only *) +let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc = + let rec frec rig (env,depth as ed) c = + let hd = if strict then whd_all env sigma c else c in + let c = if strongly_strict then hd else c in + match kind sigma hd with + | Rel n when (n < bound+depth) && (n >= depth) -> + let i = bound + depth - n - 1 in + acc.(i) <- update pos rig acc.(i) + | App (f,l) when revpat && is_reversible_pattern sigma bound depth f l -> + let i = bound + depth - EConstr.destRel sigma f - 1 in + acc.(i) <- update pos rig acc.(i) + | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> + if strict then () else + iter_with_full_binders sigma push_lift (frec false) ed c + | Proj (p, _) when rig -> + if strict then () else + iter_with_full_binders sigma push_lift (frec false) ed c + | Case _ when rig -> + if strict then () else + iter_with_full_binders sigma push_lift (frec false) ed c + | Evar _ -> () + | _ -> + iter_with_full_binders sigma push_lift (frec rig) ed c + in + let () = if not (Vars.noccur_between sigma 1 bound m) then frec true (env,1) m in + acc + +(* compute the list of implicit arguments *) + +let rec is_rigid_head sigma t = match kind sigma t with + | Rel _ | Evar _ -> false + | Ind _ | Const _ | Var _ | Sort _ -> true + | Case (_,_,f,_) -> is_rigid_head sigma f + | Proj (p,c) -> true + | App (f,args) -> + (match kind sigma f with + | Fix ((fi,i),_) -> is_rigid_head sigma (args.(fi.(i))) + | _ -> is_rigid_head sigma f) + | Lambda _ | LetIn _ | Construct _ | CoFix _ | Fix _ + | Prod _ | Meta _ | Cast _ | Int _ -> assert false + +let is_rigid env sigma t = + let open Context.Rel.Declaration in + let t = whd_all env sigma t in + match kind sigma t with + | Prod (na,a,b) -> + let (_,t) = splay_prod (push_rel (LocalAssum (na,a)) env) sigma b in + is_rigid_head sigma t + | _ -> true + +let find_displayed_name_in sigma all avoid na (env, b) = + let envnames_b = (env, b) in + let flag = RenamingElsewhereFor envnames_b in + if all then compute_and_force_displayed_name_in sigma flag avoid na b + else compute_displayed_name_in sigma flag avoid na b + +let compute_implicits_names_gen all env sigma t = + let open Context.Rel.Declaration in + let rec aux env avoid names t = + let t = whd_all env sigma t in + match kind sigma t with + | Prod (na,a,b) -> + let na',avoid' = find_displayed_name_in sigma all avoid na.Context.binder_name (names,b) in + aux (push_rel (LocalAssum (na,a)) env) avoid' (na'::names) b + | _ -> List.rev names + in aux env Id.Set.empty [] t + +let compute_implicits_names = compute_implicits_names_gen true + +let compute_implicits_explanation_gen strict strongly_strict revpat contextual env sigma t = + let open Context.Rel.Declaration in + let rec aux env n t = + let t = whd_all env sigma t in + match kind sigma t with + | Prod (na,a,b) -> + add_free_rels_until strict strongly_strict revpat n env sigma a (Hyp (n+1)) + (aux (push_rel (LocalAssum (na,a)) env) (n+1) b) + | _ -> + let v = Array.make n None in + if contextual then + add_free_rels_until strict strongly_strict revpat n env sigma t Conclusion v + else v + in + match kind sigma (whd_all env sigma t) with + | Prod (na,a,b) -> + let v = aux (push_rel (LocalAssum (na,a)) env) 1 b in + Array.to_list v + | _ -> [] + +let compute_implicits_explanation_flags env sigma f t = + compute_implicits_explanation_gen + (f.strict || f.strongly_strict) f.strongly_strict + f.reversible_pattern f.contextual env sigma t + +let compute_implicits_flags env sigma f all t = + List.combine + (compute_implicits_names_gen all env sigma t) + (compute_implicits_explanation_flags env sigma f t) + +let compute_auto_implicits env sigma flags enriching t = + List.combine + (compute_implicits_names env sigma t) + (if enriching then compute_implicits_explanation_flags env sigma flags t + else compute_implicits_explanation_gen false false false true env sigma t) + +(* Extra information about implicit arguments *) + +type maximal_insertion = bool (* true = maximal contextual insertion *) +type force_inference = bool (* true = always infer, never turn into evar/subgoal *) + +type implicit_status = + (* None = Not implicit *) + (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option + +type implicit_side_condition = DefaultImpArgs | LessArgsThan of int + +type implicits_list = implicit_side_condition * implicit_status list + +let is_status_implicit = function + | None -> false + | _ -> true + +let name_of_implicit = function + | None -> anomaly (Pp.str "Not an implicit argument.") + | Some (id,_,_) -> id + +let maximal_insertion_of = function + | Some (_,_,(b,_)) -> b + | None -> anomaly (Pp.str "Not an implicit argument.") + +let force_inference_of = function + | Some (_, _, (_, b)) -> b + | None -> anomaly (Pp.str "Not an implicit argument.") + +(* [in_ctx] means we know the expected type, [n] is the index of the argument *) +let is_inferable_implicit in_ctx n = function + | None -> false + | Some (_,DepRigid (Hyp p),_) -> in_ctx || n >= p + | Some (_,DepFlex (Hyp p),_) -> false + | Some (_,DepFlexAndRigid (_,Hyp q),_) -> in_ctx || n >= q + | Some (_,DepRigid Conclusion,_) -> in_ctx + | Some (_,DepFlex Conclusion,_) -> false + | Some (_,DepFlexAndRigid (_,Conclusion),_) -> in_ctx + | Some (_,Manual,_) -> true + +let positions_of_implicits (_,impls) = + let rec aux n = function + [] -> [] + | Some _ :: l -> n :: aux (n+1) l + | None :: l -> aux (n+1) l + in aux 1 impls + +(* Manage user-given implicit arguments *) + +let rec prepare_implicits f = function + | [] -> [] + | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit.") + | (Name id, Some imp)::imps -> + let imps' = prepare_implicits f imps in + Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' + | _::imps -> None :: prepare_implicits f imps + +(* +If found, returns Some (x,(b,fi,fo)) and l with the entry removed, +otherwise returns None and l unchanged. + *) +let assoc_by_pos k l = + let rec aux = function + (ExplByPos (k', x), b) :: tl when Int.equal k k' -> Some (x,b), tl + | hd :: tl -> let (x, tl) = aux tl in x, hd :: tl + | [] -> raise Not_found + in try aux l with Not_found -> None, l + +let check_correct_manual_implicits autoimps l = + List.iter (function + | ExplByName id,(b,fi,forced) -> + if not forced then + user_err + (str "Wrong or non-dependent implicit argument name: " ++ Id.print id ++ str ".") + | ExplByPos (i,_id),_t -> + if i<1 || i>List.length autoimps then + user_err + (str "Bad implicit argument number: " ++ int i ++ str ".") + else + user_err + (str "Cannot set implicit argument number " ++ int i ++ + str ": it has no name.")) l + +(* Take a list l of explicitations, and map them to positions. *) +let flatten_explicitations l autoimps = + let rec aux k l = function + | (Name id,_)::imps -> + let value, l' = + try + let eq = Constrexpr_ops.explicitation_eq in + let flags = List.assoc_f eq (ExplByName id) l in + Some (Some id, flags), List.remove_assoc_f eq (ExplByName id) l + with Not_found -> assoc_by_pos k l + in value :: aux (k+1) l' imps + | (Anonymous,_)::imps -> + let value, l' = assoc_by_pos k l + in value :: aux (k+1) l' imps + | [] when List.is_empty l -> [] + | [] -> + check_correct_manual_implicits autoimps l; + [] + in aux 1 l autoimps + +let set_manual_implicits flags enriching autoimps l = + if not (List.distinct l) then + user_err Pp.(str "Some parameters are referred more than once."); + (* Compare with automatic implicits to recover printing data and names *) + let rec merge k autoimps explimps = match autoimps, explimps with + | autoimp::autoimps, explimp::explimps -> + let imps' = merge (k+1) autoimps explimps in + begin match autoimp, explimp with + | (Name id,_), Some (_, (b, fi, _)) -> + Some (id, Manual, (set_maximality imps' b, fi)) + | (Name id,Some exp), None when enriching -> + Some (id, exp, (set_maximality imps' flags.maximal, true)) + | (Name _,_), None -> None + | (Anonymous,_), Some (Some id, (b, fi, true)) -> + Some (id,Manual,(b,fi)) + | (Anonymous,_), Some (None, (b, fi, true)) -> + let id = Id.of_string ("arg_" ^ string_of_int k) in + Some (id,Manual,(b,fi)) + | (Anonymous,_), Some (_, (_, _, false)) -> None + | (Anonymous,_), None -> None + end :: imps' + | [], [] -> [] + (* flatten_explicitations returns a list of the same length as autoimps *) + | _ -> assert false + in merge 1 autoimps (flatten_explicitations l autoimps) + +let compute_semi_auto_implicits env sigma f t = + if not f.auto then [DefaultImpArgs, []] + else let l = compute_implicits_flags env sigma f false t in + [DefaultImpArgs, prepare_implicits f l] + +(*s Constants. *) + +let compute_constant_implicits flags cst = + let env = Global.env () in + let sigma = Evd.from_env env in + let cb = Environ.lookup_constant cst env in + let ty = of_constr cb.const_type in + let impls = compute_semi_auto_implicits env sigma flags ty in + impls + +(*s Inductives and constructors. Their implicit arguments are stored + in an array, indexed by the inductive number, of pairs $(i,v)$ where + $i$ are the implicit arguments of the inductive and $v$ the array of + implicit arguments of the constructors. *) + +let compute_mib_implicits flags kn = + let env = Global.env () in + let sigma = Evd.from_env env in + let mib = Environ.lookup_mind kn env in + let ar = + Array.to_list + (Array.mapi (* No need to lift, arities contain no de Bruijn *) + (fun i mip -> + (* No need to care about constraints here *) + let ty, _ = Typeops.type_of_global_in_context env (IndRef (kn,i)) in + let r = Inductive.relevance_of_inductive env (kn,i) in + Context.Rel.Declaration.LocalAssum (Context.make_annot (Name mip.mind_typename) r, ty)) + mib.mind_packets) in + let env_ar = Environ.push_rel_context ar env in + let imps_one_inductive i mip = + let ind = (kn,i) in + let ar, _ = Typeops.type_of_global_in_context env (IndRef ind) in + ((IndRef ind,compute_semi_auto_implicits env sigma flags (of_constr ar)), + Array.mapi (fun j (ctx, cty) -> + let c = of_constr (Term.it_mkProd_or_LetIn cty ctx) in + (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar sigma flags c)) + mip.mind_nf_lc) + in + Array.mapi imps_one_inductive mib.mind_packets + +let compute_all_mib_implicits flags kn = + let imps = compute_mib_implicits flags kn in + List.flatten + (Array.map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps) + +(*s Variables. *) + +let compute_var_implicits flags id = + let env = Global.env () in + let sigma = Evd.from_env env in + compute_semi_auto_implicits env sigma flags (NamedDecl.get_type (lookup_named id env)) + +(* Implicits of a global reference. *) + +let compute_global_implicits flags = function + | VarRef id -> compute_var_implicits flags id + | ConstRef kn -> compute_constant_implicits flags kn + | IndRef (kn,i) -> + let ((_,imps),_) = (compute_mib_implicits flags kn).(i) in imps + | ConstructRef ((kn,i),j) -> + let (_,cimps) = (compute_mib_implicits flags kn).(i) in snd cimps.(j-1) + +(* Merge a manual explicitation with an implicit_status list *) + +let merge_impls (cond,oldimpls) (_,newimpls) = + let oldimpls,usersuffiximpls = List.chop (List.length newimpls) oldimpls in + cond, (List.map2 (fun orig ni -> + match orig with + | Some (_, Manual, _) -> orig + | _ -> ni) oldimpls newimpls)@usersuffiximpls + +(* Caching implicits *) + +type implicit_interactive_request = + | ImplAuto + | ImplManual of int + +type implicit_discharge_request = + | ImplLocal + | ImplConstant of Constant.t * implicits_flags + | ImplMutualInductive of MutInd.t * implicits_flags + | ImplInteractive of GlobRef.t * implicits_flags * + implicit_interactive_request + +let implicits_table = Summary.ref GlobRef.Map.empty ~name:"implicits" + +let implicits_of_global ref = + try + let l = GlobRef.Map.find ref !implicits_table in + try + let rename_l = Arguments_renaming.arguments_names ref in + let rec rename implicits names = match implicits, names with + | [], _ -> [] + | _, [] -> implicits + | Some (_, x,y) :: implicits, Name id :: names -> + Some (id, x,y) :: rename implicits names + | imp :: implicits, _ :: names -> imp :: rename implicits names + in + List.map (fun (t, il) -> t, rename il rename_l) l + with Not_found -> l + with Not_found -> [DefaultImpArgs,[]] + +let cache_implicits_decl (ref,imps) = + implicits_table := GlobRef.Map.add ref imps !implicits_table + +let load_implicits _ (_,(_,l)) = List.iter cache_implicits_decl l + +let cache_implicits o = + load_implicits 1 o + +let subst_implicits_decl subst (r,imps as o) = + let r' = fst (subst_global subst r) in if r==r' then o else (r',imps) + +let subst_implicits (subst,(req,l)) = + (ImplLocal,List.Smart.map (subst_implicits_decl subst) l) + +let impls_of_context ctx = + let map (decl, impl) = match impl with + | Implicit -> Some (NamedDecl.get_id decl, Manual, (true, true)) + | _ -> None + in + List.rev_map map (List.filter (fst %> NamedDecl.is_local_assum) ctx) + +let adjust_side_condition p = function + | LessArgsThan n -> LessArgsThan (n+p) + | DefaultImpArgs -> DefaultImpArgs + +let add_section_impls vars extra_impls (cond,impls) = + let p = List.length vars - List.length extra_impls in + adjust_side_condition p cond, extra_impls @ impls + +let discharge_implicits (_,(req,l)) = + match req with + | ImplLocal -> None + | ImplInteractive (ref,flags,exp) -> + (try + let vars = variable_section_segment_of_reference ref in + let extra_impls = impls_of_context vars in + let l' = [ref, List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in + Some (ImplInteractive (ref,flags,exp),l') + with Not_found -> (* ref not defined in this section *) Some (req,l)) + | ImplConstant (con,flags) -> + (try + let vars = variable_section_segment_of_reference (ConstRef con) in + let extra_impls = impls_of_context vars in + let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in + let l' = [ConstRef con,newimpls] in + Some (ImplConstant (con,flags),l') + with Not_found -> (* con not defined in this section *) Some (req,l)) + | ImplMutualInductive (kn,flags) -> + (try + let l' = List.map (fun (gr, l) -> + let vars = variable_section_segment_of_reference gr in + let extra_impls = impls_of_context vars in + (gr, + List.map (add_section_impls vars extra_impls) l)) l + in + Some (ImplMutualInductive (kn,flags),l') + with Not_found -> (* ref not defined in this section *) Some (req,l)) + +let rebuild_implicits (req,l) = + match req with + | ImplLocal -> assert false + | ImplConstant (con,flags) -> + let oldimpls = snd (List.hd l) in + let newimpls = compute_constant_implicits flags con in + req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] + | ImplMutualInductive (kn,flags) -> + let newimpls = compute_all_mib_implicits flags kn in + let rec aux olds news = + match olds, news with + | (_, oldimpls) :: old, (gr, newimpls) :: tl -> + (gr, List.map2 merge_impls oldimpls newimpls) :: aux old tl + | [], [] -> [] + | _, _ -> assert false + in req, aux l newimpls + + | ImplInteractive (ref,flags,o) -> + (if isVarRef ref && is_in_section ref then ImplLocal else req), + match o with + | ImplAuto -> + let oldimpls = snd (List.hd l) in + let newimpls = compute_global_implicits flags ref in + [ref,List.map2 merge_impls oldimpls newimpls] + | ImplManual userimplsize -> + let oldimpls = snd (List.hd l) in + if flags.auto then + let newimpls = List.hd (compute_global_implicits flags ref) in + let p = List.length (snd newimpls) - userimplsize in + let newimpls = on_snd (List.firstn p) newimpls in + [ref,List.map (fun o -> merge_impls o newimpls) oldimpls] + else + [ref,oldimpls] + +let classify_implicits (req,_ as obj) = match req with +| ImplLocal -> Dispose +| _ -> Substitute obj + +type implicits_obj = + implicit_discharge_request * + (GlobRef.t * implicits_list list) list + +let inImplicits : implicits_obj -> obj = + declare_object {(default_object "IMPLICITS") with + cache_function = cache_implicits; + load_function = load_implicits; + subst_function = subst_implicits; + classify_function = classify_implicits; + discharge_function = discharge_implicits; + rebuild_function = rebuild_implicits } + +let is_local local ref = local || isVarRef ref && is_in_section ref + +let declare_implicits_gen req flags ref = + let imps = compute_global_implicits flags ref in + add_anonymous_leaf (inImplicits (req,[ref,imps])) + +let declare_implicits local ref = + let flags = { !implicit_args with auto = true } in + let req = + if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in + declare_implicits_gen req flags ref + +let declare_var_implicits id = + let flags = !implicit_args in + declare_implicits_gen ImplLocal flags (VarRef id) + +let declare_constant_implicits con = + let flags = !implicit_args in + declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) + +let declare_mib_implicits kn = + let flags = !implicit_args in + let imps = Array.map_to_list + (fun (ind,cstrs) -> ind::(Array.to_list cstrs)) + (compute_mib_implicits flags kn) in + add_anonymous_leaf + (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps)) + +(* Declare manual implicits *) +type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool) + +type manual_implicits = manual_explicitation list + +let compute_implicits_with_manual env sigma typ enriching l = + let autoimpls = compute_auto_implicits env sigma !implicit_args enriching typ in + set_manual_implicits !implicit_args enriching autoimpls l + +let check_inclusion l = + (* Check strict inclusion *) + let rec aux = function + | n1::(n2::_ as nl) -> + if n1 <= n2 then + user_err Pp.(str "Sequences of implicit arguments must be of different lengths."); + aux nl + | _ -> () in + aux (List.map snd l) + +let check_rigidity isrigid = + if not isrigid then + user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") + +let projection_implicits env p impls = + let npars = Projection.npars p in + CList.skipn_at_least npars impls + +let declare_manual_implicits local ref ?enriching l = + assert (List.for_all (fun (_, (max, fi, fu)) -> fi && fu) l); + assert (List.for_all (fun (ex, _) -> match ex with ExplByPos (_,_) -> true | _ -> false) l); + let flags = !implicit_args in + let env = Global.env () in + let sigma = Evd.from_env env in + let t, _ = Typeops.type_of_global_in_context env ref in + let t = of_constr t in + let enriching = Option.default flags.auto enriching in + let autoimpls = compute_auto_implicits env sigma flags enriching t in + let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in + let req = + if is_local local ref then ImplLocal + else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + in add_anonymous_leaf (inImplicits (req,[ref,l])) + +let maybe_declare_manual_implicits local ref ?enriching l = + match l with + | [] -> () + | _ -> declare_manual_implicits local ref ?enriching l + +(* TODO: either turn these warnings on and document them, or handle these cases sensibly *) + +let warn_set_maximal_deprecated = + CWarnings.create ~name:"set-maximal-deprecated" ~category:"deprecated" + (fun i -> strbrk ("Argument number " ^ string_of_int i ^ " is a trailing implicit so must be maximal")) + +type implicit_kind = Implicit | MaximallyImplicit | NotImplicit + +let compute_implicit_statuses autoimps l = + let rec aux i = function + | _ :: autoimps, NotImplicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) + | Name id :: autoimps, MaximallyImplicit :: manualimps -> + Some (id, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) + | Name id :: autoimps, Implicit :: manualimps -> + let imps' = aux (i+1) (autoimps, manualimps) in + let max = set_maximality imps' false in + if max then warn_set_maximal_deprecated i; + Some (id, Manual, (max, true)) :: imps' + | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> + user_err ~hdr:"set_implicits" + (strbrk ("Argument number " ^ string_of_int i ^ " (anonymous in original definition) cannot be declared implicit.")) + | autoimps, [] -> List.map (fun _ -> None) autoimps + | [], _::_ -> assert false + in aux 0 (autoimps, l) + +let set_implicits local ref l = + let flags = !implicit_args in + let env = Global.env () in + let sigma = Evd.from_env env in + let t, _ = Typeops.type_of_global_in_context env ref in + let t = of_constr t in + let autoimpls = compute_implicits_names env sigma t in + let l' = match l with + | [] -> assert false + | [l] -> + [DefaultImpArgs, compute_implicit_statuses autoimpls l] + | _ -> + check_rigidity (is_rigid env sigma t); + (* Sort by number of implicits, decreasing *) + let is_implicit = function + | NotImplicit -> false + | _ -> true in + let l = List.map (fun imps -> (imps,List.count is_implicit imps)) l in + let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in + check_inclusion l; + let nargs = List.length autoimpls in + List.map (fun (imps,n) -> + (LessArgsThan (nargs-n), + compute_implicit_statuses autoimpls imps)) l in + let req = + if is_local local ref then ImplLocal + else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + in add_anonymous_leaf (inImplicits (req,[ref,l'])) + +let extract_impargs_data impls = + let rec aux p = function + | (DefaultImpArgs, imps)::_ -> [None,imps] + | (LessArgsThan n, imps)::l -> (Some (p,n),imps) :: aux (n+1) l + | [] -> [] in + aux 0 impls + +let lift_implicits n = + List.map (fun x -> + match fst x with + ExplByPos (k, id) -> ExplByPos (k + n, id), snd x + | _ -> x) + +let make_implicits_list l = [DefaultImpArgs, l] + +let rec drop_first_implicits p l = + if Int.equal p 0 then l else match l with + | _,[] as x -> x + | DefaultImpArgs,imp::impls -> + drop_first_implicits (p-1) (DefaultImpArgs,impls) + | LessArgsThan n,imp::impls -> + let n = if is_status_implicit imp then n-1 else n in + drop_first_implicits (p-1) (LessArgsThan n,impls) + +let rec select_impargs_size n = function + | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *) + | [_, impls] | (DefaultImpArgs, impls)::_ -> impls + | (LessArgsThan p, impls)::l -> + if n <= p then impls else select_impargs_size n l + +let select_stronger_impargs = function + | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *) + | (_,impls)::_ -> impls diff --git a/interp/impargs.mli b/interp/impargs.mli new file mode 100644 index 0000000000..0070423530 --- /dev/null +++ b/interp/impargs.mli @@ -0,0 +1,149 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Environ + +(** {6 Implicit Arguments } *) +(** Here we store the implicit arguments. Notice that we + are outside the kernel, which knows nothing about implicit arguments. *) + +val make_implicit_args : bool -> unit +val make_strict_implicit_args : bool -> unit +val make_strongly_strict_implicit_args : bool -> unit +val make_reversible_pattern_implicit_args : bool -> unit +val make_contextual_implicit_args : bool -> unit +val make_maximal_implicit_args : bool -> unit + +val is_implicit_args : unit -> bool +val is_strict_implicit_args : unit -> bool +val is_strongly_strict_implicit_args : unit -> bool +val is_reversible_pattern_implicit_args : unit -> bool +val is_contextual_implicit_args : unit -> bool +val is_maximal_implicit_args : unit -> bool + +val with_implicit_protection : ('a -> 'b) -> 'a -> 'b + +(** {6 ... } *) +(** An [implicits_list] is a list of positions telling which arguments + of a reference can be automatically infered *) + + +type argument_position = + | Conclusion + | Hyp of int + +(** We remember various information about why an argument is + inferable as implicit *) +type implicit_explanation = + | DepRigid of argument_position + (** means that the implicit argument can be found by + unification along a rigid path (we do not print the arguments of + this kind if there is enough arguments to infer them) *) + | DepFlex of argument_position + (** means that the implicit argument can be found by unification + along a collapsable path only (e.g. as x in (P x) where P is another + argument) (we do (defensively) print the arguments of this kind) *) + | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position + (** means that the least argument from which the + implicit argument can be inferred is following a collapsable path + but there is a greater argument from where the implicit argument is + inferable following a rigid path (useful to know how to print a + partial application) *) + | Manual + (** means the argument has been explicitly set as implicit. *) + +(** We also consider arguments inferable from the conclusion but it is + operational only if [conclusion_matters] is true. *) + +type maximal_insertion = bool (** true = maximal contextual insertion *) + +type force_inference = bool (** true = always infer, never turn into evar/subgoal *) + +type implicit_status = (Id.t * implicit_explanation * + (maximal_insertion * force_inference)) option + (** [None] = Not implicit *) + +type implicit_side_condition + +type implicits_list = implicit_side_condition * implicit_status list + +val is_status_implicit : implicit_status -> bool +val is_inferable_implicit : bool -> int -> implicit_status -> bool +val name_of_implicit : implicit_status -> Id.t +val maximal_insertion_of : implicit_status -> bool +val force_inference_of : implicit_status -> bool + +val positions_of_implicits : implicits_list -> int list + +(** A [manual_explicitation] is a tuple of a positional or named explicitation with + maximal insertion, force inference and force usage flags. Forcing usage makes + the argument implicit even if the automatic inference considers it not inferable. *) +type manual_explicitation = Constrexpr.explicitation * + (maximal_insertion * force_inference * bool) + +type manual_implicits = manual_explicitation list + +val compute_implicits_with_manual : env -> Evd.evar_map -> types -> bool -> + manual_implicits -> implicit_status list + +val compute_implicits_names : env -> Evd.evar_map -> types -> Name.t list + +(** {6 Computation of implicits (done using the global environment). } *) + +val declare_var_implicits : variable -> unit +val declare_constant_implicits : Constant.t -> unit +val declare_mib_implicits : MutInd.t -> unit + +val declare_implicits : bool -> GlobRef.t -> unit + +(** [declare_manual_implicits local ref enriching l] + Manual declaration of which arguments are expected implicit. + If not set, we decide if it should enrich by automatically inferd + implicits depending on the current state. + Unsets implicits if [l] is empty. *) + +val declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> + manual_implicits -> unit + +(** If the list is empty, do nothing, otherwise declare the implicits. *) + +val maybe_declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> + manual_implicits -> unit + +type implicit_kind = Implicit | MaximallyImplicit | NotImplicit + +(** [set_implicits local ref l] + Manual declaration of implicit arguments. + `l` is a list of possible sequences of implicit statuses. *) +val set_implicits : bool -> GlobRef.t -> implicit_kind list list -> unit + +val implicits_of_global : GlobRef.t -> implicits_list list + +val extract_impargs_data : + implicits_list list -> ((int * int) option * implicit_status list) list + +val lift_implicits : int -> manual_implicits -> manual_implicits + +val make_implicits_list : implicit_status list -> implicits_list list + +val drop_first_implicits : int -> implicits_list -> implicits_list + +val projection_implicits : env -> Projection.t -> implicit_status list -> + implicit_status list + +val select_impargs_size : int -> implicits_list list -> implicit_status list + +val select_stronger_impargs : implicits_list list -> implicit_status list + +val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool + [@@ocaml.deprecated "Use Constrexpr_ops.explicitation_eq instead (since 8.10)"] +(** Equality on [explicitation]. *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml new file mode 100644 index 0000000000..dffccf02fc --- /dev/null +++ b/interp/implicit_quantifiers.ml @@ -0,0 +1,289 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Names +open Context +open Decl_kinds +open CErrors +open Util +open Glob_term +open Constrexpr +open Libnames +open Typeclasses +open Pp +open Libobject +open Nameops +open Context.Rel.Declaration + +exception MismatchedContextInstance of Environ.env * Typeclasses_errors.contexts * constr_expr list * Constr.rel_context (* found, expected *) +let mismatched_ctx_inst_err env c n m = raise (MismatchedContextInstance (env, c, n, m)) + +module RelDecl = Context.Rel.Declaration +(*i*) + +let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" + +let declare_generalizable_ident table {CAst.loc;v=id} = + if not (Id.equal id (root_of_id id)) then + user_err ?loc ~hdr:"declare_generalizable_ident" + ((Id.print id ++ str + " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); + if Id.Pred.mem id table then + user_err ?loc ~hdr:"declare_generalizable_ident" + ((Id.print id++str" is already declared as a generalizable identifier")) + else Id.Pred.add id table + +let add_generalizable gen table = + match gen with + | None -> Id.Pred.empty + | Some [] -> Id.Pred.full + | Some l -> List.fold_left (fun table lid -> declare_generalizable_ident table lid) + table l + +let cache_generalizable_type (_,(local,cmd)) = + generalizable_table := add_generalizable cmd !generalizable_table + +let load_generalizable_type _ (_,(local,cmd)) = + generalizable_table := add_generalizable cmd !generalizable_table + +let in_generalizable : bool * lident list option -> obj = + declare_object {(default_object "GENERALIZED-IDENT") with + load_function = load_generalizable_type; + cache_function = cache_generalizable_type; + classify_function = (fun (local, _ as obj) -> if local then Dispose else Keep obj) + } + +let declare_generalizable ~local gen = + Lib.add_anonymous_leaf (in_generalizable (local, gen)) + +let find_generalizable_ident id = Id.Pred.mem (root_of_id id) !generalizable_table + +let ids_of_list l = + List.fold_right Id.Set.add l Id.Set.empty + +let is_global id = + 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 = + not (Id.Set.mem x ids || is_named x env || is_global x) + + +(* Auxiliary functions for the inference of implicitly quantified variables. *) + +let ungeneralizable loc id = + user_err ?loc ~hdr:"Generalization" + (str "Unbound and ungeneralizable variable " ++ Id.print id) + +let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = + let found loc id bdvars 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 + else ungeneralizable loc id + else l + in + let rec aux bdvars l c = match CAst.(c.v) with + | CRef (qid,_) when qualid_is_ident qid -> + found c.CAst.loc (qualid_basename qid) bdvars l + | CNotation ((InConstrEntrySomeLevel,"{ _ : _ | _ }"), ({ CAst.v = CRef (qid,_) } :: _, [], [], [])) when + qualid_is_ident qid && not (Id.Set.mem (qualid_basename qid) bdvars) -> + Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add (qualid_basename qid) bdvars) l c + | _ -> Constrexpr_ops.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 x.CAst.v with Name na -> na :: acc | Anonymous -> acc) [] l + +let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder_expr list) = + let rec aux bdvars l c = match c with + ((CLocalAssum (n, _, c)) :: tl) -> + let bound = ids_of_names n in + let l' = free_vars_of_constr_expr c ~bound:bdvars l in + aux (Id.Set.union (ids_of_list bound) bdvars) l' tl + + | ((CLocalDef (n, c, t)) :: tl) -> + let bound = match n.CAst.v with Anonymous -> [] | Name n -> [n] in + let l' = free_vars_of_constr_expr c ~bound:bdvars l in + let l'' = Option.fold_left (fun l t -> free_vars_of_constr_expr t ~bound:bdvars l) l' t in + aux (Id.Set.union (ids_of_list bound) bdvars) l'' tl + + | CLocalPattern _ :: tl -> assert false + | [] -> bdvars, l + in aux bound l binders + +let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) = + let rec vars bound vs c = match DAst.get c with + | GVar id -> + let loc = c.CAst.loc in + if is_freevar bound (Global.env ()) id then + if List.exists (fun {CAst.v} -> Id.equal v id) vs then vs + else CAst.(make ?loc id) :: vs + else vs + | _ -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c + in fun rt -> + let vars = List.rev (vars bound [] rt) in + List.iter (fun {CAst.loc;v=id} -> + if not (Id.Set.mem id allowed || find_generalizable_ident id) then + ungeneralizable loc id) vars; + vars + +let rec make_fresh ids env x = + if is_freevar ids env x then x else make_fresh ids env (Nameops.increment_subscript x) + +let next_name_away_from na avoid = + match na with + | 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 = + let named, applied = + List.partition + (function + (t, Some {CAst.loc;v=ExplByName id}) -> + let is_id (_, decl) = match RelDecl.get_name decl with + | Name id' -> Id.equal id id' + | Anonymous -> false + in + if not (List.exists is_id needed) then + user_err ?loc (str "Wrong argument name: " ++ Id.print id); + true + | _ -> false) applied + in + let named = List.map + (fun x -> match x with (t, Some {CAst.loc;v=ExplByName id}) -> id, t | _ -> assert false) + named + in + let is_unset (_, decl) = match decl with + | LocalAssum _ -> true + | LocalDef _ -> 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, (_, (LocalAssum ({binder_name=Name id}, _) | LocalDef ({binder_name=Name id}, _, _))) :: need when Id.List.mem_assoc id named -> + aux (Id.List.assoc id named :: ids) avoid app need + + | (x, None) :: app, (None, (LocalAssum ({binder_name=Name id}, _) | LocalDef ({binder_name=Name id}, _, _))) :: need -> + aux (x :: ids) avoid app need + + | _, (Some cl, _ as d) :: need -> + let t', avoid' = fn avoid d in + aux (t' :: ids) avoid' app need + + | x :: app, (None, _) :: need -> aux (fst x :: ids) avoid app need + + | [], (None, _ as decl) :: need -> + let t', avoid' = fn avoid decl in + aux (t' :: ids) avoid' app need + + | (x,_) :: _, [] -> + 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 (_, decl) -> + let id' = next_name_away_from (RelDecl.get_name decl) avoid in + (CAst.make @@ CRef (qualid_of_ident id',None), Id.Set.add id' avoid) + +let destClassApp cl = + let open CAst in + let loc = cl.loc in + match cl.v with + | CApp ((None, { v = CRef (ref, inst) }), l) -> CAst.make ?loc (ref, List.map fst l, inst) + | CAppExpl ((None, ref, inst), l) -> CAst.make ?loc (ref, l, inst) + | CRef (ref, inst) -> CAst.make ?loc:cl.loc (ref, [], inst) + | _ -> raise Not_found + +let destClassAppExpl cl = + let open CAst in + let loc = cl.loc in + match cl.v with + | CApp ((None, { v = CRef (ref, inst) } ), l) -> CAst.make ?loc (ref, l, inst) + | CRef (ref, inst) -> CAst.make ?loc:cl.loc (ref, [], inst) + | _ -> raise Not_found + +let implicit_application env ?(allow_partial=true) f ty = + let is_class = + try + let ({CAst.v=(qid, _, _)} as clapp) = destClassAppExpl ty in + let gr = Nametab.locate qid in + if Typeclasses.is_class gr then Some (clapp, gr) else None + with Not_found -> None + in + match is_class with + | None -> ty, env + | Some ({CAst.loc;v=(id, par, inst)}, gr) -> + let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in + let c, avoid = + let env = Global.env () in + let sigma = Evd.from_env env in + let c = class_info env sigma gr in + let (ci, rd) = c.cl_context in + if not allow_partial then + begin + 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 + mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.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 + CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid + in c, avoid + +let warn_ignoring_implicit_status = + CWarnings.create ~name:"ignoring_implicit_status" ~category:"implicits" + (fun na -> + strbrk "Ignoring implicit status of product binder " ++ + Name.print na ++ strbrk " and following binders") + +let implicits_of_glob_constr ?(with_products=true) l = + 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) + in + match DAst.get c with + | GProd (na, bk, t, b) -> + if with_products then abs na bk b + else + let () = match bk with + | Implicit -> warn_ignoring_implicit_status na ?loc:c.CAst.loc + | _ -> () + in [] + | GLambda (na, bk, t, b) -> abs na bk b + | GLetIn (na, b, t, c) -> 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) + | _ -> [] + in aux 1 l diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli new file mode 100644 index 0000000000..437fef1753 --- /dev/null +++ b/interp/implicit_quantifiers.mli @@ -0,0 +1,51 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Glob_term +open Constrexpr +open Libnames + +val declare_generalizable : local:bool -> lident list option -> unit + +val ids_of_list : Id.t list -> Id.Set.t +val destClassApp : constr_expr -> (qualid * constr_expr list * instance_expr option) CAst.t +val destClassAppExpl : constr_expr -> (qualid * (constr_expr * explicitation CAst.t option) list * instance_expr option) CAst.t + +(** Fragile, should be used only for construction a set of identifiers to avoid *) + +val free_vars_of_constr_expr : constr_expr -> ?bound:Id.Set.t -> + Id.t list -> Id.t list + +val free_vars_of_binders : + ?bound:Id.Set.t -> Id.t list -> local_binder_expr list -> Id.Set.t * Id.t list + +(** Returns the generalizable free ids in left-to-right + order with the location of their first occurrence *) + +val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> + glob_constr -> lident list + +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 : + Id.Set.t -> GlobRef.t option * Constr.rel_declaration -> + Constrexpr.constr_expr * Id.Set.t + +val implicit_application : Id.Set.t -> ?allow_partial:bool -> + (Id.Set.t -> GlobRef.t option * Constr.rel_declaration -> + Constrexpr.constr_expr * Id.Set.t) -> + constr_expr -> constr_expr * Id.Set.t + +(* Should be likely located elsewhere *) +exception MismatchedContextInstance of Environ.env * Typeclasses_errors.contexts * constr_expr list * Constr.rel_context (* found, expected *) +val mismatched_ctx_inst_err : Environ.env -> Typeclasses_errors.contexts -> constr_expr list -> Constr.rel_context -> 'a diff --git a/interp/interp.mllib b/interp/interp.mllib new file mode 100644 index 0000000000..1262dbb181 --- /dev/null +++ b/interp/interp.mllib @@ -0,0 +1,20 @@ +NumTok +Constrexpr +Tactypes +Stdarg +Notation_term +Genintern +Notation_ops +Notation +Syntax_def +Smartlocate +Constrexpr_ops +Dumpglob +Reserve +Impargs +Implicit_quantifiers +Constrintern +Modintern +Constrextern +Discharge +Declare diff --git a/interp/modintern.ml b/interp/modintern.ml new file mode 100644 index 0000000000..2f516f4f3c --- /dev/null +++ b/interp/modintern.ml @@ -0,0 +1,148 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Declarations +open Libnames +open Constrexpr +open Constrintern +open Declaremods + +type module_internalization_error = + | NotAModuleNorModtype of string + | IncorrectWithInModule + | IncorrectModuleApplication + +exception ModuleInternalizationError of module_internalization_error + +let error_not_a_module_loc kind loc qid = + let s = string_of_qualid qid in + let e = let open Declaremods in 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_application_to_not_path loc me = + Loc.raise ?loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) + +let error_incorrect_with_in_module loc = + Loc.raise ?loc (ModuleInternalizationError IncorrectWithInModule) + +let error_application_to_module_type loc = + Loc.raise ?loc (ModuleInternalizationError IncorrectModuleApplication) + +(** Searching for a module name in the Nametab. + + 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. *) + +let lookup_module_or_modtype kind qid = + let open Declaremods in + let loc = qid.CAst.loc in + try + if kind == ModType then raise Not_found; + let mp = Nametab.locate_module qid in + Dumpglob.dump_modref ?loc mp "modtype"; (mp,Module) + with Not_found -> + 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 lookup_polymorphism env base kind fqid = + let m = match kind with + | Module -> (Environ.lookup_module base env).mod_type + | ModType -> (Environ.lookup_modtype base env).mod_type + | ModAny -> assert false + in + let rec defunctor = function + | NoFunctor m -> m + | MoreFunctor (_,_,m) -> defunctor m + in + let rec aux m fqid = + let open Names in + match fqid with + | [] -> assert false + | [id] -> + let test (lab,obj) = + match Id.equal (Label.to_id lab) id, obj with + | false, _ | _, (SFBmodule _ | SFBmodtype _) -> None + | true, SFBmind mind -> Some (Declareops.inductive_is_polymorphic mind) + | true, SFBconst const -> Some (Declareops.constant_is_polymorphic const) + in + (try CList.find_map test m with Not_found -> false (* error later *)) + | id::rem -> + let next = function + | MoreFunctor _ -> false (* error later *) + | NoFunctor body -> aux body rem + in + let test (lab,obj) = + match Id.equal (Label.to_id lab) id, obj with + | false, _ | _, (SFBconst _ | SFBmind _) -> None + | true, SFBmodule body -> Some (next body.mod_type) + | true, SFBmodtype body -> (* XXX is this valid? If not error later *) + Some (next body.mod_type) + in + (try CList.find_map test m with Not_found -> false (* error later *)) + in + aux (defunctor m) fqid + +let transl_with_decl env base kind = function + | CWith_Module ({CAst.v=fqid},qid) -> + WithMod (fqid,lookup_module qid), Univ.ContextSet.empty + | CWith_Definition ({CAst.v=fqid},udecl,c) -> + let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let c, ectx = interp_constr env sigma c in + let poly = lookup_polymorphism env base kind fqid in + begin match UState.check_univ_decl ~poly ectx udecl with + | Entries.Polymorphic_entry (nas, ctx) -> + let inst, ctx = Univ.abstract_universes nas ctx in + let c = EConstr.Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in + let c = EConstr.to_constr sigma c in + WithDef (fqid,(c, Some ctx)), Univ.ContextSet.empty + | Entries.Monomorphic_entry ctx -> + let c = EConstr.to_constr sigma c in + WithDef (fqid,(c, None)), ctx + end + +let loc_of_module l = l.CAst.loc + +(* Invariant : the returned kind is never ModAny, and it is + equal to the input kind when this one isn't ModAny. *) + +let rec interp_module_ast env kind m cst = match m with + | {CAst.loc;v=CMident qid} -> + let (mp,kind) = lookup_module_or_modtype kind qid in + (MEident mp, mp, kind, cst) + | {CAst.loc;v=CMapply (me1,me2)} -> + let me1', base, kind1, cst = interp_module_ast env kind me1 cst in + let me2', _, kind2, cst = interp_module_ast env ModAny me2 cst 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), base, kind1, cst) + | {CAst.loc;v=CMwith (me,decl)} -> + let me,base,kind,cst = interp_module_ast env kind me cst in + if kind == Module then error_incorrect_with_in_module m.CAst.loc; + let decl, cst' = transl_with_decl env base kind decl in + let cst = Univ.ContextSet.union cst cst' in + (MEwith(me,decl), base, kind, cst) + +let interp_module_ast env kind m = + let me, _, kind, cst = interp_module_ast env kind m Univ.ContextSet.empty in + me, kind, cst diff --git a/interp/modintern.mli b/interp/modintern.mli new file mode 100644 index 0000000000..529c438c1a --- /dev/null +++ b/interp/modintern.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Environ +open Entries +open Constrexpr + +(** Module internalization errors *) + +type module_internalization_error = + | NotAModuleNorModtype of string + | IncorrectWithInModule + | IncorrectModuleApplication + +exception ModuleInternalizationError of module_internalization_error + +(** Module expressions and module types are interpreted relatively to + 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 -> Declaremods.module_kind -> module_ast -> module_struct_entry * Declaremods.module_kind * Univ.ContextSet.t diff --git a/interp/notation.ml b/interp/notation.ml new file mode 100644 index 0000000000..56504db04e --- /dev/null +++ b/interp/notation.ml @@ -0,0 +1,2067 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open CErrors +open Util +open Pp +open Names +open Constr +open Libnames +open Globnames +open Constrexpr +open Notation_term +open Glob_term +open Glob_ops +open Context.Named.Declaration +open Classops + +(*i*) + +(*s A scope is a set of notations; it includes + + - a set of ML interpreters/parsers for positive (e.g. 0, 1, 15, ...) and + negative numbers (e.g. -0, -2, -13, ...). These interpreters may + fail if a number has no interpretation in the scope (e.g. there is + no interpretation for negative numbers in [nat]); interpreters both for + terms and patterns can be set; these interpreters are in permanent table + [numeral_interpreter_tab] + - a set of ML printers for expressions denoting numbers parsable in + this scope + - a set of interpretations for infix (more generally distfix) notations + - an optional pair of delimiters which, when occurring in a syntactic + expression, set this scope to be the current scope +*) + +let notation_entry_eq s1 s2 = match (s1,s2) with +| InConstrEntry, InConstrEntry -> true +| InCustomEntry s1, InCustomEntry s2 -> String.equal s1 s2 +| (InConstrEntry | InCustomEntry _), _ -> false + +let notation_entry_level_eq s1 s2 = match (s1,s2) with +| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> true +| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> String.equal s1 s2 && n1 = n2 +| (InConstrEntrySomeLevel | InCustomEntryLevel _), _ -> false + +let notation_entry_level_compare s1 s2 = match (s1,s2) with +| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> 0 +| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> + pair_compare String.compare Int.compare (s1,n1) (s2,n2) +| InConstrEntrySomeLevel, _ -> -1 +| InCustomEntryLevel _, _ -> 1 + +let notation_eq (from1,ntn1) (from2,ntn2) = + notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2 + +let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s + +let notation_compare = + pair_compare notation_entry_level_compare String.compare + +module NotationOrd = + struct + type t = notation + let compare = notation_compare + end + +module NotationSet = Set.Make(NotationOrd) +module NotationMap = CMap.Make(NotationOrd) + +(**********************************************************************) +(* Scope of symbols *) + +type delimiters = string +type notation_location = (DirPath.t * DirPath.t) * string + +type notation_data = { + not_interp : interpretation; + not_location : notation_location; +} + +type scope = { + notations: notation_data NotationMap.t; + delimiters: delimiters option +} + +(* Scopes table: scope_name -> symbol_interpretation *) +let scope_map = ref String.Map.empty + +(* Delimiter table : delimiter -> scope_name *) +let delimiters_map = ref String.Map.empty + +let empty_scope = { + notations = NotationMap.empty; + delimiters = None +} + +let default_scope = "" (* empty name, not available from outside *) + +let init_scope_map () = + scope_map := String.Map.add default_scope empty_scope !scope_map + +(**********************************************************************) +(* Operations on scopes *) + +let warn_undeclared_scope = + CWarnings.create ~name:"undeclared-scope" ~category:"deprecated" + (fun (scope) -> + strbrk "Declaring a scope implicitly is deprecated; use in advance an explicit " + ++ str "\"Declare Scope " ++ str scope ++ str ".\".") + +let declare_scope scope = + try let _ = String.Map.find scope !scope_map in () + with Not_found -> + scope_map := String.Map.add scope empty_scope !scope_map + +let error_unknown_scope sc = + user_err ~hdr:"Notation" + (str "Scope " ++ str sc ++ str " is not declared.") + +let find_scope ?(tolerant=false) scope = + try String.Map.find scope !scope_map + with Not_found -> + if tolerant then + (* tolerant mode to be turn off after deprecation phase *) + begin + warn_undeclared_scope scope; + scope_map := String.Map.add scope empty_scope !scope_map; + empty_scope + end + else + error_unknown_scope scope + +let check_scope ?(tolerant=false) scope = + let _ = find_scope ~tolerant scope in () + +let ensure_scope scope = check_scope ~tolerant:true scope + +let find_scope scope = find_scope scope + +(* [sc] might be here a [scope_name] or a [delimiter] + (now allowed after Open Scope) *) + +let normalize_scope sc = + try let _ = String.Map.find sc !scope_map in sc + with Not_found -> + try + 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 + +(**********************************************************************) +(* The global stack of scopes *) + +type scope_elem = Scope of scope_name | SingleNotation of notation +type scopes = scope_elem list + +let scope_eq s1 s2 = match s1, s2 with +| Scope s1, Scope s2 -> String.equal s1 s2 +| SingleNotation s1, SingleNotation s2 -> notation_eq s1 s2 +| Scope _, SingleNotation _ +| SingleNotation _, Scope _ -> false + +(* Scopes for interpretation *) + +let scope_stack = ref [] + +let current_scopes () = !scope_stack + +let scope_is_open_in_scopes 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) + +(* Uninterpretation tables *) + +type interp_rule = + | NotationRule of scope_name option * notation + | SynDefRule of KerName.t + +type scoped_notation_rule_core = scope_name * notation * interpretation * int option +type notation_rule_core = interp_rule * interpretation * int option +type notation_rule = notation_rule_core * delimiters option * bool + +let interp_rule_compare r1 r2 = match r1, r2 with + | NotationRule (sc1,ntn1), NotationRule (sc2,ntn2) -> + pair_compare (Option.compare String.compare) notation_compare (sc1,ntn1) (sc2,ntn2) + | SynDefRule kn1, SynDefRule kn2 -> KerName.compare kn1 kn2 + | (NotationRule _ | SynDefRule _), _ -> -1 + +module InterpRuleSet = Set.Make(struct + type t = interp_rule + let compare = interp_rule_compare + end) + +(* Scopes for uninterpretation: includes abbreviations (i.e. syntactic definitions) and *) + +type uninterp_scope_elem = + | UninterpScope of scope_name + | UninterpSingle of notation_rule_core + +let uninterp_scope_eq_weak s1 s2 = match s1, s2 with +| UninterpScope s1, UninterpScope s2 -> String.equal s1 s2 +| UninterpSingle s1, UninterpSingle s2 -> false +| (UninterpSingle _ | UninterpScope _), _ -> false + +module ScopeOrd = + struct + type t = scope_name option + let compare = Pervasives.compare + end + +module ScopeMap = CMap.Make(ScopeOrd) + +let uninterp_scope_stack = ref [] + +let push_uninterp_scope sc scopes = UninterpScope sc :: scopes + +let push_uninterp_scopes = List.fold_right push_uninterp_scope + +(**********************************************************************) +(* Mapping classes to scopes *) + +type scope_class = cl_typ + +let scope_class_compare : scope_class -> scope_class -> int = + cl_typ_ord + +let compute_scope_class sigma t = + let (cl,_,_) = find_class_type sigma t in + cl + +module ScopeClassOrd = +struct + type t = scope_class + let compare = scope_class_compare +end + +module ScopeClassMap = Map.Make(ScopeClassOrd) + +let initial_scope_class_map : scope_name ScopeClassMap.t = + 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 + +let current_type_scope_name () = + find_scope_class_opt (Some CL_SORT) + +(* TODO: push nat_scope, z_scope, ... in scopes summary *) + +(* Exportation of scopes *) +let open_scope i (_,(local,op,sc)) = + if Int.equal i 1 then begin + scope_stack := + if op then Scope sc :: !scope_stack + else List.except scope_eq (Scope sc) !scope_stack; + uninterp_scope_stack := + if op then UninterpScope sc :: !uninterp_scope_stack + else List.except uninterp_scope_eq_weak (UninterpScope sc) !uninterp_scope_stack + end + +let cache_scope o = + open_scope 1 o + +let subst_scope (subst,sc) = sc + +open Libobject + +let discharge_scope (_,(local,_,_ as o)) = + if local then None else Some o + +let classify_scope (local,_,_ as o) = + if local then Dispose else Substitute o + +let inScope : bool * bool * scope_name -> obj = + declare_object {(default_object "SCOPE") with + cache_function = cache_scope; + open_function = open_scope; + subst_function = subst_scope; + discharge_function = discharge_scope; + classify_function = classify_scope } + +let open_close_scope (local,opening,sc) = + Lib.add_anonymous_leaf (inScope (local,opening,normalize_scope sc)) + +let empty_scope_stack = [] + +let push_scope sc scopes = Scope sc :: scopes + +let push_scopes = List.fold_right push_scope + +let make_type_scope_soft tmp_scope = + if Option.equal String.equal tmp_scope (current_type_scope_name ()) then + true, None + else + false, tmp_scope + +let make_current_scopes (tmp_scope,scopes) = + Option.fold_right push_scope tmp_scope (push_scopes scopes !scope_stack) + +let make_current_uninterp_scopes (tmp_scope,scopes) = + let istyp,tmp_scope = make_type_scope_soft tmp_scope in + istyp,Option.fold_right push_uninterp_scope tmp_scope + (push_uninterp_scopes scopes !uninterp_scope_stack) + +(**********************************************************************) +(* Delimiters *) + +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 := String.Map.add scope newsc !scope_map + | Some oldkey when String.equal oldkey key -> () + | Some oldkey -> + (* FIXME: implement multikey scopes? *) + Flags.if_verbose Feedback.msg_info + (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); + scope_map := String.Map.add scope newsc !scope_map + end; + try + let oldscope = String.Map.find key !delimiters_map in + if String.equal oldscope scope then () + else begin + Flags.if_verbose Feedback.msg_info (str "Hiding binding of key " ++ str key ++ str " to " ++ str oldscope); + delimiters_map := String.Map.add key scope !delimiters_map + end + with Not_found -> delimiters_map := String.Map.add key scope !delimiters_map + +let remove_delimiters scope = + let sc = find_scope scope in + let newsc = { sc with delimiters = None } in + match sc.delimiters with + | None -> CErrors.user_err (str "No bound key for scope " ++ str scope ++ str ".") + | Some key -> + scope_map := String.Map.add scope newsc !scope_map; + try + let _ = ignore (String.Map.find key !delimiters_map) in + delimiters_map := String.Map.remove key !delimiters_map + with Not_found -> + assert false (* A delimiter for scope [scope] should exist *) + +let find_delimiters_scope ?loc key = + try String.Map.find key !delimiters_map + with Not_found -> + user_err ?loc ~hdr:"find_delimiters" + (str "Unknown scope delimiting key " ++ str key ++ str ".") + +(* We define keys for glob_constr and aconstr to split the syntax entries + according to the key of the pattern (adapted from Chet Murthy by HH) *) + +type key = + | RefKey of GlobRef.t + | LambdaKey + | ProdKey + | Oth + +let key_compare k1 k2 = match k1, k2 with +| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 +| RefKey _, _ -> -1 +| _, RefKey _ -> 1 +| k1, k2 -> Pervasives.compare k1 k2 + +module KeyOrd = struct type t = key let compare = key_compare end +module KeyMap = Map.Make(KeyOrd) + +let keymap_add key sc interp (scope_map,global_map) = + (* Adding to scope keymap for printing based on open scopes *) + let oldkeymap = try ScopeMap.find sc scope_map with Not_found -> KeyMap.empty in + let oldscmap = try KeyMap.find key oldkeymap with Not_found -> [] in + let newscmap = KeyMap.add key (interp :: oldscmap) oldkeymap in + let scope_map = ScopeMap.add sc newscmap scope_map in + (* Adding to global keymap of scoped notations in case the scope is not open *) + let global_map = match interp with + | NotationRule (Some sc,ntn), interp, c -> + let oldglobalkeymap = try KeyMap.find key global_map with Not_found -> [] in + KeyMap.add key ((sc,ntn,interp,c) :: oldglobalkeymap) global_map + | (NotationRule (None,_) | SynDefRule _), _, _ -> global_map in + (scope_map, global_map) + +let keymap_extract istype keys sc map = + let keymap = + try ScopeMap.find (Some sc) map + with Not_found -> KeyMap.empty in + let delim = + if istype && Option.equal String.equal (Some sc) (current_type_scope_name ()) then + (* A type is re-interpreted with type_scope on top, so never need a delimiter *) + None + else + (* Pass the delimiter so that it can be used if ever the notation is masked *) + (String.Map.find sc !scope_map).delimiters in + let add_scope rule = (rule,delim,false) in + List.map_append (fun key -> try List.map add_scope (KeyMap.find key keymap) with Not_found -> []) keys + +let find_with_delimiters istype = function + | None -> + None + | Some _ as scope when istype && Option.equal String.equal scope (current_type_scope_name ()) -> + (* This is in case type_scope (which by default is open in the + initial state) has been explicitly closed *) + Some None + | Some scope -> + match (String.Map.find scope !scope_map).delimiters with + | Some key -> Some (Some key) + | None -> None + +let rec keymap_extract_remainder istype scope_seen = function + | [] -> [] + | (sc,ntn,interp,c) :: l -> + if String.Set.mem sc scope_seen then keymap_extract_remainder istype scope_seen l + else + match find_with_delimiters istype (Some sc) with + | None -> keymap_extract_remainder istype scope_seen l + | Some delim -> + let rule = (NotationRule (Some sc, ntn), interp, c) in + (rule,delim,true) :: keymap_extract_remainder istype scope_seen l + +(* Scopes table : interpretation -> scope_name *) +let notations_key_table = + ref ((ScopeMap.empty, KeyMap.empty) : + notation_rule_core list KeyMap.t ScopeMap.t * + scoped_notation_rule_core list KeyMap.t) + +let glob_prim_constr_key c = match DAst.get c with + | GRef (ref, _) -> Some (canonical_gr ref) + | GApp (c, _) -> + begin match DAst.get c with + | GRef (ref, _) -> Some (canonical_gr ref) + | _ -> None + end + | _ -> None + +let glob_constr_keys c = match DAst.get c with + | GRef (ref,_) -> [RefKey (canonical_gr ref)] + | GApp (c, _) -> + begin match DAst.get c with + | GRef (ref, _) -> [RefKey (canonical_gr ref); Oth] + | _ -> [Oth] + end + | GLambda _ -> [LambdaKey] + | GProd _ -> [ProdKey] + | _ -> [Oth] + +let cases_pattern_key c = match DAst.get c with + | PatCstr (ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) + | _ -> Oth + +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) + | NLambda _ | NBinderList (_,_,NLambda _,_,_) | NList (_,_,NLambda _,_,_) -> LambdaKey, None + | NProd _ | NBinderList (_,_,NProd _,_,_) | NList (_,_,NProd _,_,_) -> ProdKey, None + | _ -> Oth, None + +(**********************************************************************) +(* Interpreting numbers (not in summary because functional objects) *) + +type required_module = full_path * string list +type rawnum = Constrexpr.sign * Constrexpr.raw_numeral + +type prim_token_uid = string + +type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> glob_constr +type 'a prim_token_uninterpreter = any_glob_constr -> 'a option + +type 'a prim_token_interpretation = + 'a prim_token_interpreter * 'a prim_token_uninterpreter + +module InnerPrimToken = struct + + type interpreter = + | RawNumInterp of (?loc:Loc.t -> rawnum -> glob_constr) + | BigNumInterp of (?loc:Loc.t -> Bigint.bigint -> glob_constr) + | StringInterp of (?loc:Loc.t -> string -> glob_constr) + + let interp_eq f f' = match f,f' with + | RawNumInterp f, RawNumInterp f' -> f == f' + | BigNumInterp f, BigNumInterp f' -> f == f' + | StringInterp f, StringInterp f' -> f == f' + | _ -> false + + let ofNumeral s n = + let n = String.(concat "" (split_on_char '_' n)) in + match s with + | SPlus -> Bigint.of_string n + | SMinus -> Bigint.neg (Bigint.of_string n) + + let do_interp ?loc interp primtok = + match primtok, interp with + | Numeral (s,n), RawNumInterp interp -> interp ?loc (s,n) + | Numeral (s,{ NumTok.int = n; frac = ""; exp = "" }), + BigNumInterp interp -> interp ?loc (ofNumeral s n) + | String s, StringInterp interp -> interp ?loc s + | (Numeral _ | String _), + (RawNumInterp _ | BigNumInterp _ | StringInterp _) -> raise Not_found + + type uninterpreter = + | RawNumUninterp of (any_glob_constr -> rawnum option) + | BigNumUninterp of (any_glob_constr -> Bigint.bigint option) + | StringUninterp of (any_glob_constr -> string option) + + let uninterp_eq f f' = match f,f' with + | RawNumUninterp f, RawNumUninterp f' -> f == f' + | BigNumUninterp f, BigNumUninterp f' -> f == f' + | StringUninterp f, StringUninterp f' -> f == f' + | _ -> false + + let mkNumeral n = + if Bigint.is_pos_or_zero n then + Numeral (SPlus,NumTok.int (Bigint.to_string n)) + else + Numeral (SMinus,NumTok.int (Bigint.to_string (Bigint.neg n))) + + let mkString = function + | None -> None + | Some s -> if Unicode.is_utf8 s then Some (String s) else None + + let do_uninterp uninterp g = match uninterp with + | RawNumUninterp u -> Option.map (fun (s,n) -> Numeral (s,n)) (u g) + | BigNumUninterp u -> Option.map mkNumeral (u g) + | StringUninterp u -> mkString (u g) + +end + +(* The following two tables of (un)interpreters will *not* be + synchronized. But their indexes will be checked to be unique. + These tables contain primitive token interpreters which are + registered in plugins, such as string and ascii syntax. It is + essential that only plugins add to these tables, and that + vernacular commands do not. See + https://github.com/coq/coq/issues/8401 for details of what goes + wrong when vernacular commands add to these tables. *) +let prim_token_interpreters = + (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.interpreter) Hashtbl.t) + +let prim_token_uninterpreters = + (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.uninterpreter) Hashtbl.t) + +(*******************************************************) +(* Numeral notation interpretation *) +type prim_token_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_token_notation_error + +type numnot_option = + | Nop + | Warning of string + | Abstract of string + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type decimal_ty = + { int : int_ty; + decimal : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Decimal of decimal_ty (* Coq.Init.Decimal.decimal + uint + int *) + +type string_target_kind = + | ListByte + | Byte + +type option_kind = Option | Direct +type 'target conversion_kind = 'target * option_kind + +type ('target, 'warning) prim_token_notation_obj = + { to_kind : 'target conversion_kind; + to_ty : GlobRef.t; + of_kind : 'target conversion_kind; + of_ty : GlobRef.t; + ty_name : Libnames.qualid; (* for warnings / error messages *) + warning : 'warning } + +type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj + +module PrimTokenNotation = struct +(** * Code shared between Numeral notation and String notation *) +(** Reduction + + The constr [c] below isn't necessarily well-typed, since we + built it via an [mkApp] of a conversion function on a term + that starts with the right constructor but might be partially + applied. + + At least [c] is known to be evar-free, since it comes from + our own ad-hoc [constr_of_glob] or from conversions such + as [coqint_of_rawnum]. + + It is important to fully normalize the term, *including inductive + parameters of constructors*; see + https://github.com/coq/coq/issues/9840 for details on what goes + wrong if this does not happen, e.g., from using the vm rather than + cbv. +*) + +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let c' = Tacred.compute env sigma c in + EConstr.Unsafe.to_constr c' + +let eval_constr_app env sigma c1 c2 = + eval_constr env sigma (mkApp (c1,[| c2 |])) + +exception NotAValidPrimToken + +(** The uninterp function below work at the level of [glob_constr] + which is too low for us here. So here's a crude conversion back + to [constr] for the subset that concerns us. + + Note that if you update [constr_of_glob], you should update the + corresponding numeral notation *and* string notation doc in + doc/sphinx/user-extensions/syntax-extensions.rst that describes + what it means for a term to be ground / to be able to be + considered for parsing. *) + +let rec constr_of_glob env sigma g = match DAst.get g with + | Glob_term.GRef (ConstructRef c, _) -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | Glob_term.GRef (IndRef c, _) -> + let sigma,c = Evd.fresh_inductive_instance env sigma c in + sigma,mkIndU c + | Glob_term.GApp (gc, gcl) -> + let sigma,c = constr_of_glob env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | Glob_term.GInt i -> sigma, mkInt i + | _ -> + raise NotAValidPrimToken + +let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with + | App (c, ca) -> + let c = glob_of_constr token_kind ?loc env sigma c in + let cel = List.map (glob_of_constr token_kind ?loc env sigma) (Array.to_list ca) in + DAst.make ?loc (Glob_term.GApp (c, cel)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | Int i -> DAst.make ?loc (Glob_term.GInt i) + | _ -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedTerm c)) + +let no_such_prim_token uninterpreted_token_kind ?loc ty = + CErrors.user_err ?loc + (str ("Cannot interpret this "^uninterpreted_token_kind^" as a value of type ") ++ + pr_qualid ty) + +let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma c = + match Constr.kind c with + | App (_Some, [| _; c |]) -> glob_of_constr token_kind ?loc env sigma c + | App (_None, [| _ |]) -> no_such_prim_token uninterpreted_token_kind ?loc ty + | x -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedNonOptionTerm c)) + +let uninterp_option c = + match Constr.kind c with + | App (_Some, [| _; x |]) -> x + | _ -> raise NotAValidPrimToken + +let uninterp to_raw o (Glob_term.AnyGlobConstr n) = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in + let of_ty = EConstr.Unsafe.to_constr of_ty in + try + let sigma,n = constr_of_glob env sigma n in + let c = eval_constr_app env sigma of_ty n in + let c = if snd o.of_kind == Direct then c else uninterp_option c in + Some (to_raw (fst o.of_kind, c)) + with + | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) + | NotAValidPrimToken -> None (* all other functions except big2raw *) + +end + +(** Conversion from bigint to int63 *) +let rec int63_of_pos_bigint i = + let open Bigint in + if equal i zero then Uint63.of_int 0 + else + let (quo,rem) = div2_with_rest i in + if rem then Uint63.add (Uint63.of_int 1) + (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) + else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) + +module Numeral = struct +(** * Numeral notation *) +open PrimTokenNotation + +let warn_large_num = + CWarnings.create ~name:"large-number" ~category:"numbers" + (fun ty -> + strbrk "Stack overflow or segmentation fault happens when " ++ + strbrk "working with large numbers in " ++ pr_qualid ty ++ + strbrk " (threshold may vary depending" ++ + strbrk " on your system limits and on the command executed).") + +let warn_abstract_large_num = + CWarnings.create ~name:"abstract-large-number" ~category:"numbers" + (fun (ty,f) -> + strbrk "To avoid stack overflow, large numbers in " ++ + pr_qualid ty ++ strbrk " are interpreted as applications of " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") + +(** Comparing two raw numbers (base 10, big-endian, non-negative). + A bit nasty, but not critical: only used to decide when a + number is considered as large (see warnings above). *) + +exception Comp of int + +let rec rawnum_compare s s' = + let l = String.length s and l' = String.length s' in + if l < l' then - rawnum_compare s' s + else + let d = l-l' in + try + for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; + for i = d to l-1 do + let c = Pervasives.compare s.[i] s'.[i-d] in + if c != 0 then raise (Comp c) + done; + 0 + with Comp c -> c + +(***********************************************************************) + +(** ** Conversion between Coq [Decimal.int] and internal raw string *) + +(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) + +let digit_of_char c = + assert ('0' <= c && c <= '9'); + Char.code c - Char.code '0' + 2 + +let char_of_digit n = + assert (2<=n && n<=11); + Char.chr (n-2 + Char.code '0') + +let coquint_of_rawnum uint str = + let nil = mkConstruct (uint,1) in + let rec do_chars s i acc = + if i < 0 then acc + else if s.[i] == '_' then do_chars s (i-1) acc else + let dg = mkConstruct (uint, digit_of_char s.[i]) in + do_chars s (i-1) (mkApp(dg,[|acc|])) + in + do_chars str (String.length str - 1) nil + +let coqint_of_rawnum inds sign str = + let uint = coquint_of_rawnum inds.uint str in + let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in + mkApp (mkConstruct (inds.int, pos_neg), [|uint|]) + +let coqdecimal_of_rawnum inds sign n = + let i, f, e = NumTok.(n.int, n.frac, n.exp) in + let i = coqint_of_rawnum inds.int sign i in + let f = coquint_of_rawnum inds.int.uint f in + if e = "" then mkApp (mkConstruct (inds.decimal, 1), [|i; f|]) (* Decimal *) + else + let sign, e = match e.[1] with + | '-' -> SMinus, String.sub e 2 (String.length e - 2) + | '+' -> SPlus, String.sub e 2 (String.length e - 2) + | _ -> SPlus, String.sub e 1 (String.length e - 1) in + let e = coqint_of_rawnum inds.int sign e in + mkApp (mkConstruct (inds.decimal, 2), [|i; f; e|]) (* DecimalExp *) + +let rawnum_of_coquint c = + let rec of_uint_loop c buf = + match Constr.kind c with + | Construct ((_,1), _) (* Nil *) -> () + | App (c, [|a|]) -> + (match Constr.kind c with + | Construct ((_,n), _) (* D0 to D9 *) -> + let () = Buffer.add_char buf (char_of_digit n) in + of_uint_loop a buf + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken + in + let buf = Buffer.create 64 in + let () = of_uint_loop c buf in + if Int.equal (Buffer.length buf) 0 then + (* To avoid ambiguities between Nil and (D0 Nil), we choose + to not display Nil alone as "0" *) + raise NotAValidPrimToken + else NumTok.int (Buffer.contents buf) + +let rawnum_of_coqint c = + match Constr.kind c with + | App (c,[|c'|]) -> + (match Constr.kind c with + | Construct ((_,1), _) (* Pos *) -> (SPlus, rawnum_of_coquint c') + | Construct ((_,2), _) (* Neg *) -> (SMinus, rawnum_of_coquint c') + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken + +let rawnum_of_decimal c = + let of_ife i f e = + let sign, n = rawnum_of_coqint i in + let f = + try (rawnum_of_coquint f).NumTok.int with NotAValidPrimToken -> "" in + let e = match e with None -> "" | Some e -> match rawnum_of_coqint e with + | SPlus, e -> "e+" ^ e.NumTok.int + | SMinus, e -> "e-" ^ e.NumTok.int in + sign,{ n with NumTok.frac = f; exp = e } in + match Constr.kind c with + | App (_,[|i; f|]) -> of_ife i f None + | App (_,[|i; f; e|]) -> of_ife i f (Some e) + | _ -> raise NotAValidPrimToken + +(***********************************************************************) + +(** ** Conversion between Coq [Z] and internal bigint *) + +(** First, [positive] from/to bigint *) + +let rec pos_of_bigint posty n = + match Bigint.div2_with_rest n with + | (q, false) -> + let c = mkConstruct (posty, 2) in (* xO *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) when not (Bigint.equal q Bigint.zero) -> + let c = mkConstruct (posty, 1) in (* xI *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) -> + mkConstruct (posty, 3) (* xH *) + +let rec bigint_of_pos c = match Constr.kind c with + | Construct ((_, 3), _) -> (* xH *) Bigint.one + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) + | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) + | n -> assert false (* no other constructor of type positive *) + end + | x -> raise NotAValidPrimToken + end + | x -> raise NotAValidPrimToken + +(** Now, [Z] from/to bigint *) + +let z_of_bigint { z_ty; pos_ty } n = + if Bigint.equal n Bigint.zero then + mkConstruct (z_ty, 1) (* Z0 *) + else + let (s, n) = + if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) + else (3, Bigint.neg n) (* Zneg *) + in + let c = mkConstruct (z_ty, s) in + mkApp (c, [| pos_of_bigint pos_ty n |]) + +let bigint_of_z z = match Constr.kind z with + | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 2 -> (* Zpos *) bigint_of_pos d + | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) + | n -> assert false (* no other constructor of type Z *) + end + | _ -> raise NotAValidPrimToken + end + | _ -> raise NotAValidPrimToken + +(** Now, [Int63] from/to bigint *) + +let int63_of_pos_bigint ?loc n = + let i = int63_of_pos_bigint n in + mkInt i + +let error_negative ?loc = + CErrors.user_err ?loc ~hdr:"interp_int63" (Pp.str "int63 are only non-negative numbers.") + +let error_overflow ?loc n = + CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Bigint.to_string n)) + +let interp_int63 ?loc n = + let open Bigint in + if is_pos_or_zero n + then + if less_than n (pow two 63) + then int63_of_pos_bigint ?loc n + else error_overflow ?loc n + else error_negative ?loc + +let bigint_of_int63 c = + match Constr.kind c with + | Int i -> Bigint.of_string (Uint63.to_string i) + | _ -> raise NotAValidPrimToken + +let big2raw n = + if Bigint.is_pos_or_zero n then + (SPlus, NumTok.int (Bigint.to_string n)) + else + (SMinus, NumTok.int (Bigint.to_string (Bigint.neg n))) + +let raw2big s n = match s with + | SPlus -> Bigint.of_string n + | SMinus -> Bigint.neg (Bigint.of_string n) + +let interp o ?loc n = + begin match o.warning, n with + | Warning threshold, (SPlus, { NumTok.int = n; frac = ""; exp = "" }) + when rawnum_compare n threshold >= 0 -> + warn_large_num o.ty_name + | _ -> () + end; + let c = match fst o.to_kind, n with + | Int int_ty, (s, { NumTok.int = n; frac = ""; exp = "" }) -> + coqint_of_rawnum int_ty s n + | UInt uint_ty, (SPlus, { NumTok.int = n; frac = ""; exp = "" }) -> + coquint_of_rawnum uint_ty n + | Z z_pos_ty, (s, { NumTok.int = n; frac = ""; exp = "" }) -> + z_of_bigint z_pos_ty (raw2big s n) + | Int63, (s, { NumTok.int = n; frac = ""; exp = "" }) -> + interp_int63 ?loc (raw2big s n) + | (Int _ | UInt _ | Z _ | Int63), _ -> + no_such_prim_token "number" ?loc o.ty_name + | Decimal decimal_ty, (s,n) -> coqdecimal_of_rawnum decimal_ty s n + in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + match o.warning, snd o.to_kind with + | Abstract threshold, Direct + when rawnum_compare (snd n).NumTok.int threshold >= 0 -> + warn_abstract_large_num (o.ty_name,o.to_ty); + glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) + | _ -> + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr "numeral" ?loc env sigma res + | Option -> interp_option "number" "numeral" o.ty_name ?loc env sigma res + +let uninterp o n = + PrimTokenNotation.uninterp + begin function + | (Int _, c) -> rawnum_of_coqint c + | (UInt _, c) -> (SPlus, rawnum_of_coquint c) + | (Z _, c) -> big2raw (bigint_of_z c) + | (Int63, c) -> big2raw (bigint_of_int63 c) + | (Decimal _, c) -> rawnum_of_decimal c + end o n +end + +module Strings = struct +(** * String notation *) +open PrimTokenNotation + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_list () = qualid_of_ref "core.list.type" +let q_byte () = qualid_of_ref "core.byte.type" + +let unsafe_locate_ind q = + match Nametab.locate q with + | IndRef i -> i + | _ -> raise Not_found + +let locate_list () = unsafe_locate_ind (q_list ()) +let locate_byte () = unsafe_locate_ind (q_byte ()) + +(***********************************************************************) + +(** ** Conversion between Coq [list Byte.byte] and internal raw string *) + +let coqbyte_of_char_code byte c = + mkConstruct (byte, 1 + c) + +let coqbyte_of_string ?loc byte s = + let p = + if Int.equal (String.length s) 1 then int_of_char s.[0] + else + if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] + then int_of_string s + else + user_err ?loc ~hdr:"coqbyte_of_string" + (str "Expects a single character or a three-digits ascii code.") in + coqbyte_of_char_code byte p + +let coqbyte_of_char byte c = coqbyte_of_char_code byte (Char.code c) + +let make_ascii_string n = + if n>=32 && n<=126 then String.make 1 (char_of_int n) + else Printf.sprintf "%03d" n + +let char_code_of_coqbyte c = + match Constr.kind c with + | Construct ((_,c), _) -> c - 1 + | _ -> raise NotAValidPrimToken + +let string_of_coqbyte c = make_ascii_string (char_code_of_coqbyte c) + +let coqlist_byte_of_string byte_ty list_ty str = + let cbyte = mkInd byte_ty in + let nil = mkApp (mkConstruct (list_ty, 1), [|cbyte|]) in + let cons x xs = mkApp (mkConstruct (list_ty, 2), [|cbyte; x; xs|]) in + let rec do_chars s i acc = + if i < 0 then acc + else + let b = coqbyte_of_char byte_ty s.[i] in + do_chars s (i-1) (cons b acc) + in + do_chars str (String.length str - 1) nil + +(* N.B. We rely on the fact that [nil] is the first constructor and [cons] is the second constructor, for [list] *) +let string_of_coqlist_byte c = + let rec of_coqlist_byte_loop c buf = + match Constr.kind c with + | App (_nil, [|_ty|]) -> () + | App (_cons, [|_ty;b;c|]) -> + let () = Buffer.add_char buf (Char.chr (char_code_of_coqbyte b)) in + of_coqlist_byte_loop c buf + | _ -> raise NotAValidPrimToken + in + let buf = Buffer.create 64 in + let () = of_coqlist_byte_loop c buf in + Buffer.contents buf + +let interp o ?loc n = + let byte_ty = locate_byte () in + let list_ty = locate_list () in + let c = match fst o.to_kind with + | ListByte -> coqlist_byte_of_string byte_ty list_ty n + | Byte -> coqbyte_of_string ?loc byte_ty n + in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr "string" ?loc env sigma res + | Option -> interp_option "string" "string" o.ty_name ?loc env sigma res + +let uninterp o n = + PrimTokenNotation.uninterp + begin function + | (ListByte, c) -> string_of_coqlist_byte c + | (Byte, c) -> string_of_coqbyte c + end o n +end + +(* A [prim_token_infos], which is synchronized with the document + state, either contains a unique id pointing to an unsynchronized + prim token function, or a numeral notation object describing how to + interpret and uninterpret. We provide [prim_token_infos] because + we expect plugins to provide their own interpretation functions, + rather than going through numeral notations, which are available as + a vernacular. *) + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + | StringNotation of string_notation_obj + +type prim_token_infos = { + pt_local : bool; (** Is this interpretation local? *) + pt_scope : scope_name; (** Concerned scope *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_required : required_module; (** Module that should be loaded first *) + pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) + pt_in_match : bool (** Is this prim token legal in match patterns ? *) +} + +(* Table from scope_name to backtrack-able informations about interpreters + (in particular interpreter unique id). *) +let prim_token_interp_infos = + ref (String.Map.empty : (required_module * prim_token_interp_info) String.Map.t) + +(* Table from global_reference to backtrack-able informations about + prim_token uninterpretation (in particular uninterpreter unique id). *) +let prim_token_uninterp_infos = + ref (GlobRef.Map.empty : (scope_name * prim_token_interp_info * bool) GlobRef.Map.t) + +let hashtbl_check_and_set allow_overwrite uid f h eq = + match Hashtbl.find h uid with + | exception Not_found -> Hashtbl.add h uid f + | _ when allow_overwrite -> Hashtbl.add h uid f + | g when eq f g -> () + | _ -> + user_err ~hdr:"prim_token_interpreter" + (str "Unique identifier " ++ str uid ++ + str " already used to register a numeral or string (un)interpreter.") + +let register_gen_interpretation allow_overwrite uid (interp, uninterp) = + hashtbl_check_and_set + allow_overwrite uid interp prim_token_interpreters InnerPrimToken.interp_eq; + hashtbl_check_and_set + allow_overwrite uid uninterp prim_token_uninterpreters InnerPrimToken.uninterp_eq + +let register_rawnumeral_interpretation ?(allow_overwrite=false) uid (interp, uninterp) = + register_gen_interpretation allow_overwrite uid + (InnerPrimToken.RawNumInterp interp, InnerPrimToken.RawNumUninterp uninterp) + +let register_bignumeral_interpretation ?(allow_overwrite=false) uid (interp, uninterp) = + register_gen_interpretation allow_overwrite uid + (InnerPrimToken.BigNumInterp interp, InnerPrimToken.BigNumUninterp uninterp) + +let register_string_interpretation ?(allow_overwrite=false) uid (interp, uninterp) = + register_gen_interpretation allow_overwrite uid + (InnerPrimToken.StringInterp interp, InnerPrimToken.StringUninterp uninterp) + +let cache_prim_token_interpretation (_,infos) = + let ptii = infos.pt_interp_info in + let sc = infos.pt_scope in + check_scope ~tolerant:true sc; + prim_token_interp_infos := + String.Map.add sc (infos.pt_required,ptii) !prim_token_interp_infos; + List.iter (fun r -> prim_token_uninterp_infos := + GlobRef.Map.add r (sc,ptii,infos.pt_in_match) + !prim_token_uninterp_infos) + infos.pt_refs + +let subst_prim_token_interpretation (subs,infos) = + { infos with + pt_refs = List.map (subst_global_reference subs) infos.pt_refs } + +let classify_prim_token_interpretation infos = + if infos.pt_local then Dispose else Substitute infos + +let inPrimTokenInterp : prim_token_infos -> obj = + declare_object {(default_object "PRIM-TOKEN-INTERP") with + open_function = (fun i o -> if Int.equal i 1 then cache_prim_token_interpretation o); + cache_function = cache_prim_token_interpretation; + subst_function = subst_prim_token_interpretation; + classify_function = classify_prim_token_interpretation} + +let enable_prim_token_interpretation infos = + Lib.add_anonymous_leaf (inPrimTokenInterp infos) + +(** Compatibility. + Avoid the next two functions, they will now store unnecessary + objects in the library segment. Instead, combine + [register_*_interpretation] and [enable_prim_token_interpretation] + (the latter inside a [Mltop.declare_cache_obj]). +*) + +let fresh_string_of = + let count = ref 0 in + fun root -> count := !count+1; (string_of_int !count)^"_"^root + +let declare_numeral_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = + let uid = fresh_string_of sc in + register_bignumeral_interpretation uid (interp,uninterp); + enable_prim_token_interpretation + { pt_local = local; + pt_scope = sc; + pt_interp_info = Uid uid; + pt_required = dir; + pt_refs = List.map_filter glob_prim_constr_key patl; + pt_in_match = b } +let declare_string_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = + let uid = fresh_string_of sc in + register_string_interpretation uid (interp,uninterp); + enable_prim_token_interpretation + { pt_local = local; + pt_scope = sc; + pt_interp_info = Uid uid; + pt_required = dir; + pt_refs = List.map_filter glob_prim_constr_key patl; + pt_in_match = b } + + +let check_required_module ?loc sc (sp,d) = + try let _ = Nametab.global_of_path sp in () + with Not_found -> + match d with + | [] -> user_err ?loc ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " because " ++ pr_path sp ++ str " could not be found in the current environment.") + | _ -> user_err ?loc ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") + +(* Look if some notation or numeral printer in [scope] can be used in + the scope stack [scopes], and if yes, using delimiters or not *) + +let rec find_without_delimiters find (istype,ntn_scope,ntn as ntndata) = function + | UninterpScope scope :: scopes -> + (* Is the expected ntn/numpr attached to the most recently open scope? *) + begin match ntn_scope with + | Some scope' when String.equal scope scope' -> + Some None + | _ -> + (* 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 istype ntn_scope + else + find_without_delimiters find ntndata scopes + end + | UninterpSingle (NotationRule (_,ntn'),_,_) :: scopes -> + begin match ntn_scope, ntn with + | None, Some ntn when notation_eq ntn ntn' -> + Some None + | _ -> + find_without_delimiters find ntndata scopes + end + | UninterpSingle (SynDefRule _,_,_) :: scopes -> find_without_delimiters find ntndata scopes + | [] -> + (* Can we switch to [scope]? Yes if it has defined delimiters *) + find_with_delimiters istype ntn_scope + +(* The mapping between notations and their interpretation *) + +let warn_notation_overridden = + CWarnings.create ~name:"notation-overridden" ~category:"parsing" + (fun (ntn,which_scope) -> + str "Notation" ++ spc () ++ pr_notation ntn ++ spc () + ++ strbrk "was already used" ++ which_scope ++ str ".") + +let declare_notation_interpretation ntn scopt pat df ~onlyprint = + let scope = match scopt with Some s -> s | None -> default_scope in + let sc = find_scope scope in + if not onlyprint then begin + let () = + if NotationMap.mem ntn sc.notations then + let which_scope = match scopt with + | None -> mt () + | Some _ -> spc () ++ strbrk "in scope" ++ spc () ++ str scope in + warn_notation_overridden (ntn,which_scope) + in + let notdata = { + not_interp = pat; + not_location = df; + } in + let sc = { sc with notations = NotationMap.add ntn notdata sc.notations } in + scope_map := String.Map.add scope sc !scope_map + end; + begin match scopt with + | None -> scope_stack := SingleNotation ntn :: !scope_stack + | Some _ -> () + end + +let scope_of_rule = function + | NotationRule (None,_) | SynDefRule _ -> None + | NotationRule (Some sc as sco,_) -> sco + +let uninterp_scope_to_add pat n = function + | NotationRule (None,_) | SynDefRule _ as rule -> Some (UninterpSingle (rule,pat,n)) + | NotationRule (Some sc,_) -> None + +let declare_uninterpretation rule (metas,c as pat) = + let (key,n) = notation_constr_key c in + let sc = scope_of_rule rule in + notations_key_table := keymap_add key sc (rule,pat,n) !notations_key_table; + uninterp_scope_stack := Option.List.cons (uninterp_scope_to_add pat n rule) !uninterp_scope_stack + +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 notation_eq 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 *) + find_interpretation ntn find scopes) + | SingleNotation _::scopes -> + find_interpretation ntn find scopes + +let find_notation ntn sc = + let n = NotationMap.find ntn (find_scope sc).notations in + (n.not_interp, n.not_location) + +let notation_of_prim_token = function + | Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.to_string n + | Numeral (SMinus,n) -> InConstrEntrySomeLevel, "- "^NumTok.to_string n + | String _ -> raise Not_found + +let find_prim_token check_allowed ?loc p sc = + (* Try for a user-defined numerical notation *) + try + let (_,c),df = find_notation (notation_of_prim_token p) sc in + let pat = Notation_ops.glob_constr_of_notation_constr ?loc c in + check_allowed pat; + pat, df + with Not_found -> + (* Try for a primitive numerical notation *) + let (spdir,info) = String.Map.find sc !prim_token_interp_infos in + check_required_module ?loc sc spdir; + let interp = match info with + | Uid uid -> Hashtbl.find prim_token_interpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + | StringNotation o -> InnerPrimToken.StringInterp (Strings.interp o) + in + let pat = InnerPrimToken.do_interp ?loc interp p in + check_allowed pat; + pat, ((dirpath (fst spdir),DirPath.empty),"") + +let interp_prim_token_gen ?loc g p local_scopes = + let scopes = make_current_scopes local_scopes in + let p_as_ntn = try notation_of_prim_token p with Not_found -> InConstrEntrySomeLevel,"" in + try find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes + with Not_found -> + user_err ?loc ~hdr:"interp_prim_token" + ((match p with + | Numeral _ -> + str "No interpretation for numeral " ++ pr_notation (notation_of_prim_token p) + | String s -> str "No interpretation for string " ++ qs s) ++ str ".") + +let interp_prim_token ?loc = + interp_prim_token_gen ?loc (fun _ -> ()) + +let rec check_allowed_ref_in_pat looked_for = DAst.(with_val (function + | GVar _ | GHole _ -> () + | GRef (g,_) -> looked_for g + | GApp (f, l) -> + begin match DAst.get f with + | GRef (g, _) -> + looked_for g; List.iter (check_allowed_ref_in_pat looked_for) l + | _ -> raise Not_found + end + | _ -> raise Not_found)) + +let interp_prim_token_cases_pattern_expr ?loc looked_for p = + interp_prim_token_gen ?loc (check_allowed_ref_in_pat looked_for) 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 + (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") + +let extract_notations (istype,scopes) keys = + if keys == [] then [] (* shortcut *) else + let scope_map, global_map = !notations_key_table in + let rec aux scopes seen = + match scopes with + | UninterpScope sc :: scopes -> keymap_extract istype keys sc scope_map @ aux scopes (String.Set.add sc seen) + | UninterpSingle rule :: scopes -> (rule,None,false) :: aux scopes seen + | [] -> + let find key = try KeyMap.find key global_map with Not_found -> [] in + keymap_extract_remainder istype seen (List.flatten (List.map find keys)) + in aux scopes String.Set.empty + +let uninterp_notations scopes c = + let scopes = make_current_uninterp_scopes scopes in + extract_notations scopes (glob_constr_keys c) + +let uninterp_cases_pattern_notations scopes c = + let scopes = make_current_uninterp_scopes scopes in + extract_notations scopes [cases_pattern_key c] + +let uninterp_ind_pattern_notations scopes ind = + let scopes = make_current_uninterp_scopes scopes in + extract_notations scopes [RefKey (canonical_gr (IndRef ind))] + +(* We support coercions from a custom entry at some level to an entry + at some level (possibly the same), and from and to the constr entry. E.g.: + + Notation "[ expr ]" := expr (expr custom group at level 1). + Notation "( x )" := x (in custom group at level 0, x at level 1). + Notation "{ x }" := x (in custom group at level 0, x constr). + + Supporting any level is maybe overkill in that coercions are + commonly from the lowest level of the source entry to the highest + level of the target entry. *) + +type entry_coercion = notation list + +module EntryCoercionOrd = + struct + type t = notation_entry * notation_entry + let compare = Pervasives.compare + end + +module EntryCoercionMap = Map.Make(EntryCoercionOrd) + +let entry_coercion_map = ref EntryCoercionMap.empty + +let level_ord lev lev' = + match lev, lev' with + | None, _ -> true + | _, None -> true + | Some n, Some n' -> n <= n' + +let rec search nfrom nto = function + | [] -> raise Not_found + | ((pfrom,pto),coe)::l -> + if level_ord pfrom nfrom && level_ord nto pto then coe else search nfrom nto l + +let decompose_custom_entry = function + | InConstrEntrySomeLevel -> InConstrEntry, None + | InCustomEntryLevel (s,n) -> InCustomEntry s, Some n + +let availability_of_entry_coercion entry entry' = + let entry, lev = decompose_custom_entry entry in + let entry', lev' = decompose_custom_entry entry' in + if notation_entry_eq entry entry' && level_ord lev' lev then Some [] + else + try Some (search lev lev' (EntryCoercionMap.find (entry,entry') !entry_coercion_map)) + with Not_found -> None + +let better_path ((lev1,lev2),path) ((lev1',lev2'),path') = + (* better = shorter and lower source and higher target *) + level_ord lev1 lev1' && level_ord lev2' lev2 && List.length path <= List.length path' + +let shorter_path (_,path) (_,path') = + List.length path <= List.length path' + +let rec insert_coercion_path path = function + | [] -> [path] + | path'::paths as allpaths -> + (* If better or equal we keep the more recent one *) + if better_path path path' then path::paths + else if better_path path' path then allpaths + else if shorter_path path path' then path::allpaths + else path'::insert_coercion_path path paths + +let declare_entry_coercion (entry,_ as ntn) entry' = + let entry, lev = decompose_custom_entry entry in + let entry', lev' = decompose_custom_entry entry' in + (* Transitive closure *) + let toaddleft = + EntryCoercionMap.fold (fun (entry'',entry''') paths l -> + List.fold_right (fun ((lev'',lev'''),path) l -> + if notation_entry_eq entry entry''' && level_ord lev lev''' && + not (notation_entry_eq entry' entry'') + then ((entry'',entry'),((lev'',lev'),path@[ntn]))::l else l) paths l) + !entry_coercion_map [] in + let toaddright = + EntryCoercionMap.fold (fun (entry'',entry''') paths l -> + List.fold_right (fun ((lev'',lev'''),path) l -> + if entry' = entry'' && level_ord lev' lev'' && entry <> entry''' + then ((entry,entry'''),((lev,lev'''),path@[ntn]))::l else l) paths l) + !entry_coercion_map [] in + entry_coercion_map := + List.fold_right (fun (pair,path) -> + let olds = try EntryCoercionMap.find pair !entry_coercion_map with Not_found -> [] in + EntryCoercionMap.add pair (insert_coercion_path path olds)) + (((entry,entry'),((lev,lev'),[ntn]))::toaddright@toaddleft) + !entry_coercion_map + +let entry_has_global_map = ref String.Map.empty + +let declare_custom_entry_has_global s n = + try + let p = String.Map.find s !entry_has_global_map in + user_err (str "Custom entry " ++ str s ++ + str " has already a rule for global references at level " ++ int p ++ str ".") + with Not_found -> + entry_has_global_map := String.Map.add s n !entry_has_global_map + +let entry_has_global = function + | InConstrEntrySomeLevel -> true + | InCustomEntryLevel (s,n) -> + try String.Map.find s !entry_has_global_map <= n with Not_found -> false + +let entry_has_ident_map = ref String.Map.empty + +let declare_custom_entry_has_ident s n = + try + let p = String.Map.find s !entry_has_ident_map in + user_err (str "Custom entry " ++ str s ++ + str " has already a rule for global references at level " ++ int p ++ str ".") + with Not_found -> + entry_has_ident_map := String.Map.add s n !entry_has_ident_map + +let entry_has_ident = function + | InConstrEntrySomeLevel -> true + | InCustomEntryLevel (s,n) -> + try String.Map.find s !entry_has_ident_map <= n with Not_found -> false + +let uninterp_prim_token c = + match glob_prim_constr_key c with + | None -> raise Notation_ops.No_match + | Some r -> + try + let (sc,info,_) = GlobRef.Map.find r !prim_token_uninterp_infos in + let uninterp = match info with + | Uid uid -> Hashtbl.find prim_token_uninterpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + | StringNotation o -> InnerPrimToken.StringUninterp (Strings.uninterp o) + in + match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with + | None -> raise Notation_ops.No_match + | Some n -> (sc,n) + with Not_found -> raise Notation_ops.No_match + +let uninterp_prim_token_cases_pattern c = + match glob_constr_of_closed_cases_pattern (Global.env()) c with + | exception Not_found -> raise Notation_ops.No_match + | na,c -> let (sc,n) = uninterp_prim_token c in (na,sc,n) + +let availability_of_prim_token n printer_scope local_scopes = + let f scope = + try + let uid = snd (String.Map.find scope !prim_token_interp_infos) in + let open InnerPrimToken in + match n, uid with + | Numeral _, NumeralNotation _ -> true + | _, NumeralNotation _ -> false + | String _, StringNotation _ -> true + | _, StringNotation _ -> false + | _, Uid uid -> + let interp = Hashtbl.find prim_token_interpreters uid in + match n, interp with + | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true + | String _, StringInterp _ -> true + | _ -> false + with Not_found -> false + in + let istype,scopes = make_current_uninterp_scopes local_scopes in + find_without_delimiters f (istype,Some printer_scope,None) scopes + +(* Miscellaneous *) + +let notation_binder_source_eq s1 s2 = match s1, s2 with +| NtnParsedAsIdent, NtnParsedAsIdent -> true +| NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 +| NtnBinderParsedAsConstr bk1, NtnBinderParsedAsConstr bk2 -> bk1 = bk2 +| (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _), _ -> false + +let ntpe_eq t1 t2 = match t1, t2 with +| NtnTypeConstr, NtnTypeConstr -> true +| NtnTypeBinder s1, NtnTypeBinder s2 -> notation_binder_source_eq s1 s2 +| NtnTypeConstrList, NtnTypeConstrList -> true +| NtnTypeBinderList, NtnTypeBinderList -> true +| (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false + +let var_attributes_eq (_, ((entry1, (tmpsc1, scl1)), tp1)) (_, ((entry2, (tmpsc2, scl2)), tp2)) = + notation_entry_level_eq entry1 entry2 && + Option.equal String.equal tmpsc1 tmpsc2 && + List.equal String.equal scl1 scl2 && + ntpe_eq tp1 tp2 + +let interpretation_eq (vars1, t1) (vars2, t2) = + List.equal var_attributes_eq vars1 vars2 && + Notation_ops.eq_notation_constr (List.map fst vars1, List.map fst vars2) t1 t2 + +let exists_notation_in_scope scopt ntn onlyprint r = + let scope = match scopt with Some s -> s | None -> default_scope in + try + let sc = String.Map.find scope !scope_map in + let n = NotationMap.find ntn sc.notations in + interpretation_eq n.not_interp r + with Not_found -> false + +let exists_notation_interpretation_in_scope scopt ntn = + let scope = match scopt with Some s -> s | None -> default_scope in + try + let sc = String.Map.find scope !scope_map in + let _ = NotationMap.find ntn sc.notations in + true + with Not_found -> false + +let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false + +(**********************************************************************) +(* Special scopes associated to arguments of a global reference *) + +let rec compute_arguments_classes sigma t = + match EConstr.kind sigma (Reductionops.whd_betaiotazeta sigma t) with + | Prod (_,t,u) -> + let cl = try Some (compute_scope_class sigma t) with Not_found -> None in + cl :: compute_arguments_classes sigma u + | _ -> [] + +let compute_arguments_scope_full sigma t = + let cls = compute_arguments_classes sigma t in + let scs = List.map find_scope_class_opt cls in + scs, cls + +let compute_arguments_scope sigma t = fst (compute_arguments_scope_full sigma t) + +let compute_type_scope sigma t = + find_scope_class_opt (try Some (compute_scope_class sigma t) with Not_found -> None) + +let scope_class_of_class (x : cl_typ) : scope_class = + x + +(** 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 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 GlobRef.Map.empty + +type arguments_scope_discharge_request = + | ArgsScopeAuto + | ArgsScopeManual + | ArgsScopeNoDischarge + +let load_arguments_scope _ (_,(_,r,n,scl,cls)) = + List.iter (Option.iter check_scope) scl; + let initial_stamp = ScopeClassMap.empty in + arguments_scope := GlobRef.Map.add r (scl,cls,initial_stamp) !arguments_scope + +let cache_arguments_scope o = + load_arguments_scope 1 o + +let subst_scope_class subst cs = + try Some (subst_cl_typ subst cs) with Not_found -> None + +let subst_arguments_scope (subst,(req,r,n,scl,cls)) = + let r' = fst (subst_global subst r) in + 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.Smart.map subst_cl cls in + (ArgsScopeNoDischarge,r',n,scl,cls') + +let discharge_arguments_scope (_,(req,r,n,l,_)) = + if req == ArgsScopeNoDischarge || (isVarRef r && Lib.is_in_section r) then None + else + let n = + try + let vars = Lib.variable_section_segment_of_reference r in + vars |> List.map fst |> List.filter is_local_assum |> List.length + with + Not_found (* Not a ref defined in this section *) -> 0 in + Some (req,r,n,l,[]) + +let classify_arguments_scope (req,_,_,_,_ as obj) = + if req == ArgsScopeNoDischarge then Dispose else Substitute obj + +let rebuild_arguments_scope sigma (req,r,n,l,_) = + match req with + | ArgsScopeNoDischarge -> assert false + | ArgsScopeAuto -> + let env = Global.env () in (*FIXME?*) + let typ = EConstr.of_constr @@ fst (Typeops.type_of_global_in_context env r) in + let scs,cls = compute_arguments_scope_full sigma typ in + (req,r,List.length scs,scs,cls) + | ArgsScopeManual -> + (* Add to the manually given scopes the one found automatically + for the extra parameters of the section. Discard the classes + of the manually given scopes to avoid further re-computations. *) + let env = Global.env () in (*FIXME?*) + let typ = EConstr.of_constr @@ fst (Typeops.type_of_global_in_context env r) in + let l',cls = compute_arguments_scope_full sigma typ in + let l1 = List.firstn n l' in + let cls1 = List.firstn n cls in + (req,r,0,l1@l,cls1) + +type arguments_scope_obj = + arguments_scope_discharge_request * GlobRef.t * + (* Used to communicate information from discharge to rebuild *) + (* set to 0 otherwise *) int * + scope_name option list * scope_class option list + +let inArgumentsScope : arguments_scope_obj -> obj = + declare_object {(default_object "ARGUMENTS-SCOPE") with + cache_function = cache_arguments_scope; + load_function = load_arguments_scope; + subst_function = subst_arguments_scope; + classify_function = classify_arguments_scope; + discharge_function = discharge_arguments_scope; + (* XXX: Should we pass the sigma here or not, see @herbelin's comment in 6511 *) + rebuild_function = rebuild_arguments_scope Evd.empty } + +let is_local local ref = local || isVarRef ref && Lib.is_in_section ref + +let declare_arguments_scope_gen req r n (scl,cls) = + Lib.add_anonymous_leaf (inArgumentsScope (req,r,n,scl,cls)) + +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 further scope + re-computations and keep these manually given scopes. *) + declare_arguments_scope_gen req r 0 (scl,[]) + +let find_arguments_scope r = + try + let (scl,cls,stamp) = GlobRef.Map.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 := GlobRef.Map.add r (scl',cls,cur_stamp) !arguments_scope; + scl' + with Not_found -> [] + +let declare_ref_arguments_scope sigma ref = + let env = Global.env () in (* FIXME? *) + let typ = EConstr.of_constr @@ fst @@ Typeops.type_of_global_in_context env ref in + let (scs,cls as o) = compute_arguments_scope_full sigma typ in + declare_arguments_scope_gen ArgsScopeAuto ref (List.length scs) o + +(********************************) +(* Encoding notations as string *) + +type symbol = + | Terminal of string + | 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 "_" -> ["'_'"] + | Terminal s -> [s] + | SProdList (_,l) -> + let l = List.flatten (List.map string_of_symbol l) in "_"::l@".."::l@["_"] + | Break _ -> [] + +let make_notation_key from symbols = + (from,String.concat " " (List.flatten (List.map string_of_symbol symbols))) + +let decompose_notation_key (from,s) = + let len = String.length s in + let rec decomp_ntn dirs n = + if n>=len then List.rev dirs else + let pos = + try + String.index_from s n ' ' + with Not_found -> len + in + let tok = + match String.sub s n (pos-n) with + | "_" -> NonTerminal (Id.of_string "_") + | s -> Terminal (String.drop_simple_quotes s) in + decomp_ntn (tok::dirs) (pos+1) + in + from, decomp_ntn [] 0 + +(************) +(* Printing *) + +let pr_delimiters_info = function + | None -> str "No delimiting key" + | Some key -> str "Delimiting key is " ++ str key + +let classes_of_scope sc = + ScopeClassMap.fold (fun cl sc' l -> if String.equal sc sc' then cl::l else l) !scope_class_map [] + +let pr_scope_class = pr_class + +let pr_scope_classes sc = + let l = classes_of_scope sc in + match l with + | [] -> mt () + | _ :: ll -> + let opt_s = match ll with [] -> mt () | _ -> str "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 (Notation_ops.glob_constr_of_notation_constr c) + +let pr_named_scope prglob scope sc = + (if String.equal scope default_scope then + match NotationMap.cardinal sc.notations with + | 0 -> str "No lonely notation" + | 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 + ++ NotationMap.fold + (fun ntn { not_interp = (_, r); not_location = (_, df) } strm -> + pr_notation_info prglob df r ++ fnl () ++ strm) + sc.notations (mt ()) + +let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope) + +let pr_scopes prglob = + String.Map.fold + (fun scope sc strm -> pr_named_scope prglob scope sc ++ fnl () ++ strm) + !scope_map (mt ()) + +let rec find_default ntn = function + | [] -> None + | Scope scope :: scopes -> + if NotationMap.mem ntn (find_scope scope).notations then + Some scope + else find_default ntn scopes + | SingleNotation ntn' :: scopes -> + if notation_eq ntn ntn' then Some default_scope + else find_default ntn scopes + +let factorize_entries = function + | [] -> [] + | (ntn,c)::l -> + let (ntn,l_of_ntn,rest) = + List.fold_left + (fun (a',l,rest) (a,c) -> + if notation_eq a a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) + (ntn,[c],[]) l in + (ntn,l_of_ntn)::rest + +type symbol_token = WhiteSpace of int | String of string + +let split_notation_string str = + let push_token beg i l = + if Int.equal beg i then l else + let s = String.sub str beg (i - beg) in + String s :: l + in + let push_whitespace beg i l = + if Int.equal beg i then l else WhiteSpace (i-beg) :: l + in + let rec loop beg i = + if i < String.length str then + if str.[i] == ' ' then + push_token beg i (loop_on_whitespace (i+1) (i+1)) + else + loop beg (i+1) + else + push_token beg i [] + and loop_on_whitespace beg i = + if i < String.length str then + if str.[i] != ' ' then + push_whitespace beg i (loop i (i+1)) + else + loop_on_whitespace beg (i+1) + else + push_whitespace beg i [] + in + loop 0 0 + +let rec raw_analyze_notation_tokens = function + | [] -> [] + | String ".." :: sl -> NonTerminal Notation_ops.ldots_var :: raw_analyze_notation_tokens sl + | String "_" :: _ -> user_err Pp.(str "_ must be quoted.") + | String x :: sl when Id.is_valid x -> + NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl + | String s :: sl -> + Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl + | WhiteSpace n :: sl -> + Break n :: raw_analyze_notation_tokens sl + +let decompose_raw_notation ntn = raw_analyze_notation_tokens (split_notation_string ntn) + +let possible_notations ntn = + (* We collect the possible interpretations of a notation string depending on whether it is + in "x 'U' y" or "_ U _" format *) + let toks = split_notation_string ntn in + if List.exists (function String "_" -> true | _ -> false) toks then + (* Only "_ U _" format *) + [ntn] + else + let _,ntn' = make_notation_key None (raw_analyze_notation_tokens toks) in + if String.equal ntn ntn' then (* Only symbols *) [ntn] else [ntn;ntn'] + +let browse_notation strict ntn map = + let ntns = possible_notations ntn in + let find (from,ntn' as fullntn') ntn = + if String.contains ntn ' ' then String.equal ntn ntn' + else + let _,toks = decompose_notation_key fullntn' 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 = + String.Map.fold + (fun scope_name sc -> + NotationMap.fold (fun ntn { not_interp = (_, r); not_location = df } l -> + if List.exists (find ntn) ntns then (ntn,(scope_name,r,df))::l else l) sc.notations) + map [] in + List.sort (fun x y -> String.compare (snd (fst x)) (snd (fst y))) l + +let global_reference_of_notation test (ntn,(sc,c,_)) = + match c with + | 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 + +let error_ambiguous_notation ?loc _ntn = + user_err ?loc (str "Ambiguous notation.") + +let error_notation_not_reference ?loc ntn = + user_err ?loc + (str "Unable to interpret " ++ quote (str ntn) ++ + str " as a reference.") + +let interp_notation_as_global_reference ?loc test ntn sc = + let scopes = match sc with + | Some sc -> + let scope = find_scope (find_delimiters_scope 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 + match Option.List.flatten refs with + | [_,_,ref] -> ref + | [] -> error_notation_not_reference ?loc ntn + | refs -> + 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 + | _ -> error_ambiguous_notation ?loc ntn + +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 + match ntns with + | [] -> str "Unknown notation" + | _ -> + str "Notation" ++ fnl () ++ + prlist_with_sep fnl (fun (ntn,l) -> + let scope = find_default ntn scopes in + prlist_with_sep fnl + (fun (sc,r,(_,df)) -> + hov 0 ( + pr_notation_info prglob df r ++ + (if String.equal sc default_scope then mt () + else (spc () ++ str ": " ++ str sc)) ++ + (if Option.equal String.equal (Some sc) scope + then spc () ++ str "(default interpretation)" else mt ()))) + l) ntns + +let collect_notation_in_scope scope sc known = + assert (not (String.equal scope default_scope)); + NotationMap.fold + (fun ntn { not_interp = (_, r); not_location = (_, df) } (l,known as acc) -> + if List.mem_f notation_eq 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 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_f notation_eq ntn knownntn then (all,knownntn) + else + let { not_interp = (_, r); not_location = (_, df) } = + NotationMap.find ntn (find_scope default_scope).notations in + let all' = match all with + | (s,lonelyntn)::rest when String.equal s default_scope -> + (s,(df,r)::lonelyntn)::rest + | _ -> + (default_scope,[df,r])::all in + (all',ntn::knownntn)) + ([],[]) stack) + +let pr_visible_in_scope prglob (scope,ntns) = + let strm = + List.fold_right + (fun (df,r) strm -> pr_notation_info prglob df r ++ fnl () ++ strm) + ntns (mt ()) in + (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 + +let pr_scope_stack prglob stack = + List.fold_left + (fun strm scntns -> strm ++ pr_visible_in_scope prglob scntns ++ fnl ()) + (mt ()) (collect_notations stack) + +let pr_visibility prglob = function + | Some scope -> pr_scope_stack prglob (push_scope scope !scope_stack) + | None -> pr_scope_stack prglob !scope_stack + +(**********************************************************************) +(* Synchronisation with reset *) + +let freeze ~marshallable = + (!scope_map, !scope_stack, !uninterp_scope_stack, !arguments_scope, + !delimiters_map, !notations_key_table, !scope_class_map, + !prim_token_interp_infos, !prim_token_uninterp_infos, + !entry_coercion_map, !entry_has_global_map, + !entry_has_ident_map) + +let unfreeze (scm,scs,uscs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = + scope_map := scm; + scope_stack := scs; + uninterp_scope_stack := uscs; + arguments_scope := asc; + delimiters_map := dlm; + notations_key_table := fkm; + scope_class_map := clsc; + prim_token_interp_infos := ptii; + prim_token_uninterp_infos := ptui; + entry_coercion_map := coe; + entry_has_global_map := globs; + entry_has_ident_map := ids + +let init () = + init_scope_map (); + uninterp_scope_stack := []; + delimiters_map := String.Map.empty; + notations_key_table := (ScopeMap.empty,KeyMap.empty); + scope_class_map := initial_scope_class_map; + prim_token_interp_infos := String.Map.empty; + prim_token_uninterp_infos := GlobRef.Map.empty + +let _ = + 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 ~marshallable:false in + try let a = f x in unfreeze fs; a + with reraise -> + let reraise = CErrors.push reraise in + let () = unfreeze fs in + iraise reraise diff --git a/interp/notation.mli b/interp/notation.mli new file mode 100644 index 0000000000..57e2be16b9 --- /dev/null +++ b/interp/notation.mli @@ -0,0 +1,331 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Libnames +open Constrexpr +open Glob_term +open Notation_term + +(** Notations *) + +val pr_notation : notation -> Pp.t +(** Printing *) + +val notation_entry_eq : notation_entry -> notation_entry -> bool +(** Equality on [notation_entry]. *) + +val notation_entry_level_eq : notation_entry_level -> notation_entry_level -> bool +(** Equality on [notation_entry_level]. *) + +val notation_eq : notation -> notation -> bool +(** Equality on [notation]. *) + +module NotationSet : Set.S with type elt = notation +module NotationMap : CMap.ExtS with type key = notation and module Set := NotationSet + +(** {6 Scopes } *) +(** A scope is a set of interpreters for symbols + optional + interpreter and printers for integers + optional delimiters *) + +type delimiters = string +type scope +type scopes (** = [scope_name list] *) + +val declare_scope : scope_name -> unit + +(* To be removed after deprecation phase *) +val ensure_scope : scope_name -> unit + +val current_scopes : unit -> scopes + +(** 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 +val scope_is_open : scope_name -> bool + +(** Open scope *) + +val open_close_scope : + (* locality *) bool * (* open *) bool * scope_name -> unit + +(** Extend a list of scopes *) +val empty_scope_stack : scopes +val push_scope : scope_name -> scopes -> scopes + +val find_scope : scope_name -> scope + +(** Declare delimiters for printing *) + +val declare_delimiters : scope_name -> delimiters -> unit +val remove_delimiters : scope_name -> unit +val find_delimiters_scope : ?loc:Loc.t -> delimiters -> scope_name + +(** {6 Declare and uses back and forth an interpretation of primitive token } *) + +(** A numeral interpreter is the pair of an interpreter for **decimal** + numbers in terms and an optional interpreter in pattern, if + non integer or negative numbers are not supported, the interpreter + must fail with an appropriate error message *) + +type notation_location = (DirPath.t * DirPath.t) * string +type required_module = full_path * string list +type rawnum = Constrexpr.sign * Constrexpr.raw_numeral + +(** The unique id string below will be used to refer to a particular + registered interpreter/uninterpreter of numeral or string notation. + Using the same uid for different (un)interpreters will fail. + If at most one interpretation of prim token is used per scope, + then the scope name could be used as unique id. *) + +type prim_token_uid = string + +type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> glob_constr +type 'a prim_token_uninterpreter = any_glob_constr -> 'a option + +type 'a prim_token_interpretation = + 'a prim_token_interpreter * 'a prim_token_uninterpreter + +val register_rawnumeral_interpretation : + ?allow_overwrite:bool -> prim_token_uid -> rawnum prim_token_interpretation -> unit + +val register_bignumeral_interpretation : + ?allow_overwrite:bool -> prim_token_uid -> Bigint.bigint prim_token_interpretation -> unit + +val register_string_interpretation : + ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit + +(** * Numeral notation *) + +type prim_token_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_token_notation_error + +type numnot_option = + | Nop + | Warning of string + | Abstract of string + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type decimal_ty = + { int : int_ty; + decimal : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Decimal of decimal_ty (* Coq.Init.Decimal.decimal + uint + int *) + +type string_target_kind = + | ListByte + | Byte + +type option_kind = Option | Direct +type 'target conversion_kind = 'target * option_kind + +type ('target, 'warning) prim_token_notation_obj = + { to_kind : 'target conversion_kind; + to_ty : GlobRef.t; + of_kind : 'target conversion_kind; + of_ty : GlobRef.t; + ty_name : Libnames.qualid; (* for warnings / error messages *) + warning : 'warning } + +type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + | StringNotation of string_notation_obj + +type prim_token_infos = { + pt_local : bool; (** Is this interpretation local? *) + pt_scope : scope_name; (** Concerned scope *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_required : required_module; (** Module that should be loaded first *) + pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) + pt_in_match : bool (** Is this prim token legal in match patterns ? *) +} + +(** Note: most of the time, the [pt_refs] field above will contain + inductive constructors (e.g. O and S for nat). But it could also be + injection functions such as IZR for reals. *) + +(** Activate a prim token interpretation whose unique id and functions + have already been registered. *) + +val enable_prim_token_interpretation : prim_token_infos -> unit + +(** Compatibility. + Avoid the next two functions, they will now store unnecessary + objects in the library segment. Instead, combine + [register_*_interpretation] and [enable_prim_token_interpretation] + (the latter inside a [Mltop.declare_cache_obj]). +*) + +val declare_numeral_interpreter : ?local:bool -> scope_name -> required_module -> + Bigint.bigint prim_token_interpreter -> + glob_constr list * Bigint.bigint prim_token_uninterpreter * bool -> unit +val declare_string_interpreter : ?local:bool -> scope_name -> required_module -> + string prim_token_interpreter -> + glob_constr list * string prim_token_uninterpreter * bool -> unit + +(** Return the [term]/[cases_pattern] bound to a primitive token in a + given scope context*) + +val interp_prim_token : ?loc:Loc.t -> prim_token -> subscopes -> + glob_constr * (notation_location * scope_name option) +(* This function returns a glob_const representing a pattern *) +val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (GlobRef.t -> unit) -> prim_token -> + subscopes -> glob_constr * (notation_location * scope_name option) + +(** Return the primitive token associated to a [term]/[cases_pattern]; + raise [No_match] if no such token *) + +val uninterp_prim_token : + 'a glob_constr_g -> scope_name * prim_token +val uninterp_prim_token_cases_pattern : + 'a cases_pattern_g -> Name.t * scope_name * prim_token + +val availability_of_prim_token : + prim_token -> scope_name -> subscopes -> delimiters option option + +(** {6 Declare and interpret back and forth a notation } *) + +(** Binds a notation in a given scope to an interpretation *) +type interp_rule = + | NotationRule of scope_name option * notation + | SynDefRule of KerName.t + +module InterpRuleSet : Set.S with type elt = interp_rule + +val declare_notation_interpretation : notation -> scope_name option -> + interpretation -> notation_location -> onlyprint:bool -> unit + +val declare_uninterpretation : interp_rule -> interpretation -> unit + +(** Return the interpretation bound to a notation *) +val interp_notation : ?loc:Loc.t -> notation -> subscopes -> + interpretation * (notation_location * scope_name option) + +type notation_rule_core = + interp_rule (* kind of notation *) + * interpretation (* pattern associated to the notation *) + * int option (* number of expected arguments *) + +type notation_rule = + notation_rule_core + * delimiters option (* delimiter to possibly add *) + * bool (* true if the delimiter is mandatory *) + +(** Return the possible notations for a given term *) +val uninterp_notations : subscopes -> 'a glob_constr_g -> notation_rule list +val uninterp_cases_pattern_notations : subscopes -> 'a cases_pattern_g -> notation_rule list +val uninterp_ind_pattern_notations : subscopes -> inductive -> notation_rule list + +(* +(** Test if a notation is available in the scopes + context [scopes]; if available, the result is not None; the first + argument is itself not None if a delimiters is needed *) +val availability_of_notation : scope_name option * notation -> subscopes -> + (scope_name option * delimiters option) option + *) + +(** {6 Miscellaneous} *) + +val interp_notation_as_global_reference : ?loc:Loc.t -> (GlobRef.t -> bool) -> + notation_key -> delimiters option -> GlobRef.t + +(** Checks for already existing notations *) +val exists_notation_in_scope : scope_name option -> notation -> + bool -> interpretation -> bool + +(** Checks for already existing notations *) +val exists_notation_interpretation_in_scope : scope_name option -> notation -> bool + +(** Declares and looks for scopes associated to arguments of a global ref *) +val declare_arguments_scope : + bool (** true=local *) -> GlobRef.t -> scope_name option list -> unit + +val find_arguments_scope : GlobRef.t -> scope_name option list + +type scope_class + +(** Comparison of scope_class *) +val scope_class_compare : scope_class -> scope_class -> int + +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 : Evd.evar_map -> GlobRef.t -> unit + +val compute_arguments_scope : Evd.evar_map -> EConstr.types -> scope_name option list +val compute_type_scope : Evd.evar_map -> EConstr.types -> scope_name option + +(** Get the current scope bound to Sortclass, if it exists *) +val current_type_scope_name : unit -> scope_name option + +val scope_class_of_class : Classops.cl_typ -> scope_class + +(** Building notation key *) + +type symbol = + | Terminal of string (* an expression including symbols or a simply-quoted ident, e.g. "'U'" or "!" *) + | NonTerminal of Id.t (* an identifier "x" *) + | SProdList of Id.t * symbol list (* an expression "x sep .. sep y", remembering x (or y) and sep *) + | Break of int (* a sequence of blanks > 1, e.g. " " *) + +val symbol_eq : symbol -> symbol -> bool + +(** Make/decompose a notation of the form "_ U _" *) +val make_notation_key : notation_entry_level -> symbol list -> notation +val decompose_notation_key : notation -> notation_entry_level * symbol list + +(** Decompose a notation of the form "a 'U' b" *) +val decompose_raw_notation : string -> symbol list + +(** Prints scopes (expects a pure aconstr printer) *) +val pr_scope_class : scope_class -> Pp.t +val pr_scope : (glob_constr -> Pp.t) -> scope_name -> Pp.t +val pr_scopes : (glob_constr -> Pp.t) -> Pp.t +val locate_notation : (glob_constr -> Pp.t) -> notation_key -> + scope_name option -> Pp.t + +val pr_visibility: (glob_constr -> Pp.t) -> scope_name option -> Pp.t + +type entry_coercion = notation list +val declare_entry_coercion : notation -> notation_entry_level -> unit +val availability_of_entry_coercion : notation_entry_level -> notation_entry_level -> entry_coercion option + +val declare_custom_entry_has_global : string -> int -> unit +val declare_custom_entry_has_ident : string -> int -> unit + +val entry_has_global : notation_entry_level -> bool +val entry_has_ident : notation_entry_level -> bool + +(** Rem: printing rules for primitive token are canonical *) + +val with_notation_protection : ('a -> 'b) -> 'a -> 'b + +(** Conversion from bigint to int63 *) +val int63_of_pos_bigint : Bigint.bigint -> Uint63.t diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml new file mode 100644 index 0000000000..7f084fffdd --- /dev/null +++ b/interp/notation_ops.ml @@ -0,0 +1,1389 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Nameops +open Constr +open Globnames +open Decl_kinds +open Namegen +open Glob_term +open Glob_ops +open Mod_subst +open Notation_term + +(**********************************************************************) +(* Utilities *) + +(* helper for NVar, NVar case in eq_notation_constr *) +let get_var_ndx id vs = try Some (List.index Id.equal id vs) with Not_found -> None + +let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with +| NRef gr1, NRef gr2 -> GlobRef.equal gr1 gr2 +| NVar id1, NVar id2 -> ( + match (get_var_ndx id1 vars1,get_var_ndx id2 vars2) with + | Some n,Some m -> Int.equal n m + | None ,None -> Id.equal id1 id2 + | _ -> false) +| NApp (t1, a1), NApp (t2, a2) -> + (eq_notation_constr vars) t1 t2 && List.equal (eq_notation_constr vars) a1 a2 +| NHole (_, _, _), NHole (_, _, _) -> true (* FIXME? *) +| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> + Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && + (eq_notation_constr vars) u1 u2 && b1 == b2 +| NLambda (na1, t1, u1), NLambda (na2, t2, u2) -> + Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 +| NProd (na1, t1, u1), NProd (na2, t2, u2) -> + Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 +| NBinderList (i1, j1, t1, u1, b1), NBinderList (i2, j2, t2, u2, b2) -> + Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && + (eq_notation_constr vars) u1 u2 && b1 == b2 +| NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr vars b1 b2 && + Option.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 +| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (* FIXME? *) + let eqpat (p1, t1) (p2, t2) = + List.equal cases_pattern_eq p1 p2 && + (eq_notation_constr vars) t1 t2 + in + let eqf (t1, (na1, o1)) (t2, (na2, o2)) = + let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in + (eq_notation_constr vars) t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 + in + Option.equal (eq_notation_constr vars) o1 o2 && + List.equal eqf r1 r2 && + List.equal eqpat p1 p2 +| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) -> + List.equal Name.equal nas1 nas2 && + Name.equal na1 na2 && + Option.equal (eq_notation_constr vars) o1 o2 && + (eq_notation_constr vars) t1 t2 && + (eq_notation_constr vars) u1 u2 +| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) -> + (eq_notation_constr vars) t1 t2 && + Name.equal na1 na2 && + Option.equal (eq_notation_constr vars) o1 o2 && + (eq_notation_constr vars) u1 u2 && + (eq_notation_constr vars) r1 r2 +| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (* FIXME? *) + let eq (na1, o1, t1) (na2, o2, t2) = + Name.equal na1 na2 && + Option.equal (eq_notation_constr vars) o1 o2 && + (eq_notation_constr vars) t1 t2 + in + Array.equal Id.equal ids1 ids2 && + Array.equal (List.equal eq) ts1 ts2 && + Array.equal (eq_notation_constr vars) us1 us2 && + Array.equal (eq_notation_constr vars) rs1 rs2 +| NSort s1, NSort s2 -> + glob_sort_eq s1 s2 +| NCast (t1, c1), NCast (t2, c2) -> + (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2 +| NInt i1, NInt i2 -> + Uint63.equal i1 i2 +| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ + | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ + | NRec _ | NSort _ | NCast _ | NInt _), _ -> false + +(**********************************************************************) +(* Re-interpret a notation as a glob_constr, taking care of binders *) + +let name_to_ident = function + | Anonymous -> CErrors.user_err Pp.(str "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 product_of_cases_patterns patl = + List.fold_right (fun patl restl -> + List.flatten (List.map (fun p -> List.map (fun rest -> p::rest) restl) patl)) + patl [[]] + +let rec cases_pattern_fold_map ?loc g e = DAst.with_val (function + | PatVar na -> + let e',disjpat,na' = g e na in + e', (match disjpat with + | None -> [DAst.make ?loc @@ PatVar na'] + | Some ((_,disjpat),_) -> disjpat) + | PatCstr (cstr,patl,na) -> + let e',disjpat,na' = g e na in + if disjpat <> None then user_err (Pp.str "Unable to instantiate an \"as\" clause with a pattern."); + let e',patl' = List.fold_left_map (cases_pattern_fold_map ?loc g) e patl in + (* Distribute outwards the inner disjunctive patterns *) + let disjpatl' = product_of_cases_patterns patl' in + e', List.map (fun patl' -> DAst.make ?loc @@ PatCstr (cstr,patl',na')) disjpatl' + ) + +let subst_binder_type_vars l = function + | Evar_kinds.BinderType (Name id) -> + let id = + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id + with Not_found -> id in + Evar_kinds.BinderType (Name id) + | e -> e + +let rec subst_glob_vars l gc = DAst.map (function + | GVar id as r -> (try DAst.get (Id.List.assoc id l) with Not_found -> r) + | GProd (Name id,bk,t,c) -> + let id = + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id + with Not_found -> id in + GProd (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) + | GLambda (Name id,bk,t,c) -> + let id = + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id + with Not_found -> id in + GLambda (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) + | GHole (x,naming,arg) -> GHole (subst_binder_type_vars l x,naming,arg) + | _ -> DAst.get (map_glob_constr (subst_glob_vars l) gc) (* assume: id is not binding *) + ) gc + +let ldots_var = Id.of_string ".." + +let protect g e na = + let e',disjpat,na = g e na in + if disjpat <> None then user_err (Pp.str "Unsupported substitution of an arbitrary pattern."); + e',na + +let apply_cases_pattern_term ?loc (ids,disjpat) tm c = + let eqns = List.map (fun pat -> (CAst.make ?loc (ids,[pat],c))) disjpat in + DAst.make ?loc @@ GCases (Constr.LetPatternStyle, None, [tm,(Anonymous,None)], eqns) + +let apply_cases_pattern ?loc (ids_disjpat,id) c = + apply_cases_pattern_term ?loc ids_disjpat (DAst.make ?loc (GVar id)) c + +let glob_constr_of_notation_constr_with_binders ?loc g f e nc = + let lt x = DAst.make ?loc x in lt @@ match nc with + | NVar id -> GVar id + | NApp (a,args) -> GApp (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 [y, lt @@ GVar x] else []) in + let inner = lt @@ GApp (lt @@ GVar (ldots_var),[subst_glob_vars innerl it]) in + let outerl = (ldots_var,inner)::(if swap then [] else [y, lt @@ GVar x]) in + DAst.get (subst_glob_vars outerl it) + | NBinderList (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 [y, lt @@ GVar x] else []) in + let inner = lt @@ GApp (lt @@ GVar ldots_var,[subst_glob_vars innerl it]) in + let outerl = (ldots_var,inner)::(if swap then [] else [y, lt @@ GVar x]) in + DAst.get (subst_glob_vars outerl it) + | NLambda (na,ty,c) -> + let e',disjpat,na = g e na in GLambda (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) + | NProd (na,ty,c) -> + let e',disjpat,na = g e na in GProd (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) + | NLetIn (na,b,t,c) -> + let e',disjpat,na = g e na in + (match disjpat with + | None -> GLetIn (na,f e b,Option.map (f e) t,f e' c) + | Some (disjpat,_id) -> DAst.get (apply_cases_pattern_term ?loc disjpat (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' = protect g e' na in + e',na'::nal) nal (e',[]) in + e',Some (CAst.make ?loc (ind,nal')) in + let e',na' = protect g e' na in + (e',(f e tm,(na',t'))::tml')) tml (e,[]) in + let fold (idl,e) na = let (e,disjpat,na) = g e na in ((Name.cons na idl,e),disjpat,na) in + let eqnl' = List.map (fun (patl,rhs) -> + let ((idl,e),patl) = + List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in + let disjpatl = product_of_cases_patterns patl in + List.map (fun patl -> CAst.make (idl,patl,f e rhs)) disjpatl) eqnl in + GCases (sty,Option.map (f e') rtntypopt,tml',List.flatten eqnl') + | NLetTuple (nal,(na,po),b,c) -> + let e',nal = List.fold_left_map (protect g) e nal in + let e'',na = protect g e na in + GLetTuple (nal,(na,Option.map (f e'') po),f e b,f e' c) + | NIf (c,(na,po),b1,b2) -> + let e',na = protect g e na in + GIf (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_left_map (List.fold_left_map (fun e (na,oc,b) -> + let e,na = protect g e na in + (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in + let e',idl = Array.fold_left_map (to_id (protect g)) e idl in + GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) + | NCast (c,k) -> GCast (f e c,map_cast_type (f e) k) + | NSort x -> GSort x + | NHole (x, naming, arg) -> GHole (x, naming, arg) + | NRef x -> GRef (x,None) + | NInt i -> GInt i + +let glob_constr_of_notation_constr ?loc x = + let rec aux () x = + glob_constr_of_notation_constr_with_binders ?loc (fun () id -> ((),None,id)) aux () x + in aux () x + +(******************************************************************************) +(* Translating a glob_constr into a notation, interpreting recursive patterns *) + +type found_variables = { + vars : Id.t list; + recursive_term_vars : (Id.t * Id.t) list; + recursive_binders_vars : (Id.t * Id.t) list; + } + +let add_id r id = r := { !r with vars = id :: (!r).vars } +let add_name r = function Anonymous -> () | Name id -> add_id r id + +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + +let split_at_recursive_part c = + let sub = ref None in + let rec aux c = + let loc0 = c.CAst.loc in + match DAst.get c with + | GApp (f, c::l) when is_gvar ldots_var f -> (* *) + let loc = f.CAst.loc in + begin match !sub with + | None -> + let () = sub := Some c in + begin match l with + | [] -> DAst.make ?loc @@ GVar ldots_var + | _ :: _ -> DAst.make ?loc:loc0 @@ GApp (DAst.make ?loc @@ GVar ldots_var, l) + end + | Some _ -> + (* Not narrowed enough to find only one recursive part *) + raise Not_found + end + | _ -> 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 DAst.get outer_iterator with + | GVar v when Id.equal v ldots_var -> (* Not enough context *) raise Not_found + | _ -> outer_iterator, c + +let subtract_loc loc1 loc2 = + let l1 = fst (Option.cata Loc.unloc (0,0) loc1) in + let l2 = fst (Option.cata Loc.unloc (0,0) loc2) in + Some (Loc.make_loc (l1,l2-1)) + +let check_is_hole id t = match DAst.get t with GHole _ -> () | _ -> + user_err ?loc:(loc_of_glob_constr t) + (strbrk "In recursive notation with binders, " ++ Id.print id ++ + strbrk " is expected to come without type.") + +let check_pair_matching ?loc x y x' y' revert revert' = + if not (Id.equal x x' && Id.equal y y' && revert = revert') then + let x,y = if revert then y,x else x,y in + let x',y' = if revert' then y',x' else x',y' in + (* This is a case where one would like to highlight two locations! *) + user_err ?loc + (strbrk "Found " ++ Id.print x ++ strbrk " matching " ++ Id.print y ++ + strbrk " while " ++ Id.print x' ++ strbrk " matching " ++ Id.print y' ++ + strbrk " was first found.") + +let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' + +let mem_recursive_pair (x,y) l = List.mem_f (pair_equal Id.equal Id.equal) (x,y) l + +type recursive_pattern_kind = +| RecursiveTerms of bool (* in reverse order *) +| RecursiveBinders of bool (* in reverse order *) + +let compare_recursive_parts recvars found f f' (iterator,subc) = + let diff = ref None in + let terminator = ref None in + let rec aux c1 c2 = match DAst.get c1, DAst.get 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 c2; + true + | GApp (f,l1), GApp (term, l2) -> + begin match DAst.get f with + | GVar v 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 + | _ -> mk_glob_constr_eq aux c1 c2 + end + | GVar x, GVar y + when mem_recursive_pair (x,y) recvars || mem_recursive_pair (y,x) recvars -> + (* We found the position where it differs *) + let revert = mem_recursive_pair (y,x) recvars in + let x,y = if revert then y,x else x,y in + begin match !diff with + | None -> + let () = diff := Some (x, y, RecursiveTerms revert) in + true + | Some (x', y', RecursiveTerms revert') + | Some (x', y', RecursiveBinders revert') -> + check_pair_matching ?loc:c1.CAst.loc x y x' y' revert revert'; + true + 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) + when mem_recursive_pair (x,y) recvars || mem_recursive_pair (y,x) recvars -> + (* We found a binding position where it differs *) + check_is_hole x t_x; + check_is_hole y t_y; + let revert = mem_recursive_pair (y,x) recvars in + let x,y = if revert then y,x else x,y in + begin match !diff with + | None -> + let () = diff := Some (x, y, RecursiveBinders revert) in + aux c term + | Some (x', y', RecursiveBinders revert') -> + check_pair_matching ?loc:c1.CAst.loc x y x' y' revert revert'; + true + | Some (x', y', RecursiveTerms revert') -> + (* Recursive binders have precedence: they can be coerced to + terms but not reciprocally *) + check_pair_matching ?loc:c1.CAst.loc x y x' y' revert revert'; + let () = diff := Some (x, y, RecursiveBinders revert) in + true + end + | _ -> + mk_glob_constr_eq aux 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,RecursiveTerms revert) -> + (* By arbitrary convention, we use the second variable of the pair + as the place-holder for the iterator *) + let iterator = + f' (if revert then iterator else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in + (* found variables have been collected by compare_constr *) + found := { !found with vars = List.remove Id.equal y (!found).vars; + recursive_term_vars = List.add_set (pair_equal Id.equal Id.equal) (x,y) (!found).recursive_term_vars }; + NList (x,y,iterator,f (Option.get !terminator),revert) + | Some (x,y,RecursiveBinders revert) -> + let iterator = + f' (if revert then iterator else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in + (* found have been collected by compare_constr *) + found := { !found with vars = List.remove Id.equal y (!found).vars; + recursive_binders_vars = List.add_set (pair_equal Id.equal Id.equal) (x,y) (!found).recursive_binders_vars }; + NBinderList (x,y,iterator,f (Option.get !terminator),revert) + else + raise Not_found + +let notation_constr_and_vars_of_glob_constr recvars a = + let found = ref { vars = []; recursive_term_vars = []; recursive_binders_vars = [] } in + let has_ltac = ref false in + (* Turn a glob_constr into a notation_constr by first trying to find a recursive pattern *) + let rec aux c = + let keepfound = !found in + (* n^2 complexity but small and done only once per notation *) + try compare_recursive_parts recvars found aux aux' (split_at_recursive_part c) + with Not_found -> + found := keepfound; + match DAst.get c with + | GApp (t, [_]) -> + begin match DAst.get t with + | GVar f when Id.equal f ldots_var -> + (* Fall on the second part of the recursive pattern w/o having + found the first part *) + let loc = t.CAst.loc in + user_err ?loc + (str "Cannot find where the recursive pattern starts.") + | _ -> aux' c + end + | _c -> + aux' c + and aux' x = DAst.with_val (function + | GVar id -> if not (Id.equal id ldots_var) then 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,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t, aux c) + | GCases (sty,rtntypopt,tml,eqnl) -> + let f {CAst.v=(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 {CAst.v=(_,nl)} -> List.iter (add_name found) nl) x; + (aux tm,(na,Option.map (fun {CAst.v=(ind,nal)} -> (ind,nal)) x))) tml, + List.map f eqnl) + | GLetTuple (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 (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 + user_err Pp.(str "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,map_cast_type aux k) + | GSort s -> NSort s + | GInt i -> NInt i + | GHole (w,naming,arg) -> + if arg != None then has_ltac := true; + NHole (w, naming, arg) + | GRef (r,_) -> NRef r + | GEvar _ | GPatVar _ -> + user_err Pp.(str "Existential variables not allowed in notations.") + ) x + in + let t = aux a in + (* Side effect *) + t, !found, !has_ltac + +let check_variables_and_reversibility nenv + { vars = found; recursive_term_vars = foundrec; recursive_binders_vars = foundrecbinding } = + let injective = ref [] in + 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 + user_err (Id.print 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 + user_err Pp.(str + (Id.to_string x ^ + " should not be bound in a recursive pattern of the right-hand side.")) + else injective := x :: !injective + in + let check_pair s x y where = + if not (mem_recursive_pair (x,y) where) then + user_err (strbrk "in the right-hand side, " ++ Id.print x ++ + str " and " ++ Id.print y ++ strbrk " should appear in " ++ str s ++ + str " position as part of a recursive pattern.") in + let check_type x typ = + match typ with + | NtnInternTypeAny -> + begin + try check_pair "term" x (Id.Map.find x recvars) foundrec + with Not_found -> check_bound x + end + | NtnInternTypeOnlyBinder -> + begin + try check_pair "binding" x (Id.Map.find x recvars) foundrecbinding + with Not_found -> check_bound x + end in + Id.Map.iter check_type vars; + List.rev !injective + +let notation_constr_of_glob_constr nenv a = + let recvars = Id.Map.bindings nenv.ninterp_rec_vars in + let a, found, has_ltac = notation_constr_and_vars_of_glob_constr recvars a in + let injective = check_variables_and_reversibility nenv found in + let status = if has_ltac then HasLtac else match injective with + | [] -> APrioriReversible + | l -> NonInjective l in + a, status + +(**********************************************************************) +(* Substitution of kernel names, avoiding a list of bound identifiers *) + +let notation_constr_of_constr avoiding t = + let t = EConstr.of_constr t in + let env = Global.env () in + let evd = Evd.from_env env in + let t = Detyping.detype Detyping.Now false avoiding env evd t in + let nenv = { + ninterp_var_type = Id.Map.empty; + ninterp_rec_vars = Id.Map.empty; + } in + notation_constr_of_glob_constr nenv t + +let rec subst_pat subst pat = + match DAst.get pat with + | PatVar _ -> pat + | PatCstr (((kn,i),j),cpl,n) -> + let kn' = subst_mind subst kn + and cpl' = List.Smart.map (subst_pat subst) cpl in + if kn' == kn && cpl' == cpl then pat else + DAst.make ?loc:pat.CAst.loc @@ PatCstr (((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 (match t with + | None -> NRef ref' + | Some t -> + fst (notation_constr_of_constr bound t.Univ.univ_abstracted_value)) + + | NVar _ -> raw + + | NApp (r,rl) -> + let r' = subst_notation_constr subst bound r + and rl' = List.Smart.map (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,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 + NBinderList (id1,id2,r1',r2',b) + + | NLetIn (n,r1,t,r2) -> + let r1' = subst_notation_constr subst bound r1 in + let t' = Option.Smart.map (subst_notation_constr subst bound) t in + let r2' = subst_notation_constr subst bound r2 in + if r1' == r1 && t == t' && r2' == r2 then raw else + NLetIn (n,r1',t',r2') + + | NCases (sty,rtntypopt,rl,branches) -> + let rtntypopt' = Option.Smart.map (subst_notation_constr subst bound) rtntypopt + and rl' = List.Smart.map + (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.Smart.map + (fun (cpl,r as branch) -> + let cpl' = List.Smart.map (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.Smart.map (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.Smart.map (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.Smart.map (List.Smart.map (fun (na,oc,b as x) -> + let oc' = Option.Smart.map (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.Smart.map (subst_notation_constr subst bound) tl in + let bl' = Array.Smart.map (subst_notation_constr subst bound) bl in + if dll' == dll && tl' == tl && bl' == bl then raw else + NRec (fk,idl,dll',tl',bl') + + | NSort _ -> raw + | NInt _ -> 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.Smart.map (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' = 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.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty metas in + (metas,subst_notation_constr subst bound pat) + +(**********************************************************************) +(* Pattern-matching a [glob_constr] against a [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 tml rtn = + abstract_return_type_context (fun {CAst.v=(_,nal)} -> nal) + (fun na c -> DAst.make @@ + GLambda(na,Explicit,DAst.make @@ GHole(Evar_kinds.InternalHole,IntroAnonymous,None),c)) tml rtn + +let abstract_return_type_context_notation_constr tml rtn = + abstract_return_type_context snd + (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, IntroAnonymous, None),c)) tml rtn + +let is_term_meta id metas = + try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false + with Not_found -> false + +let is_onlybinding_strict_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeBinder (NtnParsedAsPattern true) -> true | _ -> false + with Not_found -> false + +let is_onlybinding_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeBinder _ -> true | _ -> false + with Not_found -> false + +let is_onlybinding_pattern_like_meta isvar id metas = + try match Id.List.assoc id metas with + | _,NtnTypeBinder (NtnBinderParsedAsConstr + (AsIdentOrPattern | AsStrictPattern)) -> true + | _,NtnTypeBinder (NtnParsedAsPattern strict) -> not (strict && isvar) + | _ -> false + with Not_found -> false + +let is_bindinglist_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeBinderList -> true | _ -> false + with Not_found -> false + +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 alpha_rename alpmetas v = + if alpmetas == [] then v + else try rename_glob_vars alpmetas v with UnsoundRenaming -> raise No_match + +let add_env (alp,alpmetas) (terms,termlists,binders,binderlists) var v = + (* Check that no capture of binding variables occur *) + (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..." + with an actual term "fun z => ... z ..." when "x" is not bound in the + notation, as in "Notation "'twice_upto' y" := (fun x => x + x + y)". Then + we keep (z,x) in alp, and we have to check that what the [v] which is bound + to [var] does not contain z *) + if not (Id.equal ldots_var var) && + List.exists (fun (id,_) -> occur_glob_constr id v) alp then raise No_match; + (* [alpmetas] is used when matching a pattern "fun x => ... x ... ?var ... x ..." + with an actual term "fun z => ... z ..." when "x" is bound in the + notation and the name "x" cannot be changed to "z", e.g. because + used at another occurrence, as in "Notation "'lam' y , P & Q" := + ((fun y => P),(fun y => Q))". Then, we keep (z,y) in alpmetas, and we + have to check that "fun z => ... z ..." denotes the same term as + "fun x => ... x ... ?var ... x" up to alpha-conversion when [var] + is instantiated by [v]; + Currently, we fail, but, eventually, [x] in [v] could be replaced by [x], + and, in match_, when finding "x" in subterm, failing because of a capture, + and, in match_, when finding "z" in subterm, replacing it with "x", + and, in an even further step, being even more robust, independent of the order, so + that e.g. the notation for ex2 works on "x y |- ex2 (fun x => y=x) (fun y => x=y)" + by giving, say, "exists2 x0, y=x0 & x=x0", but this would typically require the + glob_constr_eq in bind_term_env to be postponed in match_notation_constr, and the + choice of exact variable be done there; but again, this would be a non-trivial + refinement *) + let v = alpha_rename alpmetas v in + (* TODO: handle the case of multiple occs in different scopes *) + ((var,v)::terms,termlists,binders,binderlists) + +let add_termlist_env (alp,alpmetas) (terms,termlists,binders,binderlists) var vl = + if List.exists (fun (id,_) -> List.exists (occur_glob_constr id) vl) alp then raise No_match; + let vl = List.map (alpha_rename alpmetas) vl in + (terms,(var,vl)::termlists,binders,binderlists) + +let add_binding_env alp (terms,termlists,binders,binderlists) var v = + (* TODO: handle the case of multiple occs in different scopes *) + (terms,termlists,(var,v)::binders,binderlists) + +let add_bindinglist_env (terms,termlists,binders,binderlists) x bl = + (terms,termlists,binders,(x,bl)::binderlists) + +let rec map_cases_pattern_name_left f = DAst.map (function + | PatVar na -> PatVar (f na) + | PatCstr (c,l,na) -> PatCstr (c,List.map_left (map_cases_pattern_name_left f) l,f na) + ) + +let rec fold_cases_pattern_eq f x p p' = + let loc = p.CAst.loc in + match DAst.get p, DAst.get p' with + | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na + | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> + let x,l = fold_cases_pattern_list_eq f x l l' in + let x,na = f x na na' in + x, DAst.make ?loc @@ PatCstr (c,l,na) + | _ -> failwith "Not equal" + +and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with + | [], [] -> x, [] + | p::pl, p'::pl' -> + let x, p = fold_cases_pattern_eq f x p p' in + let x, pl = fold_cases_pattern_list_eq f x pl pl' in + x, p :: pl + | _ -> assert false + +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with +| PatVar na1, PatVar na2 -> Name.equal na1 na2 +| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> + eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Name.equal na1 na2 +| _ -> false + +let rec pat_binder_of_term t = DAst.map (function + | GVar id -> PatVar (Name id) + | GApp (t, l) -> + begin match DAst.get t with + | GRef (ConstructRef cstr,_) -> + let nparams = Inductiveops.inductive_nparams (Global.env()) (fst cstr) in + let _,l = List.chop nparams l in + PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) + | _ -> raise No_match + end + | _ -> raise No_match + ) t + +let unify_name_upto alp na na' = + match na, na' with + | Anonymous, na' -> alp, na' + | na, Anonymous -> alp, na + | Name id, Name id' -> + if Id.equal id id' then alp, na' + else (fst alp,(id,id')::snd alp), na' + +let unify_pat_upto alp p p' = + try fold_cases_pattern_eq unify_name_upto alp p p' with Failure _ -> raise No_match + +let unify_term alp v v' = + match DAst.get v, DAst.get v' with + | GHole _, _ -> v' + | _, GHole _ -> v + | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match + +let unify_opt_term alp v v' = + match v, v' with + | Some t, Some t' -> Some (unify_term alp t t') + | (Some _ as x), None | None, (Some _ as x) -> x + | None, None -> None + +let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match + +let unify_binder_upto alp b b' = + let loc, loc' = CAst.(b.loc, b'.loc) in + match DAst.get b, DAst.get b' with + | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> + let alp, na = unify_name_upto alp na na' in + alp, DAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') + | GLocalDef (na,bk,c,t), GLocalDef (na',bk',c',t') -> + let alp, na = unify_name_upto alp na na' in + alp, DAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') + | GLocalPattern ((disjpat,ids),id,bk,t), GLocalPattern ((disjpat',_),_,bk',t') when List.length disjpat = List.length disjpat' -> + let alp, p = List.fold_left2_map unify_pat_upto alp disjpat disjpat' in + alp, DAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') + | _ -> raise No_match + +let rec unify_terms alp vl vl' = + match vl, vl' with + | [], [] -> [] + | v :: vl, v' :: vl' -> unify_term alp v v' :: unify_terms alp vl vl' + | _ -> raise No_match + +let rec unify_binders_upto alp bl bl' = + match bl, bl' with + | [], [] -> alp, [] + | b :: bl, b' :: bl' -> + let alp,b = unify_binder_upto alp b b' in + let alp,bl = unify_binders_upto alp bl bl' in + alp, b :: bl + | _ -> raise No_match + +let unify_id alp id na' = + match na' with + | Anonymous -> Name (rename_var (snd alp) id) + | Name id' -> + if Id.equal (rename_var (snd alp) id) id' then na' else raise No_match + +let unify_pat alp p p' = + if cases_pattern_eq (map_cases_pattern_name_left (Name.map (rename_var (snd alp))) p) p' then p' + else raise No_match + +let unify_term_binder alp c = DAst.(map (fun b' -> + match DAst.get c, b' with + | GVar id, GLocalAssum (na', bk', t') -> + GLocalAssum (unify_id alp id na', bk', t') + | _, GLocalPattern (([p'],ids), id, bk', t') -> + let p = pat_binder_of_term c in + GLocalPattern (([unify_pat alp p p'],ids), id, bk', t') + | _ -> raise No_match)) + +let rec unify_terms_binders alp cl bl' = + match cl, bl' with + | [], [] -> [] + | c :: cl, b' :: bl' -> + begin match DAst.get b' with + | GLocalDef ( _, _, _, t) -> unify_terms_binders alp cl bl' + | _ -> unify_term_binder alp c b' :: unify_terms_binders alp cl bl' + end + | _ -> raise No_match + +let bind_term_env alp (terms,termlists,binders,binderlists as sigma) var v = + try + (* If already bound to a term, unify with the new term *) + let v' = Id.List.assoc var terms in + let v'' = unify_term alp v v' in + if v'' == v' then sigma else + let sigma = (Id.List.remove_assoc var terms,termlists,binders,binderlists) in + add_env alp sigma var v + with Not_found -> add_env alp sigma var v + +let bind_termlist_env alp (terms,termlists,binders,binderlists as sigma) var vl = + try + (* If already bound to a list of term, unify with the new terms *) + let vl' = Id.List.assoc var termlists in + let vl = unify_terms alp vl vl' in + let sigma = (terms,Id.List.remove_assoc var termlists,binders,binderlists) in + add_termlist_env alp sigma var vl + with Not_found -> add_termlist_env alp sigma var vl + +let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) var id = + try + (* If already bound to a term, unify the binder and the term *) + match DAst.get (Id.List.assoc var terms) with + | GVar id' -> + (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), + sigma + | t -> + (* The term is a non-variable pattern *) + raise No_match + with Not_found -> + (* The matching against a term allowing to find the instance has not been found yet *) + (* If it will be a different name, we shall unfortunately fail *) + (* TODO: look at the consequences for alp *) + alp, add_env alp sigma var (DAst.make @@ GVar id) + +let bind_binding_as_term_env alp (terms,termlists,binders,binderlists as sigma) var c = + let env = Global.env () in + let pat = try cases_pattern_of_glob_constr env Anonymous c with Not_found -> raise No_match in + try + (* If already bound to a binder, unify the term and the binder *) + let patl' = Id.List.assoc var binders in + let patl'' = List.map2 (unify_pat alp) [pat] patl' in + if patl' == patl'' then sigma + else + let sigma = (terms,termlists,Id.List.remove_assoc var binders,binderlists) in + add_binding_env alp sigma var patl'' + with Not_found -> add_binding_env alp sigma var [pat] + +let bind_binding_env alp (terms,termlists,binders,binderlists as sigma) var disjpat = + try + (* If already bound to a binder possibly *) + (* generating an alpha-renaming from unifying the new binder *) + let disjpat' = Id.List.assoc var binders in + let alp, disjpat = List.fold_left2_map unify_pat_upto alp disjpat disjpat' in + let sigma = (terms,termlists,Id.List.remove_assoc var binders,binderlists) in + alp, add_binding_env alp sigma var disjpat + with Not_found -> alp, add_binding_env alp sigma var disjpat + +let bind_bindinglist_env alp (terms,termlists,binders,binderlists as sigma) var bl = + let bl = List.rev bl in + try + (* If already bound to a list of binders possibly *) + (* generating an alpha-renaming from unifying the new binders *) + let bl' = Id.List.assoc var binderlists in + let alp, bl = unify_binders_upto alp bl bl' in + let sigma = (terms,termlists,binders,Id.List.remove_assoc var binderlists) in + alp, add_bindinglist_env sigma var bl + with Not_found -> + alp, add_bindinglist_env sigma var bl + +let bind_bindinglist_as_termlist_env alp (terms,termlists,binders,binderlists) var cl = + try + (* If already bound to a list of binders, unify the terms and binders *) + let bl' = Id.List.assoc var binderlists in + let bl = unify_terms_binders alp cl bl' in + let sigma = (terms,termlists,binders,Id.List.remove_assoc var binderlists) in + add_bindinglist_env sigma var bl + with Not_found -> + anomaly (str "There should be a binder list bindings this list of terms.") + +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 + | (na1,Name id2) when is_onlybinding_strict_meta id2 metas -> + raise No_match + | (na1,Name id2) when is_onlybinding_meta id2 metas -> + bind_binding_env alp sigma id2 [DAst.make (PatVar na1)] + | (Name id1,Name id2) when is_term_meta id2 metas -> + (* We let the non-binding occurrence define the rhs and hence reason up to *) + (* alpha-conversion for the given occurrence of the name (see #4592)) *) + bind_term_as_binding_env alp sigma id2 id1 + | (Anonymous,Name id2) when is_term_meta id2 metas -> + (* We let the non-binding occurrence define the rhs *) + alp, sigma + | (Name id1,Name id2) -> ((id1,id2)::fst alp, snd alp),sigma + | (Anonymous,Anonymous) -> alp,sigma + | _ -> raise No_match + +let rec match_cases_pattern_binders allow_catchall metas (alp,sigma as acc) pat1 pat2 = + match DAst.get pat1, DAst.get pat2 with + | PatVar _, PatVar (Name id2) when is_onlybinding_pattern_like_meta true id2 metas -> + bind_binding_env alp sigma id2 [pat1] + | _, PatVar (Name id2) when is_onlybinding_pattern_like_meta false id2 metas -> + bind_binding_env alp sigma id2 [pat1] + | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 + | _, PatVar Anonymous when allow_catchall -> acc + | 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 false metas) + (match_names metas acc na1 na2) patl1 patl2 + | _ -> raise No_match + +let remove_sigma x (terms,termlists,binders,binderlists) = + (Id.List.remove_assoc x terms,termlists,binders,binderlists) + +let remove_bindinglist_sigma x (terms,termlists,binders,binderlists) = + (terms,termlists,binders,Id.List.remove_assoc x binderlists) + +let add_ldots_var metas = (ldots_var,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeConstr))::metas + +let add_meta_bindinglist x metas = (x,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeBinderList))::metas + +(* This tells if letins in the middle of binders should be included in + the sequence of binders *) +let glue_inner_letin_with_decls = true + +(* This tells if trailing letins (with no further proper binders) + should be included in sequence of binders *) +let glue_trailing_letin_with_decls = false + +exception OnlyTrailingLetIns + +let match_binderlist match_fun alp metas sigma rest x y iter termin revert = + let rec aux trailing_letins sigma bl rest = + try + let metas = add_ldots_var (add_meta_bindinglist y metas) in + let (terms,_,_,binderlists as sigma) = match_fun alp metas sigma rest iter in + let rest = Id.List.assoc ldots_var terms in + let b = + match Id.List.assoc y binderlists with [b] -> b | _ ->assert false + in + let sigma = remove_bindinglist_sigma y (remove_sigma ldots_var sigma) in + (* In case y is bound not only to a binder but also to a term *) + let sigma = remove_sigma y sigma in + aux false sigma (b::bl) rest + with No_match -> + match DAst.get rest with + | GLetIn (na,c,t,rest') when glue_inner_letin_with_decls -> + let b = DAst.make ?loc:rest.CAst.loc @@ GLocalDef (na,Explicit (*?*), c,t) in + (* collect let-in *) + (try aux true sigma (b::bl) rest' + with OnlyTrailingLetIns + when not (trailing_letins && not glue_trailing_letin_with_decls) -> + (* renounce to take into account trailing let-ins *) + if not (List.is_empty bl) then bl, rest, sigma else raise No_match) + | _ -> + if trailing_letins && not glue_trailing_letin_with_decls then + (* Backtrack to when we tried to glue letins *) + raise OnlyTrailingLetIns; + if not (List.is_empty bl) then bl, rest, sigma else raise No_match in + let bl,rest,sigma = aux false sigma [] rest in + let bl = if revert then List.rev bl else bl in + let alp,sigma = bind_bindinglist_env alp sigma x bl in + match_fun alp metas sigma rest termin + +let add_meta_term x metas = (x,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeConstr))::metas (* Should reuse the scope of the partner of x! *) + +let match_termlist match_fun alp metas sigma rest x y iter termin revert = + let rec aux sigma acc rest = + try + let metas = add_ldots_var (add_meta_term y metas) in + let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in + let rest = Id.List.assoc ldots_var terms in + let t = Id.List.assoc y terms in + let sigma = remove_sigma y (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,(terms,termlists,binders,binderlists as sigma) = aux sigma [] rest in + let l = if revert then l else List.rev l in + if is_bindinglist_meta x metas then + (* This is a recursive pattern for both bindings and terms; it is *) + (* registered for binders *) + bind_bindinglist_as_termlist_env alp sigma x l + else + bind_termlist_env alp sigma x l + +let match_cast match_fun sigma c1 c2 = + match c1, c2 with + | CastConv t1, CastConv t2 + | CastVM t1, CastVM t2 + | CastNative t1, CastNative t2 -> + match_fun sigma t1 t2 + | CastCoerce, CastCoerce -> + sigma + | CastConv _, _ + | CastVM _, _ + | CastNative _, _ + | CastCoerce, _ -> raise No_match + +let does_not_come_from_already_eta_expanded_var glob = + (* 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). *) + match DAst.get glob with GVar _ -> false | _ -> true + +let rec match_ inner u alp metas sigma a1 a2 = + let open CAst in + let loc = a1.loc in + match DAst.get a1, a2 with + (* Matching notation variable *) + | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 a1 + | GVar _, NVar id2 when is_onlybinding_pattern_like_meta true id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | r1, NVar id2 when is_onlybinding_pattern_like_meta false id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | GVar _, NVar id2 when is_onlybinding_strict_meta id2 metas -> raise No_match + | GVar _, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_env alp sigma id2 a1 + + (* Matching recursive notations for terms *) + | r1, NList (x,y,iter,termin,revert) -> + match_termlist (match_hd u alp) alp metas sigma a1 x y iter termin revert + + (* Matching recursive notations for binders: general case *) + | _r, NBinderList (x,y,iter,termin,revert) -> + match_binderlist (match_hd u) alp metas sigma a1 x y iter termin revert + + (* Matching compositionally *) + | GVar id1, NVar id2 when alpha_var id1 id2 (fst alp) -> sigma + | GRef (r1,_), NRef r2 when (GlobRef.equal r1 r2) -> sigma + | GApp (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 DAst.make ?loc @@ GApp (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_hd u alp metas sigma f1 f2) l1 l2 + | GLambda (na1,bk1,t1,b1), NLambda (na2,t2,b2) -> + match_extended_binders false u alp metas na1 na2 bk1 t1 (match_in u alp metas sigma t1 t2) b1 b2 + | GProd (na1,bk1,t1,b1), NProd (na2,t2,b2) -> + match_extended_binders true u alp metas na1 na2 bk1 t1 (match_in u alp metas sigma t1 t2) b1 b2 + | GLetIn (na1,b1,_,c1), NLetIn (na2,b2,None,c2) + | GLetIn (na1,b1,None,c1), NLetIn (na2,b2,_,c2) -> + match_binders u alp metas na1 na2 (match_in u alp metas sigma b1 b2) c1 c2 + | GLetIn (na1,b1,Some t1,c1), NLetIn (na2,b2,Some t2,c2) -> + match_binders u alp metas na1 na2 + (match_in u alp metas (match_in u alp metas sigma b1 b2) t1 t2) c1 c2 + | GCases (sty1,rtno1,tml1,eqnl1), NCases (sty2,rtno2,tml2,eqnl2) + when sty1 == sty2 && Int.equal (List.length tml1) (List.length tml2) -> + 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 + (* Try two different strategies for matching clauses *) + (try + List.fold_left2_set No_match (match_equations u alp metas) sigma eqnl1 eqnl2 + with + No_match -> + List.fold_left2_set No_match (match_disjunctive_equations u alp metas) sigma + (Detyping.factorize_eqns eqnl1) + (List.map (fun (patl,rhs) -> ([patl],rhs)) 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(t1, c1), NCast(t2, c2) -> + match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 + | GSort (GType _), NSort (GType _) when not u -> sigma + | GSort s1, NSort s2 when glob_sort_eq s1 s2 -> sigma + | GInt i1, NInt i2 when Uint63.equal i1 i2 -> 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 as na,(NHole _ | NVar _ as t2),b2) when inner -> + let avoid = + Id.Set.union (free_glob_vars a1) (* as in Namegen: *) (glob_visible_short_qualid a1) in + let id' = Namegen.next_ident_away id avoid in + let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),IntroAnonymous,None) in + let sigma = match t2 with + | NHole _ -> sigma + | NVar id2 -> bind_term_env alp sigma id2 t1 + | _ -> assert false in + let (alp,sigma) = + if is_bindinglist_meta id metas then + bind_bindinglist_env alp sigma id [DAst.make @@ GLocalAssum (Name id',Explicit,t1)] + else + match_names metas (alp,sigma) (Name id') na in + match_in u alp metas sigma (mkGApp a1 (DAst.make @@ GVar id')) b2 + + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ + | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ + | GCast _ | GInt _ ), _ -> 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 = + (* Match binders which cannot be substituted by a pattern *) + let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in + match_in u alp metas sigma b1 b2 + +and match_extended_binders ?loc isprod u alp metas na1 na2 bk t sigma b1 b2 = + (* Match binders which can be substituted by a pattern *) + let store, get = set_temporary_memory () in + match na1, DAst.get b1, na2 with + (* Matching individual binders as part of a recursive pattern *) + | Name p, GCases (Constr.LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id + when is_gvar p e && is_bindinglist_meta id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> + (match get () with + | [{CAst.v=(ids,disj_of_patl,b1)}] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr p b1 then List.map (set_pat_alias p) disjpat else disjpat in + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((disjpat,ids),p,bk,t)] in + match_in u alp metas sigma b1 b2 + | _ -> assert false) + | Name p, GCases (LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id + when is_gvar p e && is_onlybinding_pattern_like_meta false id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> + (match get () with + | [{CAst.v=(ids,disj_of_patl,b1)}] -> + let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in + let disjpat = if occur_glob_constr p b1 then List.map (set_pat_alias p) disjpat else disjpat in + let alp,sigma = bind_binding_env alp sigma id disjpat in + match_in u alp metas sigma b1 b2 + | _ -> assert false) + | _, _, Name id when is_bindinglist_meta id metas && (not isprod || na1 != Anonymous)-> + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na1,bk,t)] in + match_in u alp metas 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 {CAst.v=(ids,patl1,rhs1)} (patl2,rhs2) rest1 rest2 = + (* patl1 and patl2 have the same length because they respectively + correspond to some tml1 and tml2 that have the same length *) + let allow_catchall = (rest2 = [] && ids = []) in + let (alp,sigma) = + List.fold_left2 (match_cases_pattern_binders allow_catchall metas) + (alp,sigma) patl1 patl2 in + match_in u alp metas sigma rhs1 rhs2 + +and match_disjunctive_equations u alp metas sigma {CAst.v=(ids,disjpatl1,rhs1)} (disjpatl2,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_set No_match + (fun alp_sigma patl1 patl2 _ _ -> + List.fold_left2 (match_cases_pattern_binders false metas) alp_sigma patl1 patl2) + (alp,sigma) disjpatl1 disjpatl2 in + match_in u alp metas sigma rhs1 rhs2 + +let match_notation_constr u c (metas,pat) = + let terms,termlists,binders,binderlists = + match_ false u ([],[]) metas ([],[],[],[]) c pat in + (* Turning substitution based on binding/constr distinction into a + substitution based on entry productions *) + List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders',binderlists') -> + match typ with + | NtnTypeConstr -> + let term = try Id.List.assoc x terms with Not_found -> raise No_match in + ((term, scl)::terms',termlists',binders',binderlists') + | NtnTypeBinder (NtnBinderParsedAsConstr _) -> + (match Id.List.assoc x binders with + | [pat] -> + let v = glob_constr_of_cases_pattern (Global.env()) pat in + ((v,scl)::terms',termlists',binders',binderlists') + | _ -> raise No_match) + | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _) -> + (terms',termlists',(Id.List.assoc x binders,scl)::binders',binderlists') + | NtnTypeConstrList -> + (terms',(Id.List.assoc x termlists,scl)::termlists',binders',binderlists') + | NtnTypeBinderList -> + let bl = try Id.List.assoc x binderlists with Not_found -> raise No_match in + (terms',termlists',binders',(bl, scl)::binderlists')) + metas ([],[],[],[]) + +(* Matching cases pattern *) + +let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v = + try + let vvar = Id.List.assoc var terms in + if cases_pattern_eq v vvar then sigma else raise No_match + with Not_found -> + (* TODO: handle the case of multiple occs in different scopes *) + (var,v)::terms,x,termlists,y + +let match_cases_pattern_list match_fun metas sigma rest x y iter termin revert = + let rec aux sigma acc rest = + try + let metas = add_ldots_var (add_meta_term y metas) in + let (terms,_,_,_ as sigma) = match_fun metas sigma rest iter in + let rest = Id.List.assoc ldots_var terms in + let t = Id.List.assoc y terms in + let sigma = remove_sigma y (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,(terms,termlists,binders,binderlists as sigma) = aux sigma [] rest in + (terms,(x,if revert then l else List.rev l)::termlists,binders,binderlists) + +let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = + match DAst.get a1, a2 with + | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) + | PatVar Anonymous, NHole _ -> sigma,(0,[]) + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (ConstructRef r2) when eq_constructor r1 r2 -> + let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in + sigma,(0,l) + | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (ConstructRef r2),l2) + when eq_constructor r1 r2 -> + let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match 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,y,iter,termin,revert) -> + (match_cases_pattern_list (match_cases_pattern_no_more_args) + metas (terms,termlists,(),()) a1 x y iter termin revert),(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') + | NtnTypeBinder _ -> assert false + | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists') + | NtnTypeBinderList -> assert false) + metas ([],[]) + +let match_notation_constr_cases_pattern c (metas,pat) = + let (terms,termlists,(),()),more_args = match_cases_pattern metas ([],[],(),()) c pat in + reorder_canonically_substitution terms termlists metas, more_args + +let match_notation_constr_ind_pattern ind args (metas,pat) = + let (terms,termlists,(),()),more_args = match_ind_pattern metas ([],[],(),()) 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 0000000000..58fa221b16 --- /dev/null +++ b/interp/notation_ops.mli @@ -0,0 +1,71 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Notation_term +open Glob_term + +(** {5 Utilities about [notation_constr]} *) + +val eq_notation_constr : Id.t list * Id.t list -> notation_constr -> notation_constr -> bool + +(** Substitution of kernel names in interpretation data *) + +val subst_interpretation : + Mod_subst.substitution -> interpretation -> interpretation + +(** Name of the special identifier used to encode recursive notations *) + +val ldots_var : Id.t + +(** {5 Translation back and forth between [glob_constr] and [notation_constr]} *) + +(** Translate a [glob_constr] into a notation given the list of variables + bound by the notation; also interpret recursive patterns *) + +val notation_constr_of_glob_constr : notation_interp_env -> + glob_constr -> notation_constr * reversibility_status + +(** Re-interpret a notation as a [glob_constr], taking care of binders *) + +val apply_cases_pattern : ?loc:Loc.t -> + (Id.t list * cases_pattern_disjunction) * Id.t -> glob_constr -> glob_constr + +val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> + ('a -> Name.t -> 'a * ((Id.t list * cases_pattern_disjunction) * Id.t) option * Name.t) -> + ('a -> notation_constr -> glob_constr) -> + 'a -> notation_constr -> glob_constr + +val glob_constr_of_notation_constr : ?loc:Loc.t -> notation_constr -> glob_constr + +(** {5 Matching a notation pattern against a [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 -> 'a glob_constr_g -> interpretation -> + ('a glob_constr_g * extended_subscopes) list * ('a glob_constr_g list * extended_subscopes) list * + ('a cases_pattern_disjunction_g * extended_subscopes) list * + ('a extended_glob_local_binder_g list * extended_subscopes) list + +val match_notation_constr_cases_pattern : + 'a cases_pattern_g -> interpretation -> + (('a cases_pattern_g * extended_subscopes) list * ('a cases_pattern_g list * extended_subscopes) list) * + (int * 'a cases_pattern_g list) + +val match_notation_constr_ind_pattern : + inductive -> 'a cases_pattern_g list -> interpretation -> + (('a cases_pattern_g * extended_subscopes) list * ('a cases_pattern_g list * extended_subscopes) list) * + (int * 'a cases_pattern_g list) + +(** {5 Matching a notation pattern against a [glob_constr]} *) + diff --git a/interp/notation_term.ml b/interp/notation_term.ml new file mode 100644 index 0000000000..5024f5c26f --- /dev/null +++ b/interp/notation_term.ml @@ -0,0 +1,99 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Glob_term + +(** [notation_constr] *) + +(** [notation_constr] is the subtype of [glob_constr] allowed in syntactic + extensions (i.e. notations). + No location since intended to be substituted at any place of a text. + Complex expressions such as fixpoints and cofixpoints are excluded, + as well as non global expressions such as existential variables. *) + +type notation_constr = + (* Part common to [glob_constr] and [cases_pattern] *) + | NRef of GlobRef.t + | NVar of Id.t + | NApp of notation_constr * notation_constr list + | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option + | NList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool + (* Part only in [glob_constr] *) + | NLambda of Name.t * notation_constr * notation_constr + | NProd of Name.t * notation_constr * notation_constr + | NBinderList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool + | NLetIn of Name.t * notation_constr * notation_constr option * notation_constr + | NCases of Constr.case_style * notation_constr option * + (notation_constr * (Name.t * (inductive * Name.t list) option)) list * + (cases_pattern list * notation_constr) list + | NLetTuple of Name.t list * (Name.t * notation_constr option) * + notation_constr * notation_constr + | NIf of notation_constr * (Name.t * notation_constr option) * + notation_constr * notation_constr + | NRec of glob_fix_kind * Id.t array * + (Name.t * notation_constr option * notation_constr) list array * + notation_constr array * notation_constr array + | NSort of glob_sort + | NCast of notation_constr * notation_constr cast_type + | NInt of Uint63.t + +(** Note concerning NList: first constr is iterator, second is terminator; + first id is where each argument of the list has to be substituted + in iterator and snd id is alternative name just for printing; + boolean is associativity *) + +(** Types concerning notations *) + +type scope_name = string + +type tmp_scope_name = scope_name + +type subscopes = tmp_scope_name option * scope_name list + +type extended_subscopes = Constrexpr.notation_entry_level * subscopes + +(** Type of the meta-variables of an notation_constr: in a recursive pattern x..y, + x carries the sequence of objects bound to the list x..y *) + +type constr_as_binder_kind = + | AsIdent + | AsIdentOrPattern + | AsStrictPattern + +type notation_binder_source = + (* This accepts only pattern *) + (* NtnParsedAsPattern true means only strict pattern (no single variable) at printing *) + | NtnParsedAsPattern of bool + (* This accepts only ident *) + | NtnParsedAsIdent + (* This accepts ident, or pattern, or both *) + | NtnBinderParsedAsConstr of constr_as_binder_kind + +type notation_var_instance_type = + | NtnTypeConstr | NtnTypeBinder of notation_binder_source | NtnTypeConstrList | NtnTypeBinderList + +(** Type of variables when interpreting a constr_expr as a notation_constr: + in a recursive pattern x..y, both x and y carry the individual type + of each element of the list x..y *) +type notation_var_internalization_type = + | NtnInternTypeAny | NtnInternTypeOnlyBinder + +(** This characterizes to what a notation is interpreted to *) +type interpretation = + (Id.t * (extended_subscopes * notation_var_instance_type)) list * + notation_constr + +type reversibility_status = APrioriReversible | HasLtac | NonInjective of Id.t list + +type notation_interp_env = { + ninterp_var_type : notation_var_internalization_type Id.Map.t; + ninterp_rec_vars : Id.t Id.Map.t; +} diff --git a/interp/numTok.ml b/interp/numTok.ml new file mode 100644 index 0000000000..8f2004b889 --- /dev/null +++ b/interp/numTok.ml @@ -0,0 +1,52 @@ +type t = { + int : string; + frac : string; + exp : string +} + +let equal n1 n2 = + String.(equal n1.int n2.int && equal n1.frac n2.frac && equal n1.exp n2.exp) + +let int s = { int = s; frac = ""; exp = "" } + +let to_string n = n.int ^ (if n.frac = "" then "" else "." ^ n.frac) ^ n.exp + +let parse = + let buff = ref (Bytes.create 80) in + let store len x = + let open Bytes in + if len >= length !buff then + buff := cat !buff (create (length !buff)); + set !buff len x; + succ len in + let get_buff len = Bytes.sub_string !buff 0 len in + (* reads [0-9_]* *) + let rec number len s = match Stream.peek s with + | Some (('0'..'9' | '_') as c) -> Stream.junk s; number (store len c) s + | _ -> len in + fun s -> + let i = get_buff (number 0 s) in + let f = + match Stream.npeek 2 s with + | '.' :: (('0'..'9' | '_') as c) :: _ -> + Stream.junk s; Stream.junk s; get_buff (number (store 0 c) s) + | _ -> "" in + let e = + match (Stream.npeek 2 s) with + | (('e'|'E') as e) :: ('0'..'9' as c) :: _ -> + Stream.junk s; Stream.junk s; get_buff (number (store (store 0 e) c) s) + | (('e'|'E') as e) :: (('+'|'-') as sign) :: _ -> + begin match Stream.npeek 3 s with + | _ :: _ :: ('0'..'9' as c) :: _ -> + Stream.junk s; Stream.junk s; Stream.junk s; + get_buff (number (store (store (store 0 e) sign) c) s) + | _ -> "" + end + | _ -> "" in + { int = i; frac = f; exp = e } + +let of_string s = + if s = "" || s.[0] < '0' || s.[0] > '9' then None else + let strm = Stream.of_string (s ^ " ") in + let n = parse strm in + if Stream.count strm >= String.length s then Some n else None diff --git a/interp/numTok.mli b/interp/numTok.mli new file mode 100644 index 0000000000..0b6a877cbd --- /dev/null +++ b/interp/numTok.mli @@ -0,0 +1,18 @@ +type t = { + int : string; (** \[0-9\]\[0-9_\]* *) + frac : string; (** empty or \[0-9_\]+ *) + exp : string (** empty or \[eE\]\[+-\]?\[0-9\]\[0-9_\]* *) +} + +val equal : t -> t -> bool + +(** [int s] amounts to [\{ int = s; frac = ""; exp = "" \}] *) +val int : string -> t + +val to_string : t -> string + +val of_string : string -> t option + +(** Precondition: the first char on the stream is a digit (\[0-9\]). + Precondition: at least two extra chars after the numeral to parse. *) +val parse : char Stream.t -> t diff --git a/interp/reserve.ml b/interp/reserve.ml new file mode 100644 index 0000000000..edbdf1dbba --- /dev/null +++ b/interp/reserve.ml @@ -0,0 +1,130 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Reserved names *) + +open CErrors +open Util +open Pp +open Names +open Nameops +open Libobject +open Lib +open Notation_term +open Notation_ops +open Globnames + +type key = + | RefKey of GlobRef.t + | Oth + +(** TODO: share code from Notation *) + +let key_compare k1 k2 = match k1, k2 with +| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.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 (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 : Id.t * notation_constr -> obj = + declare_object {(default_object "RESERVED-TYPE") with + cache_function = cache_reserved_type } + +let declare_reserved_type_binding {CAst.loc;v=id} t = + if not (Id.equal id (root_of_id id)) then + user_err ?loc ~hdr:"declare_reserved_type" + ((Id.print id ++ str + " is not reservable: it must have no trailing digits, quote, or _")); + begin try + let _ = Id.Map.find id !reserve_table in + user_err ?loc ~hdr:"declare_reserved_type" + ((Id.print id++str" is already bound to a type")) + with Not_found -> () end; + add_anonymous_leaf (in_reserved (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 = Id.Map.find (root_of_id id) !reserve_table + +let constr_key c = + try RefKey (canonical_gr (global_of_constr (fst (Constr.decompose_app c)))) + with Not_found -> Oth + +let revert_reserved_type t = + try + let t = EConstr.Unsafe.to_constr t in + let reserved = KeyMap.find (constr_key t) !reserve_revtable in + let t = EConstr.of_constr t in + let env = Global.env () in + let evd = Evd.from_env env in + let t = Detyping.detype Detyping.Now false Id.Set.empty env evd 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 diff --git a/interp/reserve.mli b/interp/reserve.mli new file mode 100644 index 0000000000..a10858e71f --- /dev/null +++ b/interp/reserve.mli @@ -0,0 +1,15 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Notation_term + +val declare_reserved_type : lident list -> notation_constr -> unit +val find_reserved_type : Id.t -> notation_constr diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml new file mode 100644 index 0000000000..91491bdf8d --- /dev/null +++ b/interp/smartlocate.ml @@ -0,0 +1,76 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Created by Hugo Herbelin from code formerly dispatched in + syntax_def.ml or tacinterp.ml, Sep 2009 *) + +(* This file provides high-level name globalization functions *) + +(* *) +open Pp +open CErrors +open Libnames +open Globnames +open Syntax_def +open Notation_term + +let global_of_extended_global_head = function + | TrueGlobal ref -> 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 + | [],NRef ref -> ref + | [],NApp (NRef ref,[]) -> ref + | _ -> raise Not_found + +let locate_global_with_alias ?(head=false) qid = + let ref = Nametab.locate_extended qid in + try + if head then global_of_extended_global_head ref + else global_of_extended_global ref + with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ + str " is bound to a notation that does not denote a reference.") + +let global_inductive_with_alias qid = + try match locate_global_with_alias qid with + | IndRef ind -> ind + | ref -> + user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" + (pr_qualid qid ++ spc () ++ str "is not an inductive type.") + with Not_found -> Nametab.error_global_not_found qid + +let global_with_alias ?head qid = + try locate_global_with_alias ?head qid + with Not_found -> Nametab.error_global_not_found qid + +let smart_global ?head = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function + | AN r -> + global_with_alias ?head r + | ByNotation (ntn,sc) -> + Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc) + +let smart_global_inductive = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function + | AN r -> + global_inductive_with_alias r + | ByNotation (ntn,sc) -> + destIndRef + (Notation.interp_notation_as_global_reference ?loc isIndRef ntn sc)) diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli new file mode 100644 index 0000000000..e41ef78913 --- /dev/null +++ b/interp/smartlocate.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Libnames +open Globnames + +(** [locate_global_with_alias] locates global reference possibly following + a notation if this notation has a role of aliasing; raise [Not_found] + if not bound in the global env; raise a [UserError] if bound to a + syntactic def that does not denote a reference *) + +val locate_global_with_alias : ?head:bool -> qualid -> GlobRef.t + +(** Extract a global_reference from a reference that can be an "alias" *) +val global_of_extended_global : extended_global_reference -> GlobRef.t + +(** 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 -> qualid -> GlobRef.t + +(** The same for inductive types *) +val global_inductive_with_alias : qualid -> inductive + +(** Locate a reference taking into account notations and "aliases" *) +val smart_global : ?head:bool -> qualid Constrexpr.or_by_notation -> GlobRef.t + +(** The same for inductive types *) +val smart_global_inductive : qualid Constrexpr.or_by_notation -> inductive diff --git a/interp/stdarg.ml b/interp/stdarg.ml new file mode 100644 index 0000000000..bf3a8fe215 --- /dev/null +++ b/interp/stdarg.ml @@ -0,0 +1,63 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Genarg +open Geninterp + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = register_val0 wit dyn in + wit + +let wit_unit : unit uniform_genarg_type = + make0 "unit" + +let wit_bool : bool uniform_genarg_type = + make0 "bool" + +let wit_int : int uniform_genarg_type = + make0 "int" + +let wit_string : string uniform_genarg_type = + make0 "string" + +let wit_pre_ident : string uniform_genarg_type = + make0 "preident" + +let wit_int_or_var = + make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" + +let wit_ident = + make0 "ident" + +let wit_var = + make0 ~dyn:(val_tag (topwit wit_ident)) "var" + +let wit_ref = make0 "ref" + +let wit_sort_family = make0 "sort_family" + +let wit_constr = + make0 "constr" + +let wit_uconstr = make0 "uconstr" + +let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" + +let wit_clause_dft_concl = + make0 "clause_dft_concl" + +(** Aliases for compatibility *) + +let wit_integer = wit_int +let wit_preident = wit_pre_ident +let wit_reference = wit_ref +let wit_global = wit_ref +let wit_clause = wit_clause_dft_concl diff --git a/interp/stdarg.mli b/interp/stdarg.mli new file mode 100644 index 0000000000..c974a4403c --- /dev/null +++ b/interp/stdarg.mli @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Basic generic arguments. *) + +open Loc +open Names +open EConstr +open Libnames +open Constrexpr +open Genarg +open Genintern +open Locus + +val wit_unit : unit uniform_genarg_type + +val wit_bool : bool uniform_genarg_type + +val wit_int : int uniform_genarg_type + +val wit_string : string uniform_genarg_type + +val wit_pre_ident : string uniform_genarg_type + +(** {5 Additional generic arguments} *) + +val wit_int_or_var : (int or_var, int or_var, int) genarg_type + +val wit_ident : Id.t uniform_genarg_type + +val wit_var : (lident, lident, Id.t) genarg_type + +val wit_ref : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type + +val wit_sort_family : (Sorts.family, unit, unit) genarg_type + +val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_uconstr : (constr_expr , glob_constr_and_expr, Ltac_pretype.closed_glob_constr) genarg_type + +val wit_open_constr : + (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_clause_dft_concl : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type + +(** Aliases for compatibility *) + +val wit_integer : int uniform_genarg_type +val wit_preident : string uniform_genarg_type +val wit_reference : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type +val wit_global : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type +val wit_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml new file mode 100644 index 0000000000..49273c4146 --- /dev/null +++ b/interp/syntax_def.ml @@ -0,0 +1,114 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Pp +open CErrors +open Names +open Libnames +open Libobject +open Lib +open Notation_term + +(* Syntactic definitions. *) + +type version = Flags.compat_version option + +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 + +let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = + if Nametab.exists_cci sp then + user_err ~hdr:"cache_syntax_constant" + (Id.print (basename sp) ++ str " already exists"); + add_syntax_constant kn pat onlyparse; + Nametab.push_syndef (Nametab.Until i) sp kn + +let is_alias_of_already_visible_name sp = function + | _,NRef ref -> + let (dir,id) = repr_qualid (Nametab.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 (Int.equal i 1 && is_alias_of_already_visible_name sp pat) then begin + Nametab.push_syndef (Nametab.Exactly i) sp kn; + 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 = + load_syntax_constant 1 d; + open_syntax_constant 1 d + +let subst_syntax_constant (subst,(local,pat,onlyparse)) = + (local,Notation_ops.subst_interpretation subst pat,onlyparse) + +let classify_syntax_constant (local,_,_ as o) = + if local then Dispose else Substitute o + +let in_syntax_constant + : bool * interpretation * Flags.compat_version option -> obj = + declare_object {(default_object "SYNTAXCONSTANT") with + cache_function = cache_syntax_constant; + load_function = load_syntax_constant; + open_function = open_syntax_constant; + subst_function = subst_syntax_constant; + classify_function = classify_syntax_constant } + +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 *) +let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,((Constrexpr.InConstrEntrySomeLevel,sc),NtnTypeConstr))) ids,ac) +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_syndef kn = pr_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) + +let pr_compat_warning (kn, def, v) = + let pp_def = match def with + | [], NRef r -> spc () ++ str "is" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r + | _ -> strbrk " is a compatibility notation" + in + pr_syndef kn ++ pp_def + +let warn_compatibility_notation = + CWarnings.(create ~name:"compatibility-notation" + ~category:"deprecated" ~default:Enabled pr_compat_warning) + +let verbose_compat ?loc kn def = function + | Some v when Flags.version_strictly_greater v -> + warn_compatibility_notation ?loc (kn, def, v) + | _ -> () + +let search_syntactic_definition ?loc kn = + let pat,v = KNmap.find kn !syntax_table in + let def = out_pat pat in + verbose_compat ?loc kn def v; + def + +let search_filtered_syntactic_definition ?loc filter kn = + let pat,v = KNmap.find kn !syntax_table in + let def = out_pat pat in + let res = filter def in + (match res with Some _ -> verbose_compat ?loc kn def v | None -> ()); + res diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli new file mode 100644 index 0000000000..77873f8f67 --- /dev/null +++ b/interp/syntax_def.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Notation_term + +(** Syntactic definitions. *) + +type syndef_interpretation = (Id.t * subscopes) list * notation_constr + +val declare_syntactic_definition : bool -> Id.t -> + Flags.compat_version option -> syndef_interpretation -> unit + +val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation + +val search_filtered_syntactic_definition : ?loc:Loc.t -> + (syndef_interpretation -> 'a option) -> KerName.t -> 'a option |