diff options
| author |  Stephane Glondu <steph@glondu.net> | 2010-07-21 09:46:51 +0200 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2010-07-21 09:46:51 +0200 |
| commit | 5b7eafd0f00a16d78f99a27f5c7d5a0de77dc7e6 (patch) | |
| tree | 631ad791a7685edafeb1fb2e8faeedc8379318ae /toplevel | |
| parent | da178a880e3ace820b41d38b191d3785b82991f5 (diff) | |
Imported Upstream snapshot 8.3~beta0+13298
Diffstat (limited to 'toplevel')
56 files changed, 4291 insertions, 3103 deletions
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 82709db4..0e66c43c 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -6,7 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auto_ind_decl.ml 11671 2008-12-12 12:43:03Z herbelin $ i*) +(*i $Id$ i*) + +(* This file is about the automatic generation of schemes about + decidable equality, created by Vincent Siles, Oct 2007 *) open Tacmach open Util @@ -28,9 +31,10 @@ open Tactics open Tacticals open Ind_tables -(* boolean equality *) +(**********************************************************************) +(* Generic synthesis of boolean equality *) -let quick_chop n l = +let quick_chop n l = let rec kick_last = function | t::[] -> [] | t::q -> t::(kick_last q) @@ -39,21 +43,21 @@ and aux = function | (0,l') -> l' | (n,h::t) -> aux (n-1,t) | _ -> failwith "quick_chop" - in + in if n > (List.length l) then failwith "quick_chop args" else kick_last (aux (n,l) ) -let rec deconstruct_type t = +let rec deconstruct_type t = let l,r = decompose_prod t in (List.map (fun (_,b) -> b) (List.rev l))@[r] -let subst_in_constr (_,subst,(ind,const)) = - let ind' = (subst_kn subst (fst ind)),(snd ind) - and const' = subst_mps subst const in - ind',const' - -exception EqNotFound of string +exception EqNotFound of inductive * inductive exception EqUnknown of string +exception UndefinedCst of string +exception InductiveWithProduct +exception InductiveWithSort +exception ParameterWithoutEquality of constant +exception NonSingletonProp of inductive let dl = dummy_loc @@ -62,70 +66,77 @@ let bb = constr_of_global Coqlib.glob_bool let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop -let andb_true_intro = fun _ -> - (Coqlib.build_bool_type()).Coqlib.andb_true_intro +let andb_true_intro = fun _ -> + (Coqlib.build_bool_type()).Coqlib.andb_true_intro -let tt = constr_of_global Coqlib.glob_true +let tt = constr_of_global Coqlib.glob_true let ff = constr_of_global Coqlib.glob_false -let eq = constr_of_global Coqlib.glob_eq +let eq = constr_of_global Coqlib.glob_eq -let sumbool = Coqlib.build_coq_sumbool +let sumbool = Coqlib.build_coq_sumbool -let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb +let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb (* reconstruct the inductive with the correct deBruijn indexes *) -let mkFullInd ind n = +let mkFullInd ind n = let mib = Global.lookup_mind (fst ind) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in (* params context divided *) - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - if nparrec > 0 + if nparrec > 0 then mkApp (mkInd ind, Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) else mkInd ind -let make_eq_scheme sp = +let check_bool_is_defined () = + try let _ = Global.type_of_global Coqlib.glob_bool in () + with _ -> raise (UndefinedCst "bool") + +let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") + +let build_beq_scheme kn = + check_bool_is_defined (); (* fetching global env *) let env = Global.env() in (* fetching the mutual inductive body *) - let mib = Global.lookup_mind sp in + let mib = Global.lookup_mind kn in (* number of inductives in the mutual *) let nb_ind = Array.length mib.mind_packets in (* number of params in the type *) let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in (* params context divided *) - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in (* predef coq's boolean type *) (* rec name *) let rec_name i =(string_of_id (Array.get mib.mind_packets i).mind_typename)^ - "_eqrec" + "_eqrec" in (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) let create_input c = - let myArrow u v = mkArrow u (lift 1 v) + let myArrow u v = mkArrow u (lift 1 v) and eqName = function | Name s -> id_of_string ("eq_"^(string_of_id s)) - | Anonymous -> id_of_string "eq_A" + | Anonymous -> id_of_string "eq_A" in let ext_rel_list = extended_rel_list 0 lnamesparrec in let lift_cnt = ref 0 in - let eqs_typ = List.map (fun aa -> - let a = lift !lift_cnt aa in - incr lift_cnt; - myArrow a (myArrow a bb) + let eqs_typ = List.map (fun aa -> + let a = lift !lift_cnt aa in + incr lift_cnt; + myArrow a (myArrow a bb) ) ext_rel_list in let eq_input = List.fold_left2 ( fun a b (n,_,_) -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName n) b a ) + mkNamedLambda (eqName n) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *) @@ -134,181 +145,170 @@ let make_eq_scheme sp = (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec in - let make_one_eq cur = - let ind = sp,cur in + let make_one_eq cur = + let ind = kn,cur in (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd ind) in + let cur_packet = mib.mind_packets.(snd ind) in (* Inductive toto : [rettyp] := *) let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in - (* split rettyp in a list without the non rec params and the last -> + (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in (* give a type A, this function tries to find the equality on A declared previously *) (* nlist = the number of args (A , B , ... ) eqA = the deBruijn index of the first eq param - ndx = how much to translate due to the 2nd Case + ndx = how much to translate due to the 2nd Case *) - let compute_A_equality rel_list nlist eqA ndx t = + let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in - let rec aux c a = match c with + let rec aux c = + let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in + match kind_of_term c with | Rel x -> mkRel (x-nlist+ndx) - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) - | Cast (x,_,_) -> aux (kind_of_term x) a - | App (x,newa) -> aux (kind_of_term x) newa - | Ind (sp',i) -> if sp=sp' then mkRel(eqA-nlist-i+nb_ind-1) - else ( try - let eq = find_eq_scheme (sp',i) - and eqa = Array.map - (fun x -> aux (kind_of_term x) [||] ) a - in - let args = Array.append - (Array.map (fun x->lift lifti x) a) eqa - in if args = [||] then eq - else mkApp (eq,Array.append + | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) + | Cast (x,_,_) -> aux (applist (x,a)) + | App _ -> assert false + | Ind (kn',i as ind') -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1) + else ( try + let a = Array.of_list a in + let eq = mkConst (find_scheme (!beq_scheme_kind_aux()) (kn',i)) + and eqa = Array.map aux a + in + let args = Array.append + (Array.map (fun x->lift lifti x) a) eqa + in if args = [||] then eq + else mkApp (eq,Array.append (Array.map (fun x->lift lifti x) a) eqa) - with Not_found -> raise(EqNotFound (string_of_kn sp')) + with Not_found -> raise(EqNotFound (ind',ind)) ) - | Sort _ -> raise (EqUnknown "Sort" ) - | Prod _ -> raise (EqUnknown "Prod" ) - | Lambda _-> raise (EqUnknown "Lambda") + | Sort _ -> raise InductiveWithSort + | Prod _ -> raise InductiveWithProduct + | Lambda _-> raise (EqUnknown "Lambda") | LetIn _ -> raise (EqUnknown "LetIn") - | Const kn -> let mp,dir,lbl= repr_con kn in - mkConst (make_con mp dir ( - mk_label ("eq_"^(string_of_label lbl)))) + | Const kn -> + (match Environ.constant_opt_value env kn with + | None -> raise (ParameterWithoutEquality kn) + | Some c -> aux (applist (c,a))) | Construct _ -> raise (EqUnknown "Construct") | Case _ -> raise (EqUnknown "Case") | CoFix _ -> raise (EqUnknown "CoFix") - | Fix _ -> raise (EqUnknown "Fix") - | Meta _ -> raise (EqUnknown "Meta") + | Fix _ -> raise (EqUnknown "Fix") + | Meta _ -> raise (EqUnknown "Meta") | Evar _ -> raise (EqUnknown "Evar") in - aux t [||] + aux t in (* construct the predicate for the Case part*) - let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) + let do_predicate rel_list n = + List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) (mkLambda (Anonymous, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - bb)) - (List.rev rettyp_l) in + bb)) + (List.rev rettyp_l) in (* make_one_eq *) - (* do the [| C1 ... => match Y with ... end - ... + (* do the [| C1 ... => match Y with ... end + ... Cn => match Y with ... end |] part *) let ci = make_case_info env ind MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.create n ff in + let ar = Array.create n ff in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.create n ff in let constrsj = constrs (3+nparrec+nb_cstr_args) in for j=0 to n-1 do - if (i=j) then + if (i=j) then ar2.(j) <- let cc = (match nb_cstr_args with | 0 -> tt - | _ -> let eqs = Array.make nb_cstr_args tt in + | _ -> let eqs = Array.make nb_cstr_args tt in for ndx = 0 to nb_cstr_args-1 do let _,_,cc = List.nth constrsi.(i).cs_args ndx in let eqA = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) (nb_cstr_args+ndx+1) - (kind_of_term cc) - in - Array.set eqs ndx + cc + in + Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] )) - done; - Array.fold_left - (fun a b -> mkApp (andb(),[|b;a|])) - (eqs.(0)) + done; + Array.fold_left + (fun a b -> mkApp (andb(),[|b;a|])) + (eqs.(0)) (Array.sub eqs 1 (nb_cstr_args - 1)) ) in (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc - (constrsj.(j).cs_args) - ) + (constrsj.(j).cs_args) + ) else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) ff (constrsj.(j).cs_args) ) done; - ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) + ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (id_of_string "Y") ,ar2)) - (constrsi.(i).cs_args)) + (constrsi.(i).cs_args)) done; mkNamedLambda (id_of_string "X") (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (id_of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar))) - in (* make_eq_scheme *) - try - let names = Array.make nb_ind Anonymous and - types = Array.make nb_ind mkSet and - cores = Array.make nb_ind mkSet and - res = Array.make nb_ind mkSet in + mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar))) + in (* build_beq_scheme *) + let names = Array.make nb_ind Anonymous and + types = Array.make nb_ind mkSet and + cores = Array.make nb_ind mkSet in for i=0 to (nb_ind-1) do names.(i) <- Name (id_of_string (rec_name i)); - types.(i) <- mkArrow (mkFullInd (sp,i) 0) - (mkArrow (mkFullInd (sp,i) 1) bb); + types.(i) <- mkArrow (mkFullInd (kn,i) 0) + (mkArrow (mkFullInd (kn,i) 1) bb); cores.(i) <- make_one_eq i - done; - if (string_of_mp (modpath sp ))="Coq.Init.Logic" - then print_string "Logic time, do nothing.\n" - else ( - for i=0 to (nb_ind-1) do - let cpack = Array.get mib.mind_packets i in - if check_eq_scheme (sp,i) - then message ("Boolean equality is already defined on "^ - (string_of_id cpack.mind_typename)^".") - else ( + done; + Array.init nb_ind (fun i -> + let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in + if not (List.mem InSet kelim) then + raise (NonSingletonProp (kn,i)); let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in - res.(i) <- create_input fix - ) - done; - ); - res - with - | EqUnknown s -> error ("Type unexpected ("^s^ - ") during boolean eq computation, please report.") - | EqNotFound s -> error ("Boolean equality on "^s^ - " is missing, equality will not be defined.") - | _ -> error ("Unknown exception during boolean equality creation,"^ - " the equality will not be defined.") + create_input fix) + +let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme + +let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind (* This function tryies to get the [inductive] between a constr the constr should be Ind i or App(Ind i,[|args|]) *) -let destruct_ind c = +let destruct_ind c = try let u,v = destApp c in let indc = destInd u in indc,v with _-> let indc = destInd c in indc,[||] -(* - In the followind, avoid is the list of names to avoid. +(* + In the following, avoid is the list of names to avoid. If the args of the Inductive type are A1 ... An - then avoid should be + then avoid should be [| lb_An ... lb _A1 (resp. bl_An ... bl_A1) eq_An .... eq_A1 An ... A1 |] so from Ai we can find the the correct eq_Ai bl_ai or lb_ai *) (* used in the leib -> bool side*) -let do_replace_lb aavoid narg gls p q = +let do_replace_lb lb_scheme_key aavoid narg gls p q = let avoid = Array.of_list aavoid in - let do_arg v offset = - try + let do_arg v offset = + try let x = narg*offset in - let s = destVar v in + let s = destVar v in let n = Array.length avoid in - let rec find i = - if avoid.(n-i) = s then avoid.(n-i-x) - else (if i<n then find (i+1) + let rec find i = + if avoid.(n-i) = s then avoid.(n-i-x) + else (if i<n then find (i+1) else error ("Var "^(string_of_id s)^" seems unknown.") ) in mkVar (find 1) @@ -317,47 +317,46 @@ let do_replace_lb aavoid narg gls p q = ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( - if offset=1 then ("eq_"^(string_of_label lbl)) + if offset=1 then ("eq_"^(string_of_label lbl)) else ((string_of_label lbl)^"_lb") ))) ) in let type_of_pq = pf_type_of gls p in let u,v = destruct_ind type_of_pq - in let lb_type_of_p = - try find_lb_proof u - with Not_found -> + in let lb_type_of_p = + try mkConst (find_scheme lb_scheme_key u) + with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = msg_with Format.str_formatter + let err_msg = msg_with Format.str_formatter (str "Leibniz->boolean:" ++ - str "You have to declare the" ++ + str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_constr type_of_pq ++ + Printer.pr_constr type_of_pq ++ str " first."); Format.flush_str_formatter () in error err_msg - in let lb_args = Array.append (Array.append + in let lb_args = Array.append (Array.append (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v) - in let app = if lb_args = [||] - then lb_type_of_p else mkApp (lb_type_of_p,lb_args) + in let app = if lb_args = [||] + then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in [Equality.replace p q ; apply app ; Auto.default_auto] - (* used in the bool -> leib side *) -let do_replace_bl ind gls aavoid narg lft rgt = - let avoid = Array.of_list aavoid in - let do_arg v offset = - try +let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = + let avoid = Array.of_list aavoid in + let do_arg v offset = + try let x = narg*offset in - let s = destVar v in + let s = destVar v in let n = Array.length avoid in - let rec find i = - if avoid.(n-i) = s then avoid.(n-i-x) - else (if i<n then find (i+1) + let rec find i = + if avoid.(n-i) = s then avoid.(n-i-x) + else (if i<n then find (i+1) else error ("Var "^(string_of_id s)^" seems unknown.") ) in mkVar (find 1) @@ -366,60 +365,60 @@ let do_replace_bl ind gls aavoid narg lft rgt = ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( - if offset=1 then ("eq_"^(string_of_label lbl)) + if offset=1 then ("eq_"^(string_of_label lbl)) else ((string_of_label lbl)^"_bl") ))) ) in - let rec aux l1 l2 = + let rec aux l1 l2 = match (l1,l2) with | (t1::q1,t2::q2) -> let tt1 = pf_type_of gls t1 in if t1=t2 then aux q1 q2 else ( - let u,v = try destruct_ind tt1 + let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) with _ -> ind,[||] - in if u = ind + in if u = ind then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2) else ( - let bl_t1 = - try find_bl_proof u - with Not_found -> + let bl_t1 = + try mkConst (find_scheme bl_scheme_key u) + with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = msg_with Format.str_formatter + let err_msg = msg_with Format.str_formatter (str "boolean->Leibniz:" ++ - str "You have to declare the" ++ + str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_constr tt1 ++ + Printer.pr_constr tt1 ++ str " first."); Format.flush_str_formatter () in error err_msg - in let bl_args = - Array.append (Array.append + in let bl_args = + Array.append (Array.append (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v ) - in - let app = if bl_args = [||] - then bl_t1 else mkApp (bl_t1,bl_args) - in - (Equality.replace_by t1 t2 + in + let app = if bl_args = [||] + then bl_t1 else mkApp (bl_t1,bl_args) + in + (Equality.replace_by t1 t2 (tclTHEN (apply app) (Auto.default_auto)))::(aux q1 q2) ) ) | ([],[]) -> [] | _ -> error "Both side of the equality must have the same arity." in - let (ind1,ca1) = try destApp lft with + let (ind1,ca1) = try destApp lft with _ -> error "replace failed." and (ind2,ca2) = try destApp rgt with _ -> error "replace failed." in let (sp1,i1) = try destInd ind1 with - _ -> (try fst (destConstruct ind1) with _ -> + _ -> (try fst (destConstruct ind1) with _ -> error "The expected type is an inductive one.") and (sp2,i2) = try destInd ind2 with _ -> (try fst (destConstruct ind2) with _ -> @@ -427,14 +426,14 @@ let do_replace_bl ind gls aavoid narg lft rgt = in if (sp1 <> sp2) || (i1 <> i2) then (error "Eq should be on the same type") - else (aux (Array.to_list ca1) (Array.to_list ca2)) + else (aux (Array.to_list ca1) (Array.to_list ca2)) -(* +(* create, from a list of ids [i1,i2,...,in] the list [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) -let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = - match n with +let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = + match n with Name s -> string_of_id s | Anonymous -> "A" in (id_of_string s',id_of_string ("eq_"^s'), @@ -445,72 +444,73 @@ let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = (* build the right eq_I A B.. N eq_A .. eq_N *) -let eqI ind l = +let eqI ind l = let list_id = list_id l in let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) - and e = try find_eq_scheme ind with - Not_found -> error - ("The boolean equality on "^(string_of_kn (fst ind))^" is needed."); + and e = try mkConst (find_scheme beq_scheme_kind ind) with + Not_found -> error + ("The boolean equality on "^(string_of_mind (fst ind))^" is needed."); in (if eA = [||] then e else mkApp(e,eA)) -let compute_bl_goal ind lnamesparrec nparrec = +(**********************************************************************) +(* Boolean->Leibniz *) + +let compute_bl_goal ind lnamesparrec nparrec = let eqI = eqI ind lnamesparrec in - let list_id = list_id lnamesparrec in + let list_id = list_id lnamesparrec in let create_input c = let x = id_of_string "x" and y = id_of_string "y" in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) - ) list_id in + ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a - ) c (List.rev list_id) (List.rev bl_typ) in + ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a - ) bl_input (List.rev list_id) (List.rev eqs_typ) in + ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec - in - let n = id_of_string "n" and - m = id_of_string "m" in + in + let n = id_of_string "x" and + m = id_of_string "y" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( - mkArrow + mkArrow (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|])) ))) - -let compute_bl_tact ind lnamesparrec nparrec = + +let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig = let list_id = list_id lnamesparrec in let avoid = ref [] in - let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in - let first_intros = + let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) - in + ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) + in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in - let freshn = fresh_id (!avoid) (id_of_string "n") gsig in + let freshn = fresh_id (!avoid) (id_of_string "x") gsig in let freshm = avoid := freshn::(!avoid); - fresh_id (!avoid) (id_of_string "m") gsig in + fresh_id (!avoid) (id_of_string "y") gsig in let freshz = avoid := freshm::(!avoid); fresh_id (!avoid) (id_of_string "Z") gsig in (* try with *) avoid := freshz::(!avoid); - Pfedit.by ( tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; new_induct false [ (Tacexpr.ElimOnConstr ((mkVar freshn), @@ -526,21 +526,20 @@ let compute_bl_tact ind lnamesparrec nparrec = None; intro_using freshz; intros; - tclTRY ( + tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); - simpl_in_hyp - ((Rawterm.all_occurrences_expr,freshz),InHyp); + simpl_in_hyp (freshz,InHyp); (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). *) tclREPEAT ( tclTHENSEQ [ - apply_in false false freshz [(Evd.empty,andb_prop()),Rawterm.NoBindings] None; + simple_apply_in freshz (andb_prop()); fun gl -> - let fresht = fresh_id (!avoid) (id_of_string "Z") gsig + let fresht = fresh_id (!avoid) (id_of_string "Z") gsig in - avoid := fresht::(!avoid); + avoid := fresht::(!avoid); (new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshz,Rawterm.NoBindings))] None @@ -549,30 +548,53 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). dl,Genarg.IntroIdentifier freshz]])) None) gl ]); (* - Ci a1 ... an = Ci b1 ... bn + Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) fun gls-> let gl = (gls.Evd.it).Evd.evar_concl in match (kind_of_term gl) with - | App (c,ca) -> ( + | App (c,ca) -> ( match (kind_of_term c) with - | Ind (i1,i2) -> - if(string_of_label (label i1) = "eq") + | Ind indeq -> + if IndRef indeq = Coqlib.glob_eq then ( - tclTHENSEQ ((do_replace_bl ind gls (!avoid) + tclTHENSEQ ((do_replace_bl bl_scheme_key ind gls + (!avoid) nparrec (ca.(2)) (ca.(1)))@[Auto.default_auto]) gls ) - else + else (error "Failure while solving Boolean->Leibniz.") | _ -> error "Failure while solving Boolean->Leibniz." ) | _ -> error "Failure while solving Boolean->Leibniz." - - ] - ) -let compute_lb_goal ind lnamesparrec nparrec = + ] gsig + +let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") + +let make_bl_scheme mind = + let mib = Global.lookup_mind mind in + if Array.length mib.mind_packets <> 1 then + errorlabstrm "" + (str "Automatic building of boolean->Leibniz lemmas not supported"); + let ind = (mind,0) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + let lnonparrec,lnamesparrec = + context_chop (nparams-nparrec) mib.mind_params_ctxt in + [|Pfedit.build_by_tactic + (compute_bl_goal ind lnamesparrec nparrec) + (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec)|] + +let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme + +let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind + +(**********************************************************************) +(* Leibniz->Boolean *) + +let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in let create_input c = @@ -581,70 +603,68 @@ let compute_lb_goal ind lnamesparrec nparrec = let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) - ) list_id in + ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> mkNamedProd slb b a - ) c (List.rev list_id) (List.rev lb_typ) in + ) c (List.rev list_id) (List.rev lb_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a - ) lb_input (List.rev list_id) (List.rev eqs_typ) in + ) lb_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec - in - let n = id_of_string "n" and - m = id_of_string "m" in + in + let n = id_of_string "x" and + m = id_of_string "y" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( - mkArrow + mkArrow (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|])) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))) -let compute_lb_tact ind lnamesparrec nparrec = +let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig = let list_id = list_id lnamesparrec in let avoid = ref [] in - let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in - let first_intros = + let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in + ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in - let freshn = fresh_id (!avoid) (id_of_string "n") gsig in + let freshn = fresh_id (!avoid) (id_of_string "x") gsig in let freshm = avoid := freshn::(!avoid); - fresh_id (!avoid) (id_of_string "m") gsig in + fresh_id (!avoid) (id_of_string "y") gsig in let freshz = avoid := freshm::(!avoid); fresh_id (!avoid) (id_of_string "Z") gsig in (* try with *) avoid := freshz::(!avoid); - Pfedit.by ( tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; - new_induct false [Tacexpr.ElimOnConstr - ((mkVar freshn),Rawterm.NoBindings)] + new_induct false [Tacexpr.ElimOnConstr + ((mkVar freshn),Rawterm.NoBindings)] None (None,None) None; intro_using freshm; - new_destruct false [Tacexpr.ElimOnConstr + new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshm),Rawterm.NoBindings)] None (None,None) None; intro_using freshz; intros; - tclTRY ( + tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); Equality.inj [] false (mkVar freshz,Rawterm.NoBindings); @@ -658,21 +678,48 @@ let compute_lb_tact ind lnamesparrec nparrec = (* assume the goal to be eq (eq_type ...) = true *) match (kind_of_term gl) with | App(c,ca) -> (match (kind_of_term ca.(1)) with - | App(c',ca') -> + | App(c',ca') -> let n = Array.length ca' in - tclTHENSEQ (do_replace_lb (!avoid) - nparrec gls + tclTHENSEQ (do_replace_lb lb_scheme_key + (!avoid) + nparrec gls ca'.(n-2) ca'.(n-1)) gls - | _ -> error - "Failure while solving Leibniz->Boolean." + | _ -> error + "Failure while solving Leibniz->Boolean." ) - | _ -> error - "Failure while solving Leibniz->Boolean." - ] - ) + | _ -> error + "Failure while solving Leibniz->Boolean." + ] gsig + +let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") + +let make_lb_scheme mind = + let mib = Global.lookup_mind mind in + if Array.length mib.mind_packets <> 1 then + errorlabstrm "" + (str "Automatic building of Leibniz->boolean lemmas not supported"); + let ind = (mind,0) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + let lnonparrec,lnamesparrec = + context_chop (nparams-nparrec) mib.mind_params_ctxt in + [|Pfedit.build_by_tactic + (compute_lb_goal ind lnamesparrec nparrec) + (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)|] + +let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme + +let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind + +(**********************************************************************) +(* Decidable equality *) + +let check_not_is_defined () = + try ignore (Coqlib.build_coq_not ()) with _ -> raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) -let compute_dec_goal ind lnamesparrec nparrec = +let compute_dec_goal ind lnamesparrec nparrec = + check_not_is_defined (); let list_id = list_id lnamesparrec in let create_input c = let x = id_of_string "x" and @@ -680,39 +727,39 @@ let compute_dec_goal ind lnamesparrec nparrec = let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) - ) list_id in + ) list_id in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) - ) list_id in + ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> mkNamedProd slb b a - ) c (List.rev list_id) (List.rev lb_typ) in + ) c (List.rev list_id) (List.rev lb_typ) in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a - ) lb_input (List.rev list_id) (List.rev bl_typ) in + ) lb_input (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a - ) bl_input (List.rev list_id) (List.rev eqs_typ) in + ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec - in - let n = id_of_string "n" and - m = id_of_string "m" in + in + let n = id_of_string "x" and + m = id_of_string "y" in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( @@ -722,93 +769,116 @@ let compute_dec_goal ind lnamesparrec nparrec = ) ) -let compute_dec_tact ind lnamesparrec nparrec = +let compute_dec_tact ind lnamesparrec nparrec gsig = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in - let avoid = ref [] in - let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in - let eqtrue x = mkApp(eq,[|bb;x;tt|]) in - let eqfalse x = mkApp(eq,[|bb;x;ff|]) in - let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_first_intros = List.map ( fun s -> - let fresh = fresh_id (!avoid) s gsig in - avoid := fresh::(!avoid); fresh ) first_intros in - let freshn = fresh_id (!avoid) (id_of_string "n") gsig in - let freshm = avoid := freshn::(!avoid); - fresh_id (!avoid) (id_of_string "m") gsig in - let freshH = avoid := freshm::(!avoid); - fresh_id (!avoid) (id_of_string "H") gsig in - let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in - avoid := freshH::(!avoid); - Pfedit.by ( tclTHENSEQ [ - intros_using fresh_first_intros; - intros_using [freshn;freshm]; - assert_tac (Name freshH) ( - mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - ) ]); -(*we do this so we don't have to prove the same goal twice *) - Pfedit.by ( tclTHEN - (new_destruct false [Tacexpr.ElimOnConstr - (eqbnm,Rawterm.NoBindings)] - None - (None,None) - None) - Auto.default_auto - ); - Pfedit.by ( - let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in - avoid := freshH2::(!avoid); - new_destruct false [Tacexpr.ElimOnConstr - ((mkVar freshH),Rawterm.NoBindings)] - None - (None,Some (dl,Genarg.IntroOrAndPattern [ - [dl,Genarg.IntroAnonymous]; - [dl,Genarg.IntroIdentifier freshH2]])) None - ); - let arfresh = Array.of_list fresh_first_intros in - let xargs = Array.sub arfresh 0 (2*nparrec) in - let blI = try find_bl_proof ind with + let avoid = ref [] in + let eqtrue x = mkApp(eq,[|bb;x;tt|]) in + let eqfalse x = mkApp(eq,[|bb;x;ff|]) in + let first_intros = + ( List.map (fun (s,_,_,_) -> s ) list_id ) @ + ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ + ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ + ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in + let fresh_first_intros = List.map ( fun s -> + let fresh = fresh_id (!avoid) s gsig in + avoid := fresh::(!avoid); fresh ) first_intros in + let freshn = fresh_id (!avoid) (id_of_string "x") gsig in + let freshm = avoid := freshn::(!avoid); + fresh_id (!avoid) (id_of_string "y") gsig in + let freshH = avoid := freshm::(!avoid); + fresh_id (!avoid) (id_of_string "H") gsig in + let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in + avoid := freshH::(!avoid); + let arfresh = Array.of_list fresh_first_intros in + let xargs = Array.sub arfresh 0 (2*nparrec) in + let blI = try mkConst (find_scheme bl_scheme_kind ind) with Not_found -> error ( "Error during the decidability part, boolean to leibniz"^ " equality is required.") - in - let lbI = try find_lb_proof ind with + in + let lbI = try mkConst (find_scheme lb_scheme_kind ind) with Not_found -> error ( "Error during the decidability part, leibniz to boolean"^ " equality is required.") - in - - (* left *) - Pfedit.by ( tclTHENSEQ [ simplest_left; - apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); - Auto.default_auto - ]); - (*right *) - let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in - avoid := freshH3::(!avoid); - Pfedit.by (tclTHENSEQ [ simplest_right ; - unfold_constr (Lazy.force Coqlib.coq_not_ref); - intro; - Equality.subst_all; - assert_tac (Name freshH3) - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) - ]); - Pfedit.by - (tclTHENSEQ [apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); - Auto.default_auto - ]); - Pfedit.by (Equality.general_rewrite_bindings_in true - all_occurrences - (List.hd !avoid) + in + tclTHENSEQ [ + intros_using fresh_first_intros; + intros_using [freshn;freshm]; + (*we do this so we don't have to prove the same goal twice *) + assert_by (Name freshH) ( + mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) + ) + (tclTHEN + (new_destruct false [Tacexpr.ElimOnConstr + (eqbnm,Rawterm.NoBindings)] + None + (None,None) + None) + Auto.default_auto); + (fun gsig -> + let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in + avoid := freshH2::(!avoid); + tclTHENS ( + new_destruct false [Tacexpr.ElimOnConstr + ((mkVar freshH),Rawterm.NoBindings)] + None + (None,Some (dl,Genarg.IntroOrAndPattern [ + [dl,Genarg.IntroAnonymous]; + [dl,Genarg.IntroIdentifier freshH2]])) None + ) [ + (* left *) + tclTHENSEQ [ + simplest_left; + apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); + Auto.default_auto + ]; + (*right *) + (fun gsig -> + let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in + avoid := freshH3::(!avoid); + tclTHENSEQ [ + simplest_right ; + unfold_constr (Lazy.force Coqlib.coq_not_ref); + intro; + Equality.subst_all; + assert_by (Name freshH3) + (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) + (tclTHENSEQ [ + apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); + Auto.default_auto + ]); + Equality.general_rewrite_bindings_in true + all_occurrences false + (List.hd !avoid) ((mkVar (List.hd (List.tl !avoid))), Rawterm.NoBindings ) - true); - Pfedit.by (Equality.discr_tac false None) - + true; + Equality.discr_tac false None + ] gsig) + ] gsig) + ] gsig + +let make_eq_decidability mind = + let mib = Global.lookup_mind mind in + if Array.length mib.mind_packets <> 1 then + anomaly "Decidability lemma for mutual inductive types not supported"; + let ind = (mind,0) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + let lnonparrec,lnamesparrec = + context_chop (nparams-nparrec) mib.mind_params_ctxt in + [|Pfedit.build_by_tactic + (compute_dec_goal ind lnamesparrec nparrec) + (compute_dec_tact ind lnamesparrec nparrec)|] + +let eq_dec_scheme_kind = + declare_mutual_scheme_object "_eq_dec" make_eq_decidability + +(* The eq_dec_scheme proofs depend on the equality and discr tactics + but the inj tactics, that comes with discr, depends on the + eq_dec_scheme... *) +let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index b8fa1710..855f023f 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -11,17 +11,31 @@ open Names open Libnames open Mod_subst open Sign +open Proof_type +open Ind_tables +(* Build boolean equality of a block of mutual inductive types *) -val subst_in_constr : (object_name*substitution*(inductive*constr)) - -> (inductive*constr) +exception EqNotFound of inductive * inductive +exception EqUnknown of string +exception UndefinedCst of string +exception InductiveWithProduct +exception InductiveWithSort +exception ParameterWithoutEquality of constant +exception NonSingletonProp of inductive -val compute_bl_goal : inductive -> rel_context -> int -> types -val compute_bl_tact : inductive -> rel_context -> int -> unit -val compute_lb_goal : inductive -> rel_context -> int -> types -val compute_lb_tact : inductive -> rel_context -> int -> unit -val compute_dec_goal : inductive -> rel_context -> int -> types -val compute_dec_tact : inductive -> rel_context -> int -> unit +val beq_scheme_kind : mutual scheme_kind +val build_beq_scheme : mutual_inductive -> constr array +(* Build equivalence between boolean equality and Leibniz equality *) -val make_eq_scheme :mutual_inductive -> types array +val lb_scheme_kind : mutual scheme_kind +val make_lb_scheme : mutual_inductive -> constr array + +val bl_scheme_kind : mutual scheme_kind +val make_bl_scheme : mutual_inductive -> constr array + +(* Build decidability of equality *) + +val eq_dec_scheme_kind : mutual scheme_kind +val make_eq_decidability : mutual_inductive -> constr array diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml new file mode 100644 index 00000000..b45e45c8 --- /dev/null +++ b/toplevel/autoinstance.ml @@ -0,0 +1,316 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id:$ *) + +(*i*) +open Pp +open Printer +open Names +open Term +open Evd +open Sign +open Libnames +(*i*) + +(*s + * Automatic detection of (some) record instances + *) + +(* Datatype for wannabe-instances: a signature is a typeclass along + with the collection of evars corresponding to the parameters/fields + of the class. Each evar can be uninstantiated (we're still looking + for them) or defined (the instance for the field is fixed) *) +type signature = global_reference * evar list * evar_map + +type instance_decl_function = global_reference -> rel_context -> constr list -> unit + +(* + * Search algorithm + *) + +let rec subst_evar evar def n c = + match kind_of_term c with + | Evar (e,_) when e=evar -> lift n def + | _ -> map_constr_with_binders (fun n->n+1) (subst_evar evar def) n c + +let subst_evar_in_evm evar def evm = + Evd.fold + (fun ev evi acc -> + let evar_body = match evi.evar_body with + | Evd.Evar_empty -> Evd.Evar_empty + | Evd.Evar_defined c -> Evd.Evar_defined (subst_evar evar def 0 c) in + let evar_concl = subst_evar evar def 0 evi.evar_concl in + Evd.add acc ev {evi with evar_body=evar_body; evar_concl=evar_concl} + ) evm empty + +(* Tries to define ev by c in evd. Fails if ev := c1 and c1 /= c ev : + * T1, c : T2 and T1 /= T2. Defines recursively all evars instantiated + * by this definition. *) + +let rec safe_define evm ev c = + if not (closedn (-1) c) then raise Termops.CannotFilter else +(* msgnl(str"safe_define "++pr_evar_map evm++spc()++str" |- ?"++Util.pr_int ev++str" := "++pr_constr c);*) + let evi = (Evd.find evm ev) in + let define_subst evm sigma = + Util.Intmap.fold + ( fun ev (e,c) evm -> + match kind_of_term c with Evar (i,_) when i=ev -> evm | _ -> + safe_define evm ev (lift (-List.length e) c) + ) sigma evm in + match evi.evar_body with + | Evd.Evar_defined def -> + define_subst evm (Termops.filtering [] Reduction.CUMUL def c) + | Evd.Evar_empty -> + let t = Libtypes.reduce (Typing.type_of (Global.env()) evm c) in + let u = Libtypes.reduce (evar_concl evi) in + let evm = subst_evar_in_evm ev c evm in + define_subst (Evd.define ev c evm) (Termops.filtering [] Reduction.CUMUL t u) + +let add_gen_ctx (cl,gen,evm) ctx : signature * constr list = + let rec really_new_evar () = + let ev = Evarutil.new_untyped_evar() in + if Evd.is_evar evm ev then really_new_evar() else ev in + let add_gen_evar (cl,gen,evm) ev ty : signature = + let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val ty) in + (cl,ev::gen,evm) in + let rec mksubst b = function + | [] -> [] + | a::tl -> b::(mksubst (a::b) tl) in + let evl = List.map (fun _ -> really_new_evar()) ctx in + let evcl = List.map (fun i -> mkEvar (i,[||])) evl in + let substl = List.rev (mksubst [] (evcl)) in + let ctx = List.map2 (fun s t -> substnl s 0 t) substl ctx in + let sign = List.fold_left2 add_gen_evar (cl,gen,evm) (List.rev evl) ctx in + sign,evcl + +(* TODO : for full proof-irrelevance in the search, provide a real + compare function for constr instead of Pervasive's one! *) +module SubstSet : Set.S with type elt = Termops.subst + = Set.Make (struct type t = Termops.subst + let compare = Util.Intmap.compare (Pervasives.compare) + end) + +(* searches instatiations in the library for just one evar [ev] of a + signature. [k] is called on each resulting signature *) +let complete_evar (cl,gen,evm:signature) (ev,evi) (k:signature -> unit) = + let ev_typ = Libtypes.reduce (evar_concl evi) in + let sort_is_prop = is_Prop (Typing.type_of (Global.env()) evm (evar_concl evi)) in +(* msgnl(str"cherche "++pr_constr ev_typ++str" pour "++Util.pr_int ev);*) + let substs = ref SubstSet.empty in + try List.iter + ( fun (gr,(pat,_),s) -> + let (_,genl,_) = Termops.decompose_prod_letin pat in + let genl = List.map (fun (_,_,t) -> t) genl in + let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) genl in + let def = applistc (Libnames.constr_of_global gr) argl in +(* msgnl(str"essayons ?"++Util.pr_int ev++spc()++str":="++spc() + ++pr_constr def++spc()++str":"++spc()++pr_constr (Global.type_of_global gr)*) + (*++spc()++str"dans"++spc()++pr_evar_map evm++spc());*) + try + let evm = safe_define evm ev def in + k (cl,gen,evm); + if sort_is_prop && SubstSet.mem s !substs then raise Exit; + substs := SubstSet.add s !substs + with Termops.CannotFilter -> () + ) (Libtypes.search_concl ev_typ) + with Exit -> () + +let evm_fold_rev f evm acc = + let l = Evd.fold (fun ev evi acc -> (ev,evi)::acc) evm [] in + List.fold_left (fun acc (ev,evi) -> f ev evi acc) acc l + +exception Continue of Evd.evar * Evd.evar_info + +(* searches matches for all the uninstantiated evars of evd in the + context. For each totally instantiated evar_map found, apply + k. *) +let rec complete_signature (k:signature -> unit) (cl,gen,evm:signature) = + try + evm_fold_rev + ( fun ev evi _ -> + if not (is_defined evm ev) && not (List.mem ev gen) then + raise (Continue (ev,evi)) + ) evm (); k (cl,gen,evm) + with Continue (ev,evi) -> complete_evar (cl,gen,evm) (ev,evi) (complete_signature k) + +(* define all permutations of the evars to evd and call k on the + resulting evd *) +let complete_with_evars_permut (cl,gen,evm:signature) evl c (k:signature -> unit) : unit = + let rec aux evm = List.iter + ( fun (ctx,ev) -> + let tyl = List.map (fun (_,_,t) -> t) ctx in + let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) tyl in + let def = applistc c argl in +(* msgnl(str"trouvé def ?"++Util.pr_int ev++str" := "++pr_constr def++str " dans "++pr_evar_map evm);*) + try + if not (Evd.is_defined evm ev) then + let evm = safe_define evm ev def in + aux evm; k (cl,gen,evm) + with Termops.CannotFilter -> () + ) evl in + aux evm + +let new_inst_no = + let cnt = ref 0 in + fun () -> incr cnt; string_of_int !cnt + +let make_instance_ident gr = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_autoinstance_"^new_inst_no()) + +let new_instance_message ident typ def = + Flags.if_verbose + msgnl (str"new instance"++spc() + ++Nameops.pr_id ident++spc()++str":"++spc() + ++pr_constr typ++spc()++str":="++spc() + ++pr_constr def) + +open Entries + +let rec deep_refresh_universes c = + match kind_of_term c with + | Sort (Type _) -> Termops.new_Type() + | _ -> map_constr deep_refresh_universes c + +let declare_record_instance gr ctx params = + let ident = make_instance_ident gr in + let def = it_mkLambda_or_LetIn (applistc (constr_of_global gr) params) ctx in + let def = deep_refresh_universes def in + let ce = { const_entry_body=def; const_entry_type=None; + const_entry_opaque=false; const_entry_boxed=false } in + let cst = Declare.declare_constant ident + (DefinitionEntry ce,Decl_kinds.IsDefinition Decl_kinds.StructureComponent) in + new_instance_message ident (Typeops.type_of_constant (Global.env()) cst) def + +let declare_class_instance gr ctx params = + let ident = make_instance_ident gr in + let cl = Typeclasses.class_info gr in + let (def,typ) = Typeclasses.instance_constructor cl params in + let (def,typ) = it_mkLambda_or_LetIn def ctx, it_mkProd_or_LetIn typ ctx in + let def = deep_refresh_universes def in + let typ = deep_refresh_universes typ in + let ce = Entries.DefinitionEntry + { const_entry_type=Some typ; const_entry_body=def; + const_entry_opaque=false; const_entry_boxed=false } in + try + let cst = Declare.declare_constant ident + (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in + Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst)); + new_instance_message ident typ def + with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Cerrors.explain_exn e) + +let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t; + match kind_of_term t with + | Prod (n,t,c) -> iter_under_prod f ((n,None,t)::ctx) c + | _ -> () + +(* main search function: search for total instances containing gr, and + apply k to each of them *) +let complete_signature_with_def gr deftyp (k:instance_decl_function -> signature -> unit) : unit = + let gr_c = Libnames.constr_of_global gr in + let (smap:(Libnames.global_reference * Evd.evar_map, + ('a * 'b * Term.constr) list * Evd.evar) + Gmapl.t ref) = ref Gmapl.empty in + iter_under_prod + ( fun ctx typ -> + List.iter + (fun ((cl,ev,evm),_,_) -> +(* msgnl(pr_global gr++str" : "++pr_constr typ++str" matche ?"++Util.pr_int ev++str " dans "++pr_evar_map evm);*) + smap := Gmapl.add (cl,evm) (ctx,ev) !smap) + (Recordops.methods_matching typ) + ) [] deftyp; + Gmapl.iter + ( fun (cl,evm) evl -> + let f = if Typeclasses.is_class cl then + declare_class_instance else declare_record_instance in + complete_with_evars_permut (cl,[],evm) evl gr_c + (fun sign -> complete_signature (k f) sign) + ) !smap + +(* + * Interface with other parts: hooks & declaration + *) + + +let evar_definition evi = match evar_body evi with + Evar_empty -> assert false | Evar_defined c -> c + +let gen_sort_topo l evm = + let iter_evar f ev = + let rec aux c = match kind_of_term c with + Evar (e,_) -> f e + | _ -> iter_constr aux c in + aux (Evd.evar_concl (Evd.find evm ev)); + if Evd.is_defined evm ev then aux (evar_definition (Evd.find evm ev)) in + let r = ref [] in + let rec dfs ev = iter_evar dfs ev; + if not(List.mem ev !r) then r := ev::!r in + List.iter dfs l; List.rev !r + +(* register real typeclass instance given a totally defined evd *) +let declare_instance (k:global_reference -> rel_context -> constr list -> unit) + (cl,gen,evm:signature) = + let evm = Evarutil.nf_evars evm in + let gen = gen_sort_topo gen evm in + let (evm,gen) = List.fold_right + (fun ev (evm,gen) -> + if Evd.is_defined evm ev + then Evd.remove evm ev,gen + else evm,(ev::gen)) + gen (evm,[]) in +(* msgnl(str"instance complète : ["++Util.prlist_with_sep (fun _ -> str";") Util.pr_int gen++str"] : "++spc()++pr_evar_map evm);*) + let ngen = List.length gen in + let (_,ctx,evm) = List.fold_left + ( fun (i,ctx,evm) ev -> + let ctx = (Anonymous,None,lift (-i) (Evd.evar_concl(Evd.find evm ev)))::ctx in + let evm = subst_evar_in_evm ev (mkRel i) (Evd.remove evm ev) in + (i-1,ctx,evm) + ) (ngen,[],evm) gen in + let fields = List.rev (Evd.fold ( fun ev evi l -> evar_definition evi::l ) evm []) in + k cl ctx fields + +let autoinstance_opt = ref true + +let search_declaration gr = + if !autoinstance_opt && + not (Lib.is_modtype()) then + let deftyp = Global.type_of_global gr in + complete_signature_with_def gr deftyp declare_instance + +let search_record k cons sign = + if !autoinstance_opt && not (Lib.is_modtype()) then + complete_signature (declare_instance k) (cons,[],sign) + +(* +let dh_key = Profile.declare_profile "declaration_hook" +let ch_key = Profile.declare_profile "class_decl_hook" +let declaration_hook = Profile.profile1 dh_key declaration_hook +let class_decl_hook = Profile.profile1 ch_key class_decl_hook +*) + +(* + * Options and bookeeping + *) + +let begin_autoinstance () = + if not !autoinstance_opt then ( + autoinstance_opt := true; + ) + +let end_autoinstance () = + if !autoinstance_opt then ( + autoinstance_opt := false; + ) + +let _ = + Goptions.declare_bool_option + { Goptions.optsync=true; + Goptions.optkey=["Autoinstance"]; + Goptions.optname="automatic typeclass instance recognition"; + Goptions.optread=(fun () -> !autoinstance_opt); + Goptions.optwrite=(fun b -> if b then begin_autoinstance() else end_autoinstance()) } diff --git a/toplevel/autoinstance.mli b/toplevel/autoinstance.mli new file mode 100644 index 00000000..3866fff3 --- /dev/null +++ b/toplevel/autoinstance.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id:$ *) + +(*i*) +open Term +open Libnames +open Typeclasses +open Names +open Evd +open Sign +(*i*) + +(*s Automatic detection of (some) record instances *) + +(* What to do if we find an instance. Passed are : the reference + * representing the record/class (definition or constructor) *) +type instance_decl_function = global_reference -> rel_context -> constr list -> unit + +(* [search_declaration gr] Search in the library if the (new) + * declaration gr can form an instance of a registered record/class *) +val search_declaration : global_reference -> unit + +(* [search_record declf gr evm] Search the library for instances of + the (new) record/class declaration [gr], and register them using + [declf]. [evm] is the signature of the record (to avoid recomputing + it) *) +val search_record : instance_decl_function -> global_reference -> evar_map -> unit + +(* Instance declaration for both scenarios *) +val declare_record_instance : instance_decl_function +val declare_class_instance : instance_decl_function diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 0983463a..d5a343b0 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: cerrors.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -17,9 +17,9 @@ open Indrec open Lexer let print_loc loc = - if loc = dummy_loc then + if loc = dummy_loc then (str"<unknown>") - else + else let loc = unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) @@ -31,41 +31,46 @@ let where s = (* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *) let rec explain_exn_default_aux anomaly_string report_fn = function - | Stream.Failure -> + | Stream.Failure -> hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") - | Stream.Error txt -> + | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Token.Error txt -> + | Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Sys_error msg -> + | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ()) - | UserError(s,pps) -> + | UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps) - | Out_of_memory -> + | Out_of_memory -> hov 0 (str "Out of memory.") - | Stack_overflow -> + | Stack_overflow -> hov 0 (str "Stack overflow.") - | Anomaly (s,pps) -> + | Timeout -> + hov 0 (str "Timeout!") + | Anomaly (s,pps) -> hov 0 (anomaly_string () ++ where s ++ pps ++ report_fn ()) + | AnomalyOnError (s,exc) -> + hov 0 (anomaly_string () ++ str s ++ str ". Received exception is:" ++ + fnl() ++ explain_exn_default_aux anomaly_string report_fn exc) | Match_failure(filename,pos1,pos2) -> - hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ + hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ if Sys.ocaml_version = "3.06" then - (str " from character " ++ int pos1 ++ + (str " from character " ++ int pos1 ++ str " to " ++ int pos2) else (str " at line " ++ int pos1 ++ str " character " ++ int pos2) ++ report_fn ()) - | Not_found -> + | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report_fn ()) - | Failure s -> + | Failure s -> hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report_fn ()) - | Invalid_argument s -> + | Invalid_argument s -> hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report_fn ()) - | Sys.Break -> + | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency (o,u,v) -> - let msg = + let msg = if !Constrextern.print_universes then spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") @@ -73,60 +78,60 @@ let rec explain_exn_default_aux anomaly_string report_fn = function else mt() in hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".") - | TypeError(ctx,te) -> + | TypeError(ctx,te) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te) | PretypeError(ctx,te) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te) | Typeclasses_errors.TypeClassError(env, te) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_typeclass_error env te) - | InductiveError e -> + | InductiveError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e) - | RecursionSchemeError e -> + | RecursionSchemeError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_recursion_scheme_error e) - | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when s <> mt () -> + | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () -> explain_exn_default_aux anomaly_string report_fn exc | Proof_type.LtacLocated (s,exc) -> hov 0 (Himsg.explain_ltac_call_trace s ++ fnl () ++ explain_exn_default_aux anomaly_string report_fn exc) - | Cases.PatternMatchingError (env,e) -> + | Cases.PatternMatchingError (env,e) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e) - | Tacred.ReductionTacticError e -> + | Tacred.ReductionTacticError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_reduction_tactic_error e) - | Logic.RefinerError e -> + | Logic.RefinerError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> hov 0 (str "Error:" ++ spc () ++ str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ - spc () ++ str "was not found" ++ + spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Nametab.GlobalizationConstantError q -> hov 0 (str "Error:" ++ spc () ++ - str "No constant of this name:" ++ spc () ++ + str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q ++ str ".") | Refiner.FailError (i,s) -> - hov 0 (str "Error: Tactic failure" ++ - (if s <> mt() then str ":" ++ s else mt ()) ++ + hov 0 (str "Error: Tactic failure" ++ + (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++ if i=0 then str "." else str " (level " ++ int i ++ str").") | Stdpp.Exc_located (loc,exc) -> hov 0 ((if loc = dummy_loc then (mt ()) else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) ++ explain_exn_default_aux anomaly_string report_fn exc) - | Lexer.Error Illegal_character -> + | Lexer.Error Illegal_character -> hov 0 (str "Syntax error: Illegal character.") - | Lexer.Error Unterminated_comment -> + | Lexer.Error Unterminated_comment -> hov 0 (str "Syntax error: Unterminated comment.") - | Lexer.Error Unterminated_string -> + | Lexer.Error Unterminated_string -> hov 0 (str "Syntax error: Unterminated string.") - | Lexer.Error Undefined_token -> + | Lexer.Error Undefined_token -> hov 0 (str "Syntax error: Undefined token.") - | Lexer.Error (Bad_token s) -> + | Lexer.Error (Bad_token s) -> hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".") | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ - (if s <> "" then + (if s <> "" then if Sys.ocaml_version = "3.06" then - (str ("(file \"" ^ s ^ "\", characters ") ++ + (str ("(file \"" ^ s ^ "\", characters ") ++ int b ++ str "-" ++ int e ++ str ")") else (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ @@ -135,8 +140,10 @@ let rec explain_exn_default_aux anomaly_string report_fn = function else (mt ())) ++ report_fn ()) + | AlreadyDeclared msg -> + hov 0 (msg ++ str ".") | reraise -> - hov 0 (anomaly_string () ++ str "Uncaught exception " ++ + hov 0 (anomaly_string () ++ str "Uncaught exception " ++ str (Printexc.to_string reraise) ++ report_fn ()) let anomaly_string () = str "Anomaly: " @@ -157,3 +164,6 @@ let _ = Tactic_debug.explain_logic_error_no_anomaly := let explain_exn_function = ref explain_exn_default let explain_exn e = !explain_exn_function e + +let explain_exn_no_anomaly e = + explain_exn_default_aux (fun () -> raise e) mt e diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index 1236ecf5..6890e73e 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cerrors.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Pp @@ -19,6 +19,12 @@ val print_loc : loc -> std_ppcmds val explain_exn : exn -> std_ppcmds +(** Same, but will re-raise all anomalies instead of explaining them *) + +val explain_exn_no_anomaly : exn -> std_ppcmds + +(** For debugging purpose (?), the explain function can be twicked *) + val explain_exn_function : (exn -> std_ppcmds) ref val explain_exn_default : exn -> std_ppcmds diff --git a/toplevel/class.ml b/toplevel/class.ml index 6ebc663b..3526bd8c 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: class.ml 11343 2008-09-01 20:55:13Z herbelin $ *) +(* $Id$ *) open Util open Pp @@ -29,10 +29,6 @@ open Safe_typing let strength_min l = if List.mem Local l then Local else Global -let id_of_varid c = match kind_of_term c with - | Var id -> id - | _ -> anomaly "class__id_of_varid" - (* Errors *) type coercion_error_kind = @@ -54,7 +50,7 @@ let explain_coercion_error g = function | NotAFunction -> (Printer.pr_global g ++ str" is not a function") | NoSource (Some cl) -> - (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " + (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " ++ Printer.pr_global g) | NoSource None -> (str ": cannot find the source class of " ++ Printer.pr_global g) @@ -62,7 +58,7 @@ let explain_coercion_error g = function pr_class cl ++ str " cannot be a source class" | NotUniform -> (Printer.pr_global g ++ - str" does not respect the inheritance uniform condition"); + str" does not respect the uniform inheritance condition"); | NoTarget -> (str"Cannot find the target class") | WrongTarget (clt,cl) -> @@ -95,33 +91,24 @@ let check_target clt = function (* condition d'heritage uniforme *) -let uniform_cond nargs lt = +let uniform_cond nargs lt = let rec aux = function | (0,[]) -> true | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l)) | _ -> false - in + in aux (nargs,lt) -let id_of_cl = function - | CL_FUN -> id_of_string "FUNCLASS" - | CL_SORT -> id_of_string "SORTCLASS" - | CL_CONST kn -> id_of_label (con_label kn) - | CL_IND ind -> - let (_,mip) = Global.lookup_inductive ind in - mip.mind_typename - | CL_SECVAR id -> id - let class_of_global = function | ConstRef sp -> CL_CONST sp | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id - | ConstructRef _ as c -> + | ConstructRef _ as c -> errorlabstrm "class_of_global" - (str "Constructors, such as " ++ Printer.pr_global c ++ + (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") -(* +(* lp est la liste (inverse'e) des arguments de la coercion ids est le nom de la classe source sps_opt est le sp de la classe source dans le cas des structures @@ -140,13 +127,13 @@ let get_source lp source = match lp with | [] -> raise Not_found | t1::_ -> find_class_type (Global.env()) Evd.empty t1 - in + in (cl1,lv1,1) | Some cl -> let rec aux = function | [] -> raise Not_found | t1::lt -> - try + try let cl1,lv1 = find_class_type (Global.env()) Evd.empty t1 in if cl = cl1 then cl1,lv1,(List.length lt+1) else raise Not_found @@ -154,20 +141,20 @@ let get_source lp source = in aux (List.rev lp) let get_target t ind = - if (ind > 1) then + if (ind > 1) then CL_FUN - else + else fst (find_class_type (Global.env()) Evd.empty t) -let prods_of t = +let prods_of t = let rec aux acc d = match kind_of_term d with | Prod (_,c1,c2) -> aux (c1::acc) c2 | Cast (c,_,_) -> aux acc c | _ -> (d,acc) - in + in aux [] t -let strength_of_cl = function +let strength_of_cl = function | CL_CONST kn -> Global | CL_SECVAR id -> Local | _ -> Global @@ -182,7 +169,7 @@ let ident_key_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" | CL_CONST sp -> string_of_label (con_label sp) - | CL_IND (sp,_) -> string_of_label (label sp) + | CL_IND (sp,_) -> string_of_label (mind_label sp) | CL_SECVAR id -> string_of_id id (* coercion identité *) @@ -199,7 +186,7 @@ let build_id_coercion idf_opt source = let c = match constant_opt_value env (destConst vs) with | Some c -> c | None -> error_not_transparent source in - let lams,t = Sign.decompose_lam_assum c in + let lams,t = decompose_lam_assum c in let val_f = it_mkLambda_or_LetIn (mkLambda (Name (id_of_string "x"), @@ -213,7 +200,7 @@ let build_id_coercion idf_opt source = lams in (* juste pour verification *) - let _ = + let _ = if not (Reductionops.is_conv_leq env Evd.empty (Typing.type_of env Evd.empty val_f) typ_f) @@ -242,7 +229,7 @@ let check_source = function | Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s)) | _ -> () -(* +(* nom de la fonction coercion strength de f nom de la classe source (optionnel) @@ -261,7 +248,7 @@ let add_new_coercion_core coef stre source target isid = let llp = List.length lp in if llp = 0 then raise (CoercionError NotAFunction); let (cls,lvs,ind) = - try + try get_source lp source with Not_found -> raise (CoercionError (NoSource source)) @@ -271,7 +258,7 @@ let add_new_coercion_core coef stre source target isid = raise (CoercionError NotUniform); let clt = try - get_target tg ind + get_target tg ind with Not_found -> raise (CoercionError NoTarget) in @@ -304,7 +291,7 @@ let try_add_new_identity_coercion id stre ~source ~target = let try_add_new_coercion_with_source ref stre ~source = try_add_new_coercion_core ref stre (Some source) None false -let add_coercion_hook stre ref = +let add_coercion_hook stre ref = try_add_new_coercion ref stre; Flags.if_verbose message (string_of_qualid (shortest_qualid_of_global Idset.empty ref) diff --git a/toplevel/class.mli b/toplevel/class.mli index 98ed6a0d..3398e3fa 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: class.mli 10840 2008-04-23 21:29:34Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -22,7 +22,7 @@ open Nametab (* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion from [src] to [tg] *) -val try_add_new_coercion_with_target : global_reference -> locality -> +val try_add_new_coercion_with_target : global_reference -> locality -> source:cl_typ -> target:cl_typ -> unit (* [try_add_new_coercion ref s] declares [ref], assumed to be of type diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 1a1640a4..90daca12 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: classes.ml 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Names @@ -34,36 +34,35 @@ open Entries let typeclasses_db = "typeclass_instances" -let qualid_of_con c = - Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c)) - -let set_rigid c = +let set_typeclass_transparency c b = Auto.add_hints false [typeclasses_db] - (Vernacexpr.HintsTransparency ([qualid_of_con c], false)) - + (Auto.HintsTransparencyEntry ([c], b)) + let _ = - Typeclasses.register_add_instance_hint + Typeclasses.register_add_instance_hint (fun inst pri -> - Flags.silently (fun () -> - Auto.add_hints false [typeclasses_db] - (Vernacexpr.HintsResolve - [pri, false, CAppExpl (dummy_loc, (None, qualid_of_con inst), [])])) ()) + Flags.silently (fun () -> + Auto.add_hints false [typeclasses_db] + (Auto.HintsResolveEntry + [pri, false, constr_of_global inst])) ()); + Typeclasses.register_set_typeclass_transparency set_typeclass_transparency + +let declare_class g = + match global g with + | ConstRef x -> Typeclasses.add_constant_class x + | IndRef x -> Typeclasses.add_inductive_class x + | _ -> user_err_loc (loc_of_reference g, "declare_class", + Pp.str"Unsupported class type, only constants and inductives are allowed") -let declare_instance_cst glob con = - let instance = Typeops.type_of_constant (Global.env ()) con in +let declare_instance glob g = + let c = global g in + let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some tc -> add_instance (new_instance tc None glob con) - | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.") + | Some tc -> add_instance (new_instance tc None glob c) + | None -> user_err_loc (loc_of_reference g, "declare_instance", + Pp.str "Constant does not build instances of a declared type class.") -let declare_instance glob idl = - let con = - try (match global (Ident idl) with - | ConstRef x -> x - | _ -> raise Not_found) - with _ -> error "Instance definition not found." - in declare_instance_cst glob con - let mismatched_params env n m = mismatched_ctx_inst env Parameters n m let mismatched_props env n m = mismatched_ctx_inst env Properties n m @@ -71,54 +70,53 @@ type binder_list = (identifier located * bool * constr_expr) list (* Calls to interpretation functions. *) -let interp_type_evars evdref env ?(impls=([],[])) typ = - let typ' = intern_gen true ~impls (Evd.evars_of !evdref) env typ in +let interp_type_evars evdref env ?(impls=empty_internalization_env) typ = + let typ' = intern_gen true ~impls !evdref env typ in let imps = Implicit_quantifiers.implicits_of_rawterm typ' in imps, Pretyping.Default.understand_tcc_evars evdref env Pretyping.IsType typ' - + (* Declare everything in the parameters as implicit, and the class instance as well *) open Topconstr - -let type_ctx_instance isevars env ctx inst subst = - let (s, _) = - List.fold_left2 - (fun (subst, instctx) (na, b, t) ce -> - let t' = substl subst t in - let c' = - match b with - | None -> interp_casted_constr_evars isevars env ce t' - | Some b -> substl subst b - in - let d = na, Some c', t' in - c' :: subst, d :: instctx) - (subst, []) (List.rev ctx) inst - in s + +let type_ctx_instance evars env ctx inst subst = + let rec aux (subst, instctx) l = function + (na, b, t) :: ctx -> + let t' = substl subst t in + let c', l = + match b with + | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l + | Some b -> substl subst b, l + in + let d = na, Some c', t' in + aux (c' :: subst, d :: instctx) l ctx + | [] -> subst + in aux (subst, []) inst (List.rev ctx) let refine_ref = ref (fun _ -> assert(false)) let id_of_class cl = match cl.cl_impl with | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l - | IndRef (kn,i) -> + | IndRef (kn,i) -> let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in mip.(0).Declarations.mind_typename | _ -> assert false - + open Pp let ($$) g f = fun x -> g (f x) - -let instance_hook k pri global imps ?hook cst = + +let instance_hook k pri global imps ?hook cst = let inst = Typeclasses.new_instance k pri global cst in - Impargs.maybe_declare_manual_implicits false (ConstRef cst) ~enriching:false imps; + Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; Typeclasses.add_instance inst; (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k pri global imps ?hook id term termtype = - let cdecl = + let cdecl = let kind = IsDefinition Instance in - let entry = + let entry = { const_entry_body = term; const_entry_type = Some termtype; const_entry_opaque = false; @@ -126,137 +124,159 @@ let declare_instance_constant k pri global imps ?hook id term termtype = in DefinitionEntry entry, kind in let kn = Declare.declare_constant id cdecl in - Flags.if_verbose Command.definition_message id; - instance_hook k pri global imps ?hook kn; + Declare.definition_message id; + instance_hook k pri global imps ?hook (ConstRef kn); id -let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) - ?(tac:Proof_type.tactic option) ?(hook:(Names.constant -> unit) option) pri = +let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props + ?(generalize=true) + ?(tac:Proof_type.tactic option) ?(hook:(global_reference -> unit) option) pri = let env = Global.env() in - let isevars = ref (Evd.create_evar_defs Evd.empty) in - let tclass = + let evars = ref Evd.empty in + let tclass, ids = match bk with | Implicit -> Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false - (fun avoid (clname, (id, _, t)) -> - match clname with - | Some (cl, b) -> + (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> let t = CHole (Util.dummy_loc, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) cl - | Explicit -> cl + | Explicit -> cl, Idset.empty in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in - let k, ctx', imps, subst = - let c = Command.generalize_constr_expr tclass ctx in - let imps, c' = interp_type_evars isevars env c in - let ctx, c = decompose_prod_assum c' in - let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in - cl, ctx, imps, List.rev args + let k, cty, ctx', ctx, len, imps, subst = + let (env', ctx), imps = interp_context_evars evars env ctx in + let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in + let len = List.length ctx in + let imps = imps @ Impargs.lift_implicits len imps' in + let ctx', c = decompose_prod_assum c' in + let ctx'' = ctx' @ ctx in + let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in + let _, args = + List.fold_right (fun (na, b, t) (args, args') -> + match b with + | None -> (List.tl args, List.hd args :: args') + | Some b -> (args, substl args' b :: args')) + (snd cl.cl_context) (args, []) + in + cl, c', ctx', ctx, len, imps, args in - let id = + let id = match snd instid with - Name id -> + Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); id - | Anonymous -> + | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in - Termops.next_global_ident_away false i (Termops.ids_of_context env) + Namegen.next_global_ident_away i (Termops.ids_of_context env) in - let env' = push_rel_context ctx' env in - isevars := Evarutil.nf_evar_defs !isevars; - isevars := resolve_typeclasses env !isevars; - let sigma = Evd.evars_of !isevars in + let env' = push_rel_context ctx env in + evars := Evarutil.nf_evar_map !evars; + evars := resolve_typeclasses env !evars; + let sigma = !evars in let subst = List.map (Evarutil.nf_evar sigma) subst in - if Lib.is_modtype () then + if abstract then begin + if not (Lib.is_modtype ()) then + error "Declare Instance while not in Module Type."; let _, ty_constr = instance_constructor k (List.rev subst) in - let termtype = - let t = it_mkProd_or_LetIn ty_constr ctx' in - Evarutil.nf_isevar !isevars t + let termtype = + let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in + Evarutil.nf_evar !evars t in - Evarutil.check_evars env Evd.empty !isevars termtype; + Evarutil.check_evars env Evd.empty !evars termtype; let cst = Declare.declare_internal_constant id (Entries.ParameterEntry (termtype,false), Decl_kinds.IsAssumption Decl_kinds.Logical) - in instance_hook k None false imps ?hook cst; id + in instance_hook k None false imps ?hook (ConstRef cst); id end else begin - let props = + let props = match props with - | CRecord (loc, _, fs) -> - if List.length fs > List.length k.cl_props then + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; - fs - | _ -> - if List.length k.cl_props <> 1 then - errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") - else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] + Inl fs + | _ -> Inr props in - let subst = - match k.cl_props with - | [(na,b,ty)] -> - let term = match props with [] -> CHole (Util.dummy_loc, None) - | [(_,f)] -> f | _ -> assert false in - let ty' = substl subst ty in - let c = interp_casted_constr_evars isevars env' term ty' in - c :: subst - | _ -> - let props, rest = + let subst = + match props with + | Inr term -> + let c = interp_casted_constr_evars evars env' term cty in + Inr (c, subst) + | Inl props -> + let get_id = + function + | Ident id' -> id' + | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled") + in + let props, rest = List.fold_left - (fun (props, rest) (id,b,_) -> - try - let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in - let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); - c :: props, rest' - with Not_found -> - (CHole (Util.dummy_loc, None) :: props), rest) + (fun (props, rest) (id,b,_) -> + if b = None then + try + let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in + let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in + let (loc, mid) = get_id loc_mid in + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + c :: props, rest' + with Not_found -> + (CHole (Util.dummy_loc, None) :: props), rest + else props, rest) ([], props) k.cl_props in - if rest <> [] then - unbound_method env' k.cl_impl (fst (List.hd rest)) + if rest <> [] then + unbound_method env' k.cl_impl (get_id (fst (List.hd rest))) else - type_ctx_instance isevars env' k.cl_props props subst - in - let subst = List.fold_left2 - (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') - [] subst (k.cl_props @ snd k.cl_context) - in - let app, ty_constr = instance_constructor k subst in - let termtype = - let t = it_mkProd_or_LetIn ty_constr ctx' in - Evarutil.nf_isevar !isevars t + Inl (type_ctx_instance evars env' k.cl_props props subst) + in + evars := Evarutil.nf_evar_map !evars; + let term, termtype = + match subst with + | Inl subst -> + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') + [] subst (k.cl_props @ snd k.cl_context) + in + let app, ty_constr = instance_constructor k subst in + let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in + let term = Termops.it_mkLambda_or_LetIn app (ctx' @ ctx) in + term, termtype + | Inr (def, subst) -> + let termtype = it_mkProd_or_LetIn cty ctx in + let term = Termops.it_mkLambda_or_LetIn def ctx in + term, termtype in - let term = Termops.it_mkLambda_or_LetIn app ctx' in - isevars := Evarutil.nf_evar_defs !isevars; - let term = Evarutil.nf_isevar !isevars term in - let evm = Evd.evars_of (undefined_evars !isevars) in - Evarutil.check_evars env Evd.empty !isevars termtype; - if evm = Evd.empty then + let termtype = Evarutil.nf_evar !evars termtype in + let term = Evarutil.nf_evar !evars term in + let evm = undefined_evars !evars in + Evarutil.check_evars env Evd.empty !evars termtype; + if Evd.is_empty evm then declare_instance_constant k pri global imps ?hook id term termtype else begin - isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !isevars; + evars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !evars; let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in Flags.silently (fun () -> - Command.start_proof id kind termtype - (fun _ -> function ConstRef cst -> instance_hook k pri global imps ?hook cst - | _ -> assert false); - if props <> [] then - Pfedit.by (* (Refiner.tclTHEN (Refiner.tclEVARS (Evd.evars_of !isevars)) *) - (!refine_ref (evm, term)); + Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook); + if props <> Inl [] then + Pfedit.by (* (Refiner.tclTHEN (Refiner.tclEVARS ( !isevars)) *) + (!refine_ref (evm, term)) + else if Flags.is_auto_intros () then + Pfedit.by (Refiner.tclDO len Tactics.intro); (match tac with Some tac -> Pfedit.by tac | None -> ())) (); Flags.if_verbose (msg $$ Printer.pr_open_subgoals) (); id end end - + let named_of_rel_context l = - let acc, ctx = - List.fold_right + let acc, ctx = + List.fold_right (fun (na, b, t) (subst, ctx) -> let id = match na with Anonymous -> raise (Invalid_argument "named_of_rel_context") | Name id -> id in let d = (id, Option.map (substl subst) b, substl subst t) in @@ -274,42 +294,33 @@ let rec list_filter_map f = function let context ?(hook=fun _ -> ()) l = let env = Global.env() in - let evars = ref (Evd.create_evar_defs Evd.empty) in + let evars = ref Evd.empty in let (env', fullctx), impls = interp_context_evars evars env l in - let fullctx = Evarutil.nf_rel_context_evar (Evd.evars_of !evars) fullctx in + let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx; - let ctx = try named_of_rel_context fullctx with _ -> + let ctx = try named_of_rel_context fullctx with _ -> error "Anonymous variables not allowed in contexts." in - let env = push_named_context ctx env in - let keeps = - List.fold_left (fun acc (id,_,t) -> - match class_of_constr t with - | None -> acc - | Some _ -> List.map pi1 (keep_hyps env (Idset.singleton id)) :: acc) - [] ctx - in - List.iter (function (id,_,t) -> - if Lib.is_modtype () then - let cst = Declare.declare_internal_constant id - (ParameterEntry (t,false), IsAssumption Logical) - in - match class_of_constr t with - | Some tc -> - add_instance (Typeclasses.new_instance tc None false cst); - hook (ConstRef cst) - | None -> () - else ( - let impl = List.exists (fun (x,_) -> - match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls - and keep = - let l = list_filter_map (fun ids -> if List.mem id ids then Some ids else None) keeps in - List.concat l - in - Command.declare_one_assumption false (Local (* global *), Definitional) t - [] impl (* implicit *) keep (* always kept *) false (* inline *) (dummy_loc, id); - match class_of_constr t with - | None -> () - | Some tc -> hook (VarRef id))) - (List.rev ctx) + let fn (id, _, t) = + if Lib.is_modtype () && not (Lib.sections_are_opened ()) then + let cst = Declare.declare_internal_constant id + (ParameterEntry (t,false), IsAssumption Logical) + in + match class_of_constr t with + | Some tc -> + add_instance (Typeclasses.new_instance tc None false (ConstRef cst)); + hook (ConstRef cst) + | None -> () + else ( + let impl = List.exists + (fun (x,_) -> + match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls + in + Command.declare_assumption false (Local (* global *), Definitional) t + [] impl (* implicit *) false (* inline *) (dummy_loc, id); + match class_of_constr t with + | None -> () + | Some tc -> hook (VarRef id)) + in List.iter fn (List.rev ctx) + diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 1bbf29a6..b8b104d4 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Names @@ -21,6 +21,7 @@ open Topconstr open Util open Typeclasses open Implicit_quantifiers +open Libnames (*i*) (* Errors *) @@ -29,39 +30,48 @@ val mismatched_params : env -> constr_expr list -> rel_context -> 'a val mismatched_props : env -> constr_expr list -> rel_context -> 'a +(* Post-hoc class declaration. *) + +val declare_class : reference -> unit + (* Instance declaration *) -val declare_instance : bool -> identifier located -> unit +val declare_instance : bool -> reference -> unit val declare_instance_constant : typeclass -> int option -> (* priority *) bool -> (* globality *) Impargs.manual_explicitation list -> (* implicits *) - ?hook:(Names.constant -> unit) -> + ?hook:(Libnames.global_reference -> unit) -> identifier -> (* name *) Term.constr -> (* body *) Term.types -> (* type *) Names.identifier - -val new_instance : + +val new_instance : + ?abstract:bool -> (* Not abstract by default. *) ?global:bool -> (* Not global by default. *) local_binder list -> typeclass_constraint -> constr_expr -> ?generalize:bool -> ?tac:Proof_type.tactic -> - ?hook:(constant -> unit) -> + ?hook:(Libnames.global_reference -> unit) -> int option -> identifier +(* Setting opacity *) + +val set_typeclass_transparency : evaluable_global_reference -> bool -> unit + (* For generation on names based on classes only *) val id_of_class : typeclass -> identifier -(* Context command *) +(* Context command *) -val context : ?hook:(Libnames.global_reference -> unit) -> +val context : ?hook:(Libnames.global_reference -> unit) -> local_binder list -> unit (* Forward ref for refine *) diff --git a/toplevel/command.ml b/toplevel/command.ml index 05a22829..700efc99 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -6,63 +6,32 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: command.ml 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) open Pp open Util open Flags open Term open Termops -open Declarations open Entries -open Inductive open Environ -open Reduction open Redexpr open Declare -open Nametab open Names open Libnames open Nameops open Topconstr -open Library -open Libobject open Constrintern -open Proof_type -open Tacmach -open Safe_typing open Nametab open Impargs -open Typeops open Reductionops open Indtypes -open Vernacexpr open Decl_kinds open Pretyping open Evarutil open Evarconv open Notation -open Goptions -open Mod_subst -open Evd -open Decls - -let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,default_binder_kind,a,b)) -let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,default_binder_kind,a,b)) - -let rec abstract_constr_expr c = function - | [] -> c - | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl) - | LocalRawAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> mkLambdaC([x],k,t,b)) idl - (abstract_constr_expr c bl) - -let rec generalize_constr_expr c = function - | [] -> c - | LocalRawDef (x,b)::bl -> mkLetInC(x,b,generalize_constr_expr c bl) - | LocalRawAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> mkProdC([x],k,t,b)) idl - (generalize_constr_expr c bl) +open Indschemes let rec under_binders env f n c = if n = 0 then f env Evd.empty c else @@ -73,14 +42,6 @@ let rec under_binders env f n c = mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c) | _ -> assert false -let rec destSubCast c = match kind_of_term c with - | Lambda (x,t,c) -> - let (b,u) = destSubCast c in mkLambda (x,t,b), mkProd (x,t,u) - | LetIn (x,b,t,c) -> - let (d,u) = destSubCast c in mkLetIn (x,b,t,d), mkLetIn (x,b,t,u) - | Cast (b,_, u) -> (b,u) - | _ -> assert false - let rec complete_conclusion a cs = function | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c) | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c) @@ -98,92 +59,86 @@ let rec complete_conclusion a cs = function (* 1| Constant definitions *) -let definition_message id = - if_verbose message ((string_of_id id) ^ " is defined") +let red_constant_entry n ce = function + | None -> ce + | Some red -> + let body = ce.const_entry_body in + { ce with const_entry_body = + under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body } -let constant_entry_of_com (bl,com,comtypopt,opacity,boxed) = +let interp_definition boxed bl red_option c ctypopt = let env = Global.env() in - match comtypopt with - None -> - let b = abstract_constr_expr com bl in - let b, imps = interp_constr_evars_impls env b in - imps, - { const_entry_body = b; + let evdref = ref Evd.empty in + let (env_bl, ctx), imps1 = + interp_context_evars ~fail_anonymous:false evdref env bl in + let imps,ce = + match ctypopt with + None -> + let c, imps2 = interp_constr_evars_impls ~evdref ~fail_evar:false env_bl c in + let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in + check_evars env Evd.empty !evdref body; + imps1@imps2, + { const_entry_body = body; const_entry_type = None; - const_entry_opaque = opacity; + const_entry_opaque = false; const_entry_boxed = boxed } - | Some comtyp -> - (* We use a cast to avoid troubles with evars in comtyp *) - (* that can only be resolved knowing com *) - let b = abstract_constr_expr (mkCastC (com, Rawterm.CastConv (DEFAULTcast,comtyp))) bl in - let b, imps = interp_constr_evars_impls env b in - let (body,typ) = destSubCast b in - imps, + | Some ctyp -> + let ty, impls = interp_type_evars_impls ~evdref ~fail_evar:false env_bl ctyp in + let c, imps2 = interp_casted_constr_evars_impls ~evdref ~fail_evar:false env_bl c ty in + let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in + let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in + check_evars env Evd.empty !evdref body; + check_evars env Evd.empty !evdref typ; + imps1@imps2, { const_entry_body = body; const_entry_type = Some typ; - const_entry_opaque = opacity; + const_entry_opaque = false; const_entry_boxed = boxed } + in + red_constant_entry (rel_context_length ctx) ce red_option, imps -let red_constant_entry bl ce = function - | None -> ce - | Some red -> - let body = ce.const_entry_body in - { ce with const_entry_body = - under_binders (Global.env()) (fst (reduction_of_red_expr red)) - (local_binders_length bl) - body } - -let declare_global_definition ident ce local imps = - let kn = declare_constant ident (DefinitionEntry ce,IsDefinition Definition) in +let declare_global_definition ident ce local k imps = + let kn = declare_constant ident (DefinitionEntry ce,IsDefinition k) in let gr = ConstRef kn in maybe_declare_manual_implicits false gr imps; if local = Local && Flags.is_verbose() then msg_warning (pr_id ident ++ str" is declared as a global definition"); definition_message ident; + Autoinstance.search_declaration (ConstRef kn); gr let declare_definition_hook = ref ignore let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook -let declare_definition ident (local,boxed,dok) bl red_option c typopt hook = - let imps, ce = constant_entry_of_com (bl,c,typopt,false,boxed) in - let ce' = red_constant_entry bl ce red_option in - !declare_definition_hook ce'; +let declare_definition ident (local,k) ce imps hook = + !declare_definition_hook ce; let r = match local with | Local when Lib.sections_are_opened () -> let c = - SectionLocalDef(ce'.const_entry_body,ce'.const_entry_type,false) in - let _ = declare_variable ident (Lib.cwd(),c,IsDefinition Definition) in + SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in + let _ = declare_variable ident (Lib.cwd(),c,IsDefinition k) in definition_message ident; - if Pfedit.refining () then - Flags.if_verbose msg_warning - (str"Local definition " ++ pr_id ident ++ + if Pfedit.refining () then + Flags.if_verbose msg_warning + (str"Local definition " ++ pr_id ident ++ str" is not visible from current goals"); VarRef ident | (Global|Local) -> - declare_global_definition ident ce' local imps in + declare_global_definition ident ce local k imps in hook local r -let syntax_definition ident (vars,c) local onlyparse = - let ((vars,_),pat) = interp_aconstr [] (vars,[]) c in - let onlyparse = onlyparse or Metasyntax.is_not_printable pat in - Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) - (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) -let assumption_message id = - if_verbose message ((string_of_id id) ^ " is assumed") - -let declare_one_assumption is_coe (local,kind) c imps impl keep nl (_,ident) = +let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) = let r = match local with | Local when Lib.sections_are_opened () -> - let _ = - declare_variable ident - (Lib.cwd(), SectionLocalAssum (c,impl,keep), IsAssumption kind) in + let _ = + declare_variable ident + (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in assumption_message ident; - if is_verbose () & Pfedit.refining () then - msgerrnl (str"Warning: Variable " ++ pr_id ident ++ + if is_verbose () & Pfedit.refining () then + msgerrnl (str"Warning: Variable " ++ pr_id ident ++ str" is not visible from current goals"); VarRef ident | (Global|Local) -> @@ -195,283 +150,26 @@ let declare_one_assumption is_coe (local,kind) c imps impl keep nl (_,ident) = if local=Local & Flags.is_verbose () then msg_warning (pr_id ident ++ str" is declared as a parameter" ++ str" because it is at a global level"); + Autoinstance.search_declaration (ConstRef kn); gr in if is_coe then Class.try_add_new_coercion r local -let declare_assumption_hook = ref ignore -let set_declare_assumption_hook = (:=) declare_assumption_hook - -let declare_assumption idl is_coe k bl c impl keep nl = - if not (Pfedit.refining ()) then - let c = generalize_constr_expr c bl in - let env = Global.env () in - let c', imps = interp_type_evars_impls env c in - !declare_assumption_hook c'; - List.iter (declare_one_assumption is_coe k c' imps impl keep nl) idl - else - errorlabstrm "Command.Assumption" - (str "Cannot declare an assumption while in proof editing mode.") - -(* 3a| Elimination schemes for mutual inductive definitions *) - -open Indrec -open Inductiveops +let declare_assumptions_hook = ref ignore +let set_declare_assumptions_hook = (:=) declare_assumptions_hook +let interp_assumption bl c = + let c = prod_constr_expr c bl in + let env = Global.env () in + interp_type_evars_impls env c -let non_type_eliminations = - [ (InProp,elimination_suffix InProp); - (InSet,elimination_suffix InSet) ] +let declare_assumptions idl is_coe k c imps impl_is_on nl = + !declare_assumptions_hook c; + List.iter (declare_assumption is_coe k c imps impl_is_on nl) idl -let declare_one_elimination ind = - let (mib,mip) = Global.lookup_inductive ind in - let mindstr = string_of_id mip.mind_typename in - let declare s c t = - let id = id_of_string s in - let kn = Declare.declare_internal_constant id - (DefinitionEntry - { const_entry_body = c; - const_entry_type = t; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() }, - Decl_kinds.IsDefinition Definition) in - definition_message id; - kn - in - let env = Global.env () in - let sigma = Evd.empty in - let elim_scheme = Indrec.build_indrec env sigma ind in - let npars = - (* if a constructor of [ind] contains a recursive call, the scheme - is generalized only wrt recursively uniform parameters *) - if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) - then - mib.mind_nparams_rec - else - mib.mind_nparams in - let make_elim s = Indrec.instantiate_indrec_scheme s npars elim_scheme in - let kelim = elim_sorts (mib,mip) in - (* in case the inductive has a type elimination, generates only one - induction scheme, the other ones share the same code with the - apropriate type *) - if List.mem InType kelim then - let elim = make_elim (new_sort_in_family InType) in - let cte = declare (mindstr^(Indrec.elimination_suffix InType)) elim None in - let c = mkConst cte in - let t = type_of_constant (Global.env()) cte in - List.iter (fun (sort,suff) -> - let (t',c') = - Indrec.instantiate_type_indrec_scheme (new_sort_in_family sort) - npars c t in - let _ = declare (mindstr^suff) c' (Some t') in ()) - non_type_eliminations - else (* Impredicative or logical inductive definition *) - List.iter - (fun (sort,suff) -> - if List.mem sort kelim then - let elim = make_elim (new_sort_in_family sort) in - let _ = declare (mindstr^suff) elim None in ()) - non_type_eliminations - -(* bool eq declaration flag && eq dec declaration flag *) -let eq_flag = ref false -let _ = - declare_bool_option - { optsync = true; - optname = "automatic declaration of boolean equality"; - optkey = (SecondaryTable ("Equality","Scheme")); - optread = (fun () -> !eq_flag) ; - optwrite = (fun b -> eq_flag := b) } - -(* boolean equality *) -let (inScheme,outScheme) = - declare_object {(default_object "EQSCHEME") with - cache_function = Ind_tables.cache_scheme; - load_function = (fun _ -> Ind_tables.cache_scheme); - subst_function = Auto_ind_decl.subst_in_constr; - export_function = Ind_tables.export_scheme } - -let declare_eq_scheme sp = - let mib = Global.lookup_mind sp in - let nb_ind = Array.length mib.mind_packets in - let eq_array = Auto_ind_decl.make_eq_scheme sp in - try - for i=0 to (nb_ind-1) do - let cpack = Array.get mib.mind_packets i in - let nam = id_of_string ((string_of_id cpack.mind_typename)^"_beq") - in - let cst_entry = {const_entry_body = eq_array.(i); - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() } - in - let cst_decl = (DefinitionEntry cst_entry),(IsDefinition Definition) - in - let cst = Declare.declare_constant nam cst_decl in - Lib.add_anonymous_leaf (inScheme ((sp,i),mkConst cst)); - definition_message nam - done - with Not_found -> - error "Your type contains Parameters without a boolean equality." - -(* decidability of eq *) - - -let (inBoolLeib,outBoolLeib) = - declare_object {(default_object "BOOLLIEB") with - cache_function = Ind_tables.cache_bl; - load_function = (fun _ -> Ind_tables.cache_bl); - subst_function = Auto_ind_decl.subst_in_constr; - export_function = Ind_tables.export_bool_leib } - -let (inLeibBool,outLeibBool) = - declare_object {(default_object "LIEBBOOL") with - cache_function = Ind_tables.cache_lb; - load_function = (fun _ -> Ind_tables.cache_lb); - subst_function = Auto_ind_decl.subst_in_constr; - export_function = Ind_tables.export_leib_bool } - -let (inDec,outDec) = - declare_object {(default_object "EQDEC") with - cache_function = Ind_tables.cache_dec; - load_function = (fun _ -> Ind_tables.cache_dec); - subst_function = Auto_ind_decl.subst_in_constr; - export_function = Ind_tables.export_dec_proof } - -let start_hook = ref ignore -let set_start_hook = (:=) start_hook - -let start_proof id kind c ?init_tac ?(compute_guard=false) hook = - let sign = Global.named_context () in - let sign = clear_proofs sign in - !start_hook c; - Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook - -let adjust_guardness_conditions const = - (* Try all combinations... not optimal *) - match kind_of_term const.const_entry_body with - | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> - let possible_indexes = - List.map (fun c -> - interval 0 (List.length (fst (Sign.decompose_lam_assum c)))) - (Array.to_list fixdefs) in - let indexes = search_guard dummy_loc (Global.env()) possible_indexes fixdecls in - { const with const_entry_body = mkFix ((indexes,0),fixdecls) } - | c -> const - -let save id const do_guard (locality,kind) hook = - let const = if do_guard then adjust_guardness_conditions const else const in - let {const_entry_body = pft; - const_entry_type = tpo; - const_entry_opaque = opacity } = const in - let k = logical_kind_of_goal_kind kind in - let l,r = match locality with - | Local when Lib.sections_are_opened () -> - let c = SectionLocalDef (pft, tpo, opacity) in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Local, VarRef id) - | Local | Global -> - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) in - Pfedit.delete_current_proof (); - definition_message id; - hook l r - -let save_hook = ref ignore -let set_save_hook f = save_hook := f - -let save_named opacity = - let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in - let const = { const with const_entry_opaque = opacity } in - save id const do_guard persistence hook - -let make_eq_decidability ind = - (* fetching data *) - let mib = Global.lookup_mind (fst ind) in - let nparams = mib.mind_nparams in - let nparrec = mib.mind_nparams_rec in - let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in - let proof_name = (string_of_id( - Array.get mib.mind_packets (snd ind)).mind_typename)^"_eq_dec" in - let bl_name =(string_of_id( - Array.get mib.mind_packets (snd ind)).mind_typename)^"_dec_bl" in - let lb_name =(string_of_id( - Array.get mib.mind_packets (snd ind)).mind_typename)^"_dec_lb" in - (* main calls*) - if Ind_tables.check_bl_proof ind - then (message (bl_name^" is already declared.")) - else ( - start_proof (id_of_string bl_name) - (Global,Proof Theorem) - (Auto_ind_decl.compute_bl_goal ind lnamesparrec nparrec) - (fun _ _ -> ()); - Auto_ind_decl.compute_bl_tact ind lnamesparrec nparrec; - save_named true; - Lib.add_anonymous_leaf - (inBoolLeib (ind,mkConst (Lib.make_con (id_of_string bl_name)))) -(* definition_message (id_of_string bl_name) *) - ); - if Ind_tables.check_lb_proof ind - then (message (lb_name^" is already declared.")) - else ( - start_proof (id_of_string lb_name) - (Global,Proof Theorem) - (Auto_ind_decl.compute_lb_goal ind lnamesparrec nparrec) - ( fun _ _ -> ()); - Auto_ind_decl.compute_lb_tact ind lnamesparrec nparrec; - save_named true; - Lib.add_anonymous_leaf - (inLeibBool (ind,mkConst (Lib.make_con (id_of_string lb_name)))) -(* definition_message (id_of_string lb_name) *) - ); - if Ind_tables.check_dec_proof ind - then (message (proof_name^" is already declared.")) - else ( - start_proof (id_of_string proof_name) - (Global,Proof Theorem) - (Auto_ind_decl.compute_dec_goal ind lnamesparrec nparrec) - ( fun _ _ -> ()); - Auto_ind_decl.compute_dec_tact ind lnamesparrec nparrec; - save_named true; - Lib.add_anonymous_leaf - (inDec (ind,mkConst (Lib.make_con (id_of_string proof_name)))) -(* definition_message (id_of_string proof_name) *) - ) - -(* end of automated definition on ind*) - -let declare_eliminations sp = - let mib = Global.lookup_mind sp in - if mib.mind_finite then begin - if (!eq_flag) then (declare_eq_scheme sp); - for i = 0 to Array.length mib.mind_packets - 1 do - declare_one_elimination (sp,i); - try - if (!eq_flag) then (make_eq_decidability (sp,i)) - with _ -> - Pfedit.delete_current_proof(); - message "Error while computing decidability scheme. Please report." - done; - end +(* 3a| Elimination schemes for mutual inductive definitions *) (* 3b| Mutual inductive definitions *) -let compute_interning_datas env ty l nal typl impll = - let mk_interning_data na typ impls = - let idl, impl = - let impl = - compute_implicits_with_manual env typ (is_implicit_args ()) impls - in - let sub_impl,_ = list_chop (List.length l) impl in - let sub_impl' = List.filter is_status_implicit sub_impl in - (List.map name_of_implicit sub_impl', impl) - in - (na, (ty, idl, impl, compute_arguments_scope typ)) in - (l, list_map3 mk_interning_data nal typl impll) - -let declare_interning_data (_,impls) (df,c,scope) = - silently (Metasyntax.add_notation_interpretation df impls c) scope - let push_named_types env idl tl = List.fold_left2 (fun env id t -> Environ.push_named (id,None,t) env) env idl tl @@ -480,16 +178,19 @@ let push_types env idl tl = List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env) env idl tl -type inductive_expr = { +type structured_one_inductive_expr = { ind_name : identifier; ind_arity : constr_expr; ind_lc : (identifier * constr_expr) list } +type structured_inductive_expr = + local_binder list * structured_one_inductive_expr list + let minductive_message = function | [] -> error "No inductive definition." | [x] -> (pr_id x ++ str " is defined") - | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++ + | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ spc () ++ str "are defined") let check_all_names_different indl = @@ -503,15 +204,15 @@ let check_all_names_different indl = if l <> [] then raise (InductiveError (SameNamesOverlap l)) let mk_mltype_data evdref env assums arity indname = - let is_ml_type = is_sort env (evars_of !evdref) arity in + let is_ml_type = is_sort env !evdref arity in (is_ml_type,indname,assums) let prepare_param = function - | (na,None,t) -> out_name na, LocalAssum t + | (na,None,t) -> out_name na, LocalAssum t | (na,Some b,_) -> out_name na, LocalDef b let interp_ind_arity evdref env ind = - interp_type_evars evdref env ind.ind_arity + interp_type_evars_impls ~evdref env ind.ind_arity let interp_cstrs evdref env impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in @@ -521,12 +222,12 @@ let interp_cstrs evdref env impls mldata arity ind = let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls ~evdref env ~impls) ctyps') in (cnames, ctyps'', cimpls) -let interp_mutual paramsl indl notations finite = +let interp_mutual_inductive (paramsl,indl) notations finite = check_all_names_different indl; let env0 = Global.env() in - let evdref = ref (Evd.create_evar_defs Evd.empty) in - let (env_params, ctx_params), userimpls = - interp_context_evars ~fail_anonymous:false evdref env0 paramsl + let evdref = ref Evd.empty in + let (env_params, ctx_params), userimpls = + interp_context_evars ~fail_anonymous:false evdref env0 paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in @@ -536,19 +237,20 @@ let interp_mutual paramsl indl notations finite = (* Interpret the arities *) let arities = List.map (interp_ind_arity evdref env_params) indl in - let fullarities = List.map (fun c -> it_mkProd_or_LetIn c ctx_params) arities in + let fullarities = List.map (fun (c, _) -> it_mkProd_or_LetIn c ctx_params) arities in let env_ar = push_types env0 indnames fullarities in let env_ar_params = push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) - let indimpls = List.map (fun _ -> userimpls) fullarities in - let impls = compute_interning_datas env0 Inductive params indnames fullarities indimpls in + let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (List.length userimpls) impls) arities in + let arities = List.map fst arities in + let impls = compute_full_internalization_env env0 Inductive params indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = - States.with_state_protection (fun () -> + States.with_state_protection (fun () -> (* Temporary declaration of notations and scopes *) - List.iter (declare_interning_data impls) notations; + List.iter (Metasyntax.set_notation_for_interpretation impls) notations; (* Interpret the constructor types *) list_map3 (interp_cstrs evdref env_ar_params impls) mldatas arities indl) () in @@ -556,7 +258,7 @@ let interp_mutual paramsl indl notations finite = (* Instantiate evars and check all are resolved *) let evd,_ = consider_remaining_unif_problems env_params !evdref in let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in - let sigma = evars_of evd in + let sigma = evd in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in let arities = List.map (nf_evar sigma) arities in @@ -565,7 +267,7 @@ let interp_mutual paramsl indl notations finite = List.iter (fun (_,ctyps,_) -> List.iter (check_evars env_ar_params Evd.empty evd) ctyps) constructors; - + (* Build the inductive entries *) let entries = list_map3 (fun ind arity (cnames,ctypes,cimpls) -> { mind_entry_typename = ind.ind_name; @@ -573,17 +275,17 @@ let interp_mutual paramsl indl notations finite = mind_entry_consnames = cnames; mind_entry_lc = ctypes }) indl arities constructors in - let impls = + let impls = let len = List.length ctx_params in - List.map (fun (_,_,impls) -> - userimpls, List.map (fun impls -> - userimpls @ (lift_implicits len impls)) impls) constructors + List.map2 (fun indimpls (_,_,cimpls) -> + indimpls, List.map (fun impls -> + userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors in (* Build the mutual inductive entry *) { mind_entry_params = List.map prepare_param ctx_params; - mind_entry_record = false; - mind_entry_finite = finite; - mind_entry_inds = entries }, + mind_entry_record = false; + mind_entry_finite = finite; + mind_entry_inds = entries }, impls let eq_constr_expr c1 c2 = @@ -604,7 +306,7 @@ let eq_local_binders bl1 bl2 = List.length bl1 = List.length bl2 && List.for_all2 eq_local_binder bl1 bl2 let extract_coercions indl = - let mkqid (_,((_,id),_)) = make_short_qualid id in + let mkqid (_,((_,id),_)) = qualid_of_ident id in let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) @@ -613,88 +315,64 @@ let extract_params indl = match paramsl with | [] -> anomaly "empty list of inductive types" | params::paramsl -> - if not (List.for_all (eq_local_binders params) paramsl) then error + if not (List.for_all (eq_local_binders params) paramsl) then error "Parameters should be syntactically the same for each inductive type."; params -let prepare_inductive ntnl indl = - let indl = - List.map (fun ((_,indname),_,ar,lc) -> { - ind_name = indname; - ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar; - ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc - }) indl in - List.fold_right Option.List.cons ntnl [], indl - - -let elim_flag = ref true -let _ = - declare_bool_option - { optsync = true; - optname = "automatic declaration of eliminations"; - optkey = (SecondaryTable ("Elimination","Schemes")); - optread = (fun () -> !elim_flag) ; - optwrite = (fun b -> elim_flag := b) } - -let declare_mutual_with_eliminations isrecord mie impls = +let extract_inductive indl = + List.map (fun ((_,indname),_,ar,lc) -> { + ind_name = indname; + ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar; + ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc + }) indl + +let extract_mutual_inductive_declaration_components indl = + let indl,ntnl = List.split indl in + let params = extract_params indl in + let coes = extract_coercions indl in + let indl = extract_inductive indl in + (params,indl), coes, List.flatten ntnl + +let declare_mutual_inductive_with_eliminations isrecord mie impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - let (_,kn) = declare_mind isrecord mie in - list_iter_i (fun i (indimpls, constrimpls) -> - let ind = (kn,i) in - maybe_declare_manual_implicits false (IndRef ind) indimpls; - list_iter_i - (fun j impls -> - maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) - constrimpls) + let (_,kn) = declare_mind isrecord mie in + let mind = Global.mind_of_delta (mind_of_kn kn) in + list_iter_i (fun i (indimpls, constrimpls) -> + let ind = (mind,i) in + Autoinstance.search_declaration (IndRef ind); + maybe_declare_manual_implicits false (IndRef ind) indimpls; + list_iter_i + (fun j impls -> +(* Autoinstance.search_declaration (ConstructRef (ind,j));*) + maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) + constrimpls) impls; - if_verbose ppnl (minductive_message names); - if !elim_flag then declare_eliminations kn; - kn + if_verbose ppnl (minductive_message names); + declare_default_schemes mind; + mind -let build_mutual l finite = - let indl,ntnl = List.split l in - let paramsl = extract_params indl in - let coes = extract_coercions indl in - let notations,indl = prepare_inductive ntnl indl in - let mie,impls = interp_mutual paramsl indl notations finite in - (* Declare the mutual inductive block with its eliminations *) - ignore (declare_mutual_with_eliminations false mie impls); +open Vernacexpr + +type one_inductive_impls = + Impargs.manual_explicitation list (* for inds *)* + Impargs.manual_explicitation list list (* for constrs *) + +type one_inductive_expr = + lident * local_binder list * constr_expr option * constructor_expr list + +let do_mutual_inductive indl finite = + let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in + (* Interpret the types *) + let mie,impls = interp_mutual_inductive indl ntns finite in + (* Declare the mutual inductive block with its associated schemes *) + ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls); (* Declare the possible notations of inductive types *) - List.iter (declare_interning_data ([],[])) notations; + List.iter Metasyntax.add_notation_interpretation ntns; (* Declare the coercions *) List.iter (fun qid -> Class.try_add_new_coercion (locate qid) Global) coes (* 3c| Fixpoints and co-fixpoints *) -let pr_rank = function - | 0 -> str "1st" - | 1 -> str "2nd" - | 2 -> str "3rd" - | n -> str ((string_of_int (n+1))^"th") - -let recursive_message indexes = function - | [] -> anomaly "no recursive definition" - | [id] -> pr_id 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_coma pr_id l ++ - spc () ++ str "are recursively defined" ++ - match indexes with - | Some a -> spc () ++ str "(decreasing respectively on " ++ - prlist_with_sep pr_coma pr_rank (Array.to_list a) ++ - str " arguments)" - | None -> mt ()) - -let corecursive_message _ = function - | [] -> error "No corecursive definition." - | [id] -> pr_id id ++ str " is corecursively defined" - | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++ - spc () ++ str "are corecursively defined") - -let recursive_message isfix = - if isfix=Fixpoint then recursive_message else corecursive_message - (* An (unoptimized) function that maps preorders to partial orders... Input: a list of associations (x,[y1;...;yn]), all yi distincts @@ -717,11 +395,11 @@ let rec partial_order = function | (z, Inr zge) when List.mem x zge -> (z, Inr (list_union zge xge')) | r -> r) res in (x,Inr xge')::res - | y::xge -> - let rec link y = + | y::xge -> + let rec link y = try match List.assoc y res with | Inl z -> link z - | Inr yge -> + | Inr yge -> if List.mem x yge then let res = List.remove_assoc y res in let res = List.map (function @@ -737,43 +415,41 @@ let rec partial_order = function browse res (list_add_set y (list_union xge' yge)) xge with Not_found -> browse res (list_add_set y xge') xge in link y - in browse (partial_order rest) [] xge + in browse (partial_order rest) [] xge -let non_full_mutual_message x xge y yge kind rest = - let reason = - if List.mem x yge then +let non_full_mutual_message x xge y yge isfix rest = + let reason = + if List.mem x yge then string_of_id y^" depends on "^string_of_id x^" but not conversely" - else if List.mem y xge then + else if List.mem y xge then string_of_id x^" depends on "^string_of_id y^" but not conversely" else string_of_id y^" and "^string_of_id x^" are not mutually dependent" in let e = if rest <> [] then "e.g.: "^reason else reason in - let k = if kind=Fixpoint then "fixpoint" else "cofixpoint" in + let k = if isfix then "fixpoint" else "cofixpoint" in let w = - if kind=Fixpoint then "Well-foundedness check may fail unexpectedly.\n" - else "" in - "Not a fully mutually defined "^k^"\n("^e^").\n"^w + if isfix + then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() + else mt () in + strbrk ("Not a fully mutually defined "^k) ++ fnl () ++ + strbrk ("("^e^").") ++ fnl () ++ w -let check_mutuality env kind fixl = +let check_mutuality env isfix fixl = let names = List.map fst fixl in let preorder = - List.map (fun (id,def) -> + List.map (fun (id,def) -> (id, List.filter (fun id' -> id<>id' & occur_var env id' def) names)) fixl in let po = partial_order preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with | (x,Inr xge)::(y,Inr yge)::rest -> - if_verbose warning (non_full_mutual_message x xge y yge kind rest) + if_verbose msg_warning (non_full_mutual_message x xge y yge isfix rest) | _ -> () -type fixpoint_kind = - | IsFixpoint of (identifier located option * recursion_order_expr) list - | IsCoFixpoint - -type fixpoint_expr = { +type structured_fixpoint_expr = { fix_name : identifier; fix_binders : local_binder list; - fix_body : constr_expr; + fix_body : constr_expr option; fix_type : constr_expr } @@ -784,9 +460,10 @@ let interp_fix_ccl evdref (env,_) fix = interp_type_evars evdref env fix.fix_type let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = - let env = push_rel_context ctx env_rec in - let body = interp_casted_constr_evars evdref env ~impls fix.fix_body ccl in - it_mkLambda_or_LetIn body ctx + Option.map (fun body -> + let env = push_rel_context ctx env_rec in + let body = interp_casted_constr_evars evdref env ~impls body ccl in + it_mkLambda_or_LetIn body ctx) fix.fix_body let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx @@ -799,9 +476,10 @@ let declare_fix boxed kind f def t imps = } in let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in let gr = ConstRef kn in - maybe_declare_manual_implicits false gr imps; - gr - + Autoinstance.search_declaration (ConstRef kn); + maybe_declare_manual_implicits false gr imps; + gr + let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in let names = List.map (fun id -> Name id) fixnames in @@ -809,454 +487,135 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs = (* Jump over let-bindings. *) -let rel_index n ctx = - list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) - -let rec unfold f b = - match f b with - | Some (x, b') -> x :: unfold f b' - | None -> [] - -let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = - match n with - | Some (loc, n) -> [rel_index n fixctx] - | None -> +let compute_possible_guardness_evidences na fix (ids,_) = + match index_of_annot fix.fix_binders na with + | Some i -> [i] + | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) - let len = List.length fixctx in - unfold (function x when x = len -> None - | n -> Some (n, succ n)) 0 + interval 0 (List.length ids - 1) + +type recursive_preentry = + identifier list * constr option list * types list -let interp_recursive fixkind l boxed = +let interp_recursive isfix fixl notations = let env = Global.env() in - let fixl, ntnl = List.split l in - let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in let fixnames = List.map (fun fix -> fix.fix_name) fixl in (* Interp arities allowing for unresolved types *) - let evdref = ref (Evd.create_evar_defs Evd.empty) in + let evdref = ref Evd.empty in let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let fixtypes = List.map (nf_evar (evars_of !evdref)) fixtypes in + let fixtypes = List.map (nf_evar !evdref) fixtypes in let env_rec = push_named_types env fixnames fixtypes in (* Get interpretation metadatas *) - let impls = compute_interning_datas env Recursive [] fixnames fixtypes fiximps in - let notations = List.fold_right Option.List.cons ntnl [] in + let impls = compute_full_internalization_env env Recursive [] fixnames fixtypes fiximps in (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - States.with_state_protection (fun () -> - List.iter (declare_interning_data impls) notations; + let fixdefs = + States.with_state_protection (fun () -> + List.iter (Metasyntax.set_notation_for_interpretation impls) notations; list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) () in (* Instantiate evars and check all are resolved *) let evd,_ = consider_remaining_unif_problems env_rec !evdref in - let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in - let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in + let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in + let fixtypes = List.map (nf_evar evd) fixtypes in + let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in - List.iter (check_evars env_rec Evd.empty evd) fixdefs; + List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs; List.iter (check_evars env Evd.empty evd) fixtypes; - check_mutuality env kind (List.combine fixnames fixdefs); + if not (List.mem None fixdefs) then begin + let fixdefs = List.map Option.get fixdefs in + check_mutuality env isfix (List.combine fixnames fixdefs) + end; (* Build the fix declaration block *) - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let indexes, fixdecls = - match fixkind with - | IsFixpoint wfl -> - let possible_indexes = - list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in - let indexes = search_guard dummy_loc env possible_indexes fixdecls in - Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l - | IsCoFixpoint -> - None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l - in - - (* Declare the recursive definitions *) - ignore (list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps); - if_verbose ppnl (recursive_message kind indexes fixnames); - + (fixnames,fixdefs,fixtypes),List.combine fixctxnames fiximps + +let interp_fixpoint = interp_recursive true +let interp_cofixpoint = interp_recursive false + +let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = + if List.mem None fixdefs then + (* Some bodies to define by proof *) + let thms = + list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) + fixdefs) in + Lemmas.start_proof_with_initialization (Global,DefinitionBody Fixpoint) + (Some(false,indexes,init_tac)) thms None (fun _ _ -> ()) + else begin + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let indexes = search_guard dummy_loc (Global.env()) indexes fixdecls in + let fiximps = List.map snd fiximps in + let fixdecls = + list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in + ignore (list_map4 (declare_fix boxed Fixpoint) fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + fixpoint_message (Some indexes) fixnames; + end; (* Declare notations *) - List.iter (declare_interning_data ([],[])) notations - -let build_recursive l b = - let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in - let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> - ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn)) - l in - interp_recursive (IsFixpoint g) fixl b - -let build_corecursive l b = - let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> - ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn)) - l in - interp_recursive IsCoFixpoint fixl b - -(* 3d| Schemes *) -let rec split_scheme l = - let env = Global.env() in - match l with - | [] -> [],[] - | (Some id,t)::q -> let l1,l2 = split_scheme q in - ( match t with - | InductionScheme (x,y,z) -> ((id,x,y,z)::l1),l2 - | EqualityScheme x -> l1,(x::l2) - ) -(* - if no name has been provided, we build one from the types of the ind -requested -*) - | (None,t)::q -> - let l1,l2 = split_scheme q in - ( match t with - | InductionScheme (x,y,z) -> - let ind = mkInd (Nametab.inductive_of_reference y) in - let sort_of_ind = family_of_sort (Typing.sort_of env Evd.empty ind) -in - let z' = family_of_sort (interp_sort z) in - let suffix = ( - match sort_of_ind with - | InProp -> - if x then (match z' with - | InProp -> "_ind_nodep" - | InSet -> "_rec_nodep" - | InType -> "_rect_nodep") - else ( match z' with - | InProp -> "_ind" - | InSet -> "_rec" - | InType -> "_rect" ) - | _ -> - if x then (match z' with - | InProp -> "_ind" - | InSet -> "_rec" - | InType -> "_rect" ) - else (match z' with - | InProp -> "_ind_nodep" - | InSet -> "_rec_nodep" - | InType -> "_rect_nodep") - ) in - let newid = (string_of_id (Pcoq.coerce_global_to_id y))^suffix in - let newref = (dummy_loc,id_of_string newid) in - ((newref,x,y,z)::l1),l2 - | EqualityScheme x -> l1,(x::l2) - ) - - -let build_induction_scheme lnamedepindsort = - let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort - and sigma = Evd.empty - and env0 = Global.env() in - let lrecspec = - List.map - (fun (_,dep,indid,sort) -> - let ind = Nametab.inductive_of_reference indid in - let (mib,mip) = Global.lookup_inductive ind in - (ind,mib,mip,dep,interp_elimination_sort sort)) - lnamedepindsort - in - let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in - let rec declare decl fi lrecref = - let decltype = Retyping.get_type_of env0 Evd.empty decl in - let decltype = refresh_universes decltype in - let ce = { const_entry_body = decl; - const_entry_type = Some decltype; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() } in - let kn = declare_constant fi (DefinitionEntry ce, IsDefinition Scheme) in - ConstRef kn :: lrecref - in - let _ = List.fold_right2 declare listdecl lrecnames [] in - if_verbose ppnl (recursive_message Fixpoint None lrecnames) - -let build_scheme l = - let ischeme,escheme = split_scheme l in -(* we want 1 kind of scheme at a time so we check if the user -tried to declare different schemes at once *) - if (ischeme <> []) && (escheme <> []) - then - error "Do not declare equality and induction scheme at the same time." - else ( - if ischeme <> [] then build_induction_scheme ischeme; - List.iter ( fun indname -> - let ind = Nametab.inductive_of_reference indname - in declare_eq_scheme (fst ind); - try - make_eq_decidability ind - with _ -> - Pfedit.delete_current_proof(); - message "Error while computing decidability scheme. Please report." - ) escheme - ) - -let list_split_rev_at index l = - let rec aux i acc = function - hd :: tl when i = index -> acc, tl - | hd :: tl -> aux (succ i) (hd :: acc) tl - | [] -> failwith "list_split_at: Invalid argument" - in aux 0 [] l - -let fold_left' f = function - [] -> raise (Invalid_argument "fold_right'") - | hd :: tl -> List.fold_left f hd tl - -let build_combined_scheme name schemes = - let env = Global.env () in -(* let nschemes = List.length schemes in *) - let find_inductive ty = - let (ctx, arity) = decompose_prod ty in - let (_, last) = List.hd ctx in - match kind_of_term last with - | App (ind, args) -> - let ind = destInd ind in - let (_,spec) = Inductive.lookup_mind_specif env ind in - ctx, ind, spec.mind_nrealargs - | _ -> ctx, destInd last, 0 - in - let defs = - List.map (fun x -> - let refe = Ident x in - let qualid = qualid_of_reference refe in - let cst = try Nametab.locate_constant (snd qualid) - with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.") - in - let ty = Typeops.type_of_constant env cst in - qualid, cst, ty) - schemes - in - let (qid, c, t) = List.hd defs in - let ctx, ind, nargs = find_inductive t in - (* Number of clauses, including the predicates quantification *) - let prods = nb_prod t - (nargs + 1) in - let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in - let relargs = rel_vect 0 prods in - let concls = List.rev_map - (fun (_, cst, t) -> - mkApp(mkConst cst, relargs), - snd (decompose_prod_n prods t)) defs in - let concl_bod, concl_typ = - fold_left' - (fun (accb, acct) (cst, x) -> - mkApp (coqconj, [| x; acct; cst; accb |]), - mkApp (coqand, [| x; acct |])) concls - in - let ctx, _ = - list_split_rev_at prods - (List.rev_map (fun (x, y) -> x, None, y) ctx) in - let typ = it_mkProd_wo_LetIn concl_typ ctx in - let body = it_mkLambda_or_LetIn concl_bod ctx in - let ce = { const_entry_body = body; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() } in - let _ = declare_constant (snd name) (DefinitionEntry ce, IsDefinition Scheme) in - if_verbose ppnl (recursive_message Fixpoint None [snd name]) -(* 4| Goal declaration *) - -(* 4.1| Support for mutually proved theorems *) - -let retrieve_first_recthm = function - | VarRef id -> - (pi2 (Global.lookup_named id),variable_opacity id) - | ConstRef cst -> - let {const_body=body;const_opaque=opaq} = Global.lookup_constant cst in - (Option.map Declarations.force body,opaq) - | _ -> assert false - -let default_thm_id = id_of_string "Unnamed_thm" - -let compute_proof_name = function - | Some (loc,id) -> - (* We check existence here: it's a bit late at Qed time *) - if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then - user_err_loc (loc,"",pr_id id ++ str " already exists."); - id - | None -> - let rec next avoid id = - let id = next_global_ident_away false id avoid in - if Nametab.exists_cci (Lib.make_path id) then next (id::avoid) id - else id - in - next (Pfedit.get_all_proof_names ()) default_thm_id - -let save_remaining_recthms (local,kind) body opaq i (id,(t_i,imps)) = - match body with - | None -> - (match local with - | Local -> - let impl=false in (* copy values from Vernacentries *) - let k = IsAssumption Conjectural in - let c = SectionLocalAssum (t_i,impl,[]) in - let _ = declare_variable id (Lib.cwd(),c,k) in - (Local,VarRef id,imps) - | Global -> - let k = IsAssumption Conjectural in - let kn = declare_constant id (ParameterEntry (t_i,false), k) in - (Global,ConstRef kn,imps)) - | Some body -> - let k = logical_kind_of_goal_kind kind in - let body_i = match kind_of_term body with - | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) - | CoFix (0,decls) -> mkCoFix (i,decls) - | _ -> anomaly "Not a proof by induction" in - match local with - | Local -> - let c = SectionLocalDef (body_i, Some t_i, opaq) in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Local,VarRef id,imps) - | Global -> - let const = - { const_entry_body = body_i; - const_entry_type = Some t_i; - const_entry_opaque = opaq; - const_entry_boxed = false (* copy of what cook_proof does *)} in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global,ConstRef kn,imps) - -let look_for_mutual_statements thms = - if List.tl thms <> [] then - (* More than one statement: we look for a common inductive hyp or a *) - (* common coinductive conclusion *) - let n = List.length thms in - let inds = List.map (fun (id,(t,_) as x) -> - let (hyps,ccl) = Sign.decompose_prod_assum t in - let whnf_hyp_hds = fold_map_rel_context - (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c)) - (Global.env()) hyps in - let ind_hyps = - List.flatten (list_map_i (fun i (_,b,t) -> - match kind_of_term t with - | Ind (kn,_ as ind) when - let mind = Global.lookup_mind kn in - mind.mind_finite & b = None -> - [ind,x,i] - | _ -> - []) 1 (List.rev whnf_hyp_hds)) in - let ind_ccl = - let cclenv = push_rel_context hyps (Global.env()) in - let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in - match kind_of_term whnf_ccl with - | Ind (kn,_ as ind) when - let mind = Global.lookup_mind kn in - mind.mind_ntypes = n & not mind.mind_finite -> - [ind,x,0] - | _ -> - [] in - ind_hyps,ind_ccl) thms in - let inds_hyps,ind_ccls = List.split inds in - let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in - (* Check if all conclusions are coinductive in the same type *) - (* (degenerated cartesian product since there is at most one coind ccl) *) - let same_indccl = - list_cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks - then Some (hyp::oks) else None) [] ind_ccls in - let ordered_same_indccl = - List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in - (* Check if some hypotheses are inductive in the same type *) - let common_same_indhyp = - list_cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks - then Some (hyp::oks) else None) [] inds_hyps in - let ordered_inds,finite = - match ordered_same_indccl, common_same_indhyp with - | indccl::rest, _ -> - assert (rest=[]); - (* One occ. of common coind ccls and no common inductive hyps *) - if common_same_indhyp <> [] then - if_verbose warning "Assuming mutual coinductive statements."; - flush_all (); - indccl, true - | [], _::_ -> - if same_indccl <> [] && - list_distinct (List.map pi1 (List.hd same_indccl)) then - if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all (); - (* assume the largest indices as possible *) - list_last common_same_indhyp, false - | _, [] -> - error - ("Cannot find common (mutual) inductive premises or coinductive" ^ - " conclusions in the statements.") - in - let nl,thms = List.split (List.map (fun (_,x,i) -> (i,x)) ordered_inds) in - let rec_tac = - if finite then - match List.map (fun (id,(t,_)) -> (id,t)) thms with - | (id,_)::l -> Hiddentac.h_mutual_cofix true id l - | _ -> assert false - else - (* nl is dummy: it will be recomputed at Qed-time *) - match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with - | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l - | _ -> assert false in - Some rec_tac,thms - else - None, thms - -(* 4.2| General support for goals *) - -let start_proof_com kind thms hook = - let thms = List.map (fun (sopt,(bl,t)) -> - (compute_proof_name sopt, - interp_type_evars_impls (Global.env()) (generalize_constr_expr t bl))) - thms in - let rec_tac,thms = look_for_mutual_statements thms in - match thms with - | [] -> anomaly "No proof to start" - | (id,(t,imps))::other_thms -> - let hook strength ref = - let other_thms_data = - if other_thms = [] then [] else - (* there are several theorems defined mutually *) - let body,opaq = retrieve_first_recthm ref in - list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in - let thms_data = (strength,ref,imps)::other_thms_data in - List.iter (fun (strength,ref,imps) -> - maybe_declare_manual_implicits false ref imps; - hook strength ref) thms_data in - start_proof id kind t ?init_tac:rec_tac - ~compute_guard:(rec_tac<>None) hook - -let check_anonymity id save_ident = - if atompart_of_id id <> "Unnamed_thm" then - error "This command can only be used for unnamed theorem." -(* - message("Overriding name "^(string_of_id id)^" and using "^save_ident) -*) - -let save_anonymous opacity save_ident = - let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in - let const = { const with const_entry_opaque = opacity } in - check_anonymity id save_ident; - save save_ident const do_guard persistence hook - -let save_anonymous_with_strength kind opacity save_ident = - let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in - let const = { const with const_entry_opaque = opacity } in - check_anonymity id save_ident; - (* we consider that non opaque behaves as local for discharge *) - save save_ident const do_guard (Global, Proof kind) hook - -let admit () = - let (id,k,typ,hook) = Pfedit.current_proof_statement () in -(* Contraire aux besoins d'interactivité... - if k <> IsGlobal (Proof Conjecture) then - error "Only statements declared as conjecture can be admitted"; -*) - let kn = - declare_constant id (ParameterEntry (typ,false), IsAssumption Conjectural) in - Pfedit.delete_current_proof (); - assumption_message id; - hook Global (ConstRef kn) + List.iter Metasyntax.add_notation_interpretation ntns + +let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns = + if List.mem None fixdefs then + (* Some bodies to define by proof *) + let thms = + list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) + fixdefs) in + Lemmas.start_proof_with_initialization (Global,DefinitionBody CoFixpoint) + (Some(true,[],init_tac)) thms None (fun _ _ -> ()) + else begin + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in + let fiximps = List.map snd fiximps in + ignore (list_map4 (declare_fix boxed CoFixpoint) fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + cofixpoint_message fixnames + end; + (* Declare notations *) + List.iter Metasyntax.add_notation_interpretation ntns -let get_current_context () = - try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> - (Evd.empty, Global.env()) +let extract_decreasing_argument = function + | (_,(na,CStructRec),_,_,_) -> na + | _ -> error + "Only structural decreasing is supported for a non-Program Fixpoint" +let extract_fixpoint_components l = + let fixl, ntnl = List.split l in + let wfl = List.map extract_decreasing_argument fixl in + let fixl = List.map (fun ((_,id),_,bl,typ,def) -> + {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in + fixl, List.flatten ntnl, wfl +let extract_cofixpoint_components l = + let fixl, ntnl = List.split l in + List.map (fun ((_,id),bl,typ,def) -> + {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.flatten ntnl + +let do_fixpoint l b = + let fixl,ntns,wfl = extract_fixpoint_components l in + let fix = interp_fixpoint fixl ntns in + let possible_indexes = + list_map3 compute_possible_guardness_evidences wfl fixl (snd fix) in + declare_fixpoint b fix possible_indexes ntns + +let do_cofixpoint l b = + let fixl,ntns = extract_cofixpoint_components l in + declare_cofixpoint b (interp_cofixpoint fixl ntns) ntns diff --git a/toplevel/command.mli b/toplevel/command.mli index 36399029..b87060e4 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -6,143 +6,153 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: command.mli 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Util open Names open Term -open Nametab -open Declare -open Library +open Entries open Libnames -open Nametab open Tacexpr open Vernacexpr -open Rawterm open Topconstr open Decl_kinds open Redexpr +open Constrintern +open Pfedit (*i*) -(*s Declaration functions. The following functions take ASTs, - transform them into [constr] and then call the corresponding - functions of [Declare]; they return an absolute reference to the - defined object *) +(*s This file is about the interpretation of raw commands into typed + ones and top-level declaration of the main Gallina objects *) -val get_declare_definition_hook : unit -> (Entries.definition_entry -> unit) -val set_declare_definition_hook : (Entries.definition_entry -> unit) -> unit +(* Hooks for Pcoq *) -val definition_message : identifier -> unit -val assumption_message : identifier -> unit +val set_declare_definition_hook : (definition_entry -> unit) -> unit +val get_declare_definition_hook : unit -> (definition_entry -> unit) +val set_declare_assumptions_hook : (types -> unit) -> unit -val declare_definition : identifier -> definition_kind -> - local_binder list -> red_expr option -> constr_expr -> - constr_expr option -> declaration_hook -> unit +(*************************************************************************) +(* Definitions/Let *) -val syntax_definition : identifier -> identifier list * constr_expr -> +val interp_definition : + boxed_flag -> local_binder list -> red_expr option -> constr_expr -> + constr_expr option -> definition_entry * manual_implicits + +val declare_definition : identifier -> locality * definition_object_kind -> + definition_entry -> manual_implicits -> declaration_hook -> unit + +(*************************************************************************) +(* Parameters/Assumptions *) + +val interp_assumption : + local_binder list -> constr_expr -> types * manual_implicits + +val declare_assumption : coercion_flag -> assumption_kind -> types -> + manual_implicits -> + bool (* implicit *) -> bool (* inline *) -> variable located -> unit + +val declare_assumptions : variable located list -> + coercion_flag -> assumption_kind -> types -> manual_implicits -> bool -> bool -> unit -val declare_one_assumption : coercion_flag -> assumption_kind -> Term.types -> - Impargs.manual_explicitation list -> - bool (* implicit *) -> identifier list (* keep *) -> bool (* inline *) -> Names.variable located -> unit - -val set_declare_assumption_hook : (types -> unit) -> unit - -val declare_assumption : identifier located list -> - coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> - bool -> identifier list -> bool -> unit - -val declare_interning_data : 'a * Constrintern.implicits_env -> - string * Topconstr.constr_expr * Topconstr.scope_name option -> unit - -val compute_interning_datas : Environ.env -> Constrintern.var_internalisation_type -> - 'a list -> 'b list -> - Term.types list ->Impargs.manual_explicitation list list -> - 'a list * - ('b * (Constrintern.var_internalisation_type * Names.identifier list * Impargs.implicits_list * - Topconstr.scope_name option list)) - list - -val check_mutuality : Environ.env -> definition_object_kind -> - (identifier * types) list -> unit - -val build_mutual : ((lident * local_binder list * constr_expr option * constructor_expr list) * - decl_notation) list -> bool -> unit - -val declare_mutual_with_eliminations : - bool -> Entries.mutual_inductive_entry -> - (Impargs.manual_explicitation list * - Impargs.manual_explicitation list list) list -> - mutual_inductive +(*************************************************************************) +(* Inductive and coinductive types *) -type fixpoint_kind = - | IsFixpoint of (identifier located option * recursion_order_expr) list - | IsCoFixpoint +(* Extracting the semantical components out of the raw syntax of mutual + inductive declarations *) -type fixpoint_expr = { - fix_name : identifier; - fix_binders : local_binder list; - fix_body : constr_expr; - fix_type : constr_expr +type structured_one_inductive_expr = { + ind_name : identifier; + ind_arity : constr_expr; + ind_lc : (identifier * constr_expr) list } -val recursive_message : definition_object_kind -> - int array option -> identifier list -> Pp.std_ppcmds - -val declare_fix : bool -> definition_object_kind -> identifier -> - constr -> types -> Impargs.manual_explicitation list -> global_reference +type structured_inductive_expr = + local_binder list * structured_one_inductive_expr list -val build_recursive : (Topconstr.fixpoint_expr * decl_notation) list -> bool -> unit +val extract_mutual_inductive_declaration_components : + (one_inductive_expr * decl_notation list) list -> + structured_inductive_expr * (*coercions:*) qualid list * decl_notation list -val build_corecursive : (Topconstr.cofixpoint_expr * decl_notation) list -> bool -> unit +(* Typing mutual inductive definitions *) -val build_scheme : (identifier located option * scheme ) list -> unit +type one_inductive_impls = + Impargs.manual_explicitation list (* for inds *)* + Impargs.manual_explicitation list list (* for constrs *) -val build_combined_scheme : identifier located -> identifier located list -> unit +val interp_mutual_inductive : + structured_inductive_expr -> decl_notation list -> bool -> + mutual_inductive_entry * one_inductive_impls list -val generalize_constr_expr : constr_expr -> local_binder list -> constr_expr +(* Registering a mutual inductive definition together with its + associated schemes *) -val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr +val declare_mutual_inductive_with_eliminations : + Declare.internal_flag -> mutual_inductive_entry -> one_inductive_impls list -> + mutual_inductive + +(* Entry points for the vernacular commands Inductive and CoInductive *) -(* A hook start_proof calls on the type of the definition being started *) -val set_start_hook : (types -> unit) -> unit +val do_mutual_inductive : + (one_inductive_expr * decl_notation list) list -> bool -> unit -val start_proof : identifier -> goal_kind -> types -> - ?init_tac:Proof_type.tactic -> ?compute_guard:bool -> declaration_hook -> unit +(*************************************************************************) +(* Fixpoints and cofixpoints *) -val start_proof_com : goal_kind -> - (lident option * (local_binder list * constr_expr)) list -> - declaration_hook -> unit +type structured_fixpoint_expr = { + fix_name : identifier; + fix_binders : local_binder list; + fix_body : constr_expr option; + fix_type : constr_expr +} -(* A hook the next three functions pass to cook_proof *) -val set_save_hook : (Refiner.pftreestate -> unit) -> unit +(* Extracting the semantical components out of the raw syntax of + (co)fixpoints declarations *) -(*s [save_named b] saves the current completed proof under the name it -was started; boolean [b] tells if the theorem is declared opaque; it -fails if the proof is not completed *) +val extract_fixpoint_components : + (fixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list * + (* possible structural arg: *) lident option list -val save_named : bool -> unit +val extract_cofixpoint_components : + (cofixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list -(* [save_anonymous b name] behaves as [save_named] but declares the theorem -under the name [name] and respects the strength of the declaration *) +(* Typing global fixpoints and cofixpoint_expr *) -val save_anonymous : bool -> identifier -> unit +type recursive_preentry = + identifier list * constr option list * types list -(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but - declares the theorem under the name [name] and gives it the - strength [strength] *) +val interp_fixpoint : + structured_fixpoint_expr list -> decl_notation list -> + recursive_preentry * (name list * manual_implicits) list -val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit +val interp_cofixpoint : + structured_fixpoint_expr list -> decl_notation list -> + recursive_preentry * (name list * manual_implicits) list -(* [admit ()] aborts the current goal and save it as an assmumption *) +(* Registering fixpoints and cofixpoints in the environment *) -val admit : unit -> unit +val declare_fixpoint : + bool -> recursive_preentry * (name list * manual_implicits) list -> + lemma_possible_guards -> decl_notation list -> unit -(* [get_current_context ()] returns the evar context and env of the - current open proof if any, otherwise returns the empty evar context - and the current global env *) +val declare_cofixpoint : + bool -> recursive_preentry * (name list * manual_implicits) list -> + decl_notation list -> unit -val get_current_context : unit -> Evd.evar_map * Environ.env +(* Entry points for the vernacular commands Fixpoint and CoFixpoint *) +val do_fixpoint : + (fixpoint_expr * decl_notation list) list -> bool -> unit +val do_cofixpoint : + (cofixpoint_expr * decl_notation list) list -> bool -> unit + +(* Utils *) + +val check_mutuality : Environ.env -> bool -> (identifier * types) list -> unit + +val declare_fix : bool -> definition_object_kind -> identifier -> + constr -> types -> Impargs.manual_explicitation list -> global_reference diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index d32a773d..d9fcdb24 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqinit.ml 11749 2009-01-05 14:01:04Z notin $ *) +(* $Id$ *) open Pp open System @@ -32,7 +32,7 @@ let load_rcfile() = if !load_rc then try if !rcfile_specified then - if file_readable_p !rcfile then + if file_readable_p !rcfile then Vernac.load_vernac false !rcfile else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) else if file_readable_p (!rcfile^"."^Coq_config.version) then @@ -48,12 +48,9 @@ let load_rcfile() = with e -> (msgnl (str"Load of rcfile failed."); raise e) - else + else Flags.if_verbose msgnl (str"Skipping rcfile loading.") -let add_ml_include s = - Mltop.add_ml_dir s - (* Puts dir in the path of ML and in the LoadPath *) let coq_add_path d s = Mltop.add_path d (Names.make_dirpath [Nameops.coq_root;Names.id_of_string s]) @@ -64,32 +61,29 @@ let includes = ref [] let push_include (s, alias) = includes := (s,alias,false) :: !includes let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes -(* Because find puts "./" and the loadpath is not nicely pretty-printed *) -let hm2 s = - let n = String.length s in - if n > 1 && s.[0] = '.' && s.[1] = '/' then String.sub s 2 (n-2) else s - (* The list of all theories in the standard library /!\ order does matter *) let theories_dirs_map = [ "theories/Unicode", "Unicode" ; - "theories/Classes", "Classes" ; - "theories/Program", "Program" ; - "theories/FSets", "FSets" ; - "theories/Reals", "Reals" ; - "theories/Strings", "Strings" ; - "theories/Sorting", "Sorting" ; - "theories/Setoids", "Setoids" ; - "theories/Sets", "Sets" ; - "theories/Lists", "Lists" ; - "theories/Wellfounded", "Wellfounded" ; - "theories/Relations", "Relations" ; - "theories/Numbers", "Numbers" ; - "theories/QArith", "QArith" ; - "theories/NArith", "NArith" ; - "theories/ZArith", "ZArith" ; - "theories/Arith", "Arith" ; - "theories/Bool", "Bool" ; - "theories/Logic", "Logic" ; + "theories/Classes", "Classes" ; + "theories/Program", "Program" ; + "theories/MSets", "MSets" ; + "theories/FSets", "FSets" ; + "theories/Reals", "Reals" ; + "theories/Strings", "Strings" ; + "theories/Sorting", "Sorting" ; + "theories/Setoids", "Setoids" ; + "theories/Sets", "Sets" ; + "theories/Structures", "Structures" ; + "theories/Lists", "Lists" ; + "theories/Wellfounded", "Wellfounded" ; + "theories/Relations", "Relations" ; + "theories/Numbers", "Numbers" ; + "theories/QArith", "QArith" ; + "theories/NArith", "NArith" ; + "theories/ZArith", "ZArith" ; + "theories/Arith", "Arith" ; + "theories/Bool", "Bool" ; + "theories/Logic", "Logic" ; "theories/Init", "Init" ] @@ -97,26 +91,26 @@ let theories_dirs_map = [ let init_load_path () = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in - let dirs = "states" :: ["contrib"] in + let dirs = ["states";"plugins"] in (* first user-contrib *) - if Sys.file_exists user_contrib then + if Sys.file_exists user_contrib then Mltop.add_rec_path user_contrib Nameops.default_root_prefix; - (* then states, contrib and dev *) + (* then states, theories and dev *) List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; (* developer specific directory to open *) if Coq_config.local then coq_add_path (coqlib/"dev") "dev"; (* then standard library *) - List.iter - (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) + List.iter + (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) theories_dirs_map; (* then current directory *) Mltop.add_path "." Nameops.default_root_prefix; (* additional loadpath, given with -I -include -R options *) - List.iter + List.iter (fun (s,alias,reci) -> if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias) (List.rev !includes) - + let init_library_roots () = includes := [] @@ -124,11 +118,11 @@ let init_library_roots () = find the "include" file in the *source* directory *) let init_ocaml_path () = let coqsrc = Coq_config.coqsrc in - let add_subdir dl = - Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) + let add_subdir dl = + Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) in - Mltop.add_ml_dir (Envars.coqlib ()); + Mltop.add_ml_dir (Envars.coqlib ()); List.iter add_subdir - [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; + [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ] diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index d7856170..f4c82a41 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: coqinit.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (* Initialization. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f5d1d142..a88ee3ba 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqtop.ml 11830 2009-01-22 06:45:13Z notin $ *) +(* $Id$ *) open Pp open Util @@ -21,7 +21,7 @@ open Coqinit let get_version_date () = try - let coqlib = Envars.coqlib () in + let coqlib = Envars.coqlib () in let ch = open_in (Filename.concat coqlib "revision") in let ver = input_line ch in let rev = input_line ch in @@ -37,7 +37,7 @@ let output_context = ref false let memory_stat = ref false -let print_memory_stat () = +let print_memory_stat () = if !memory_stat then Format.printf "total heap size = %d kbytes\n" (heap_size_kb ()) @@ -47,7 +47,7 @@ let engagement = ref None let set_engagement c = engagement := Some c let engage () = match !engagement with Some c -> Global.set_engagement c | None -> () - + let set_batch_mode () = batch_mode := true let toplevel_default_name = make_dirpath [id_of_string "Top"] @@ -72,22 +72,19 @@ let set_outputstate s = outputstate:=s let outputstate () = if !outputstate <> "" then extern_state !outputstate let set_default_include d = push_include (d,Nameops.default_root_prefix) -let set_default_rec_include d = push_rec_include(d,Nameops.default_root_prefix) let set_include d p = let p = dirpath_of_string p in - Library.check_coq_overwriting p; push_include (d,p) let set_rec_include d p = - let p = dirpath_of_string p in - Library.check_coq_overwriting p; + let p = dirpath_of_string p in push_rec_include(d,p) - + let load_vernacular_list = ref ([] : (string * bool) list) let add_load_vernacular verb s = load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list let load_vernacular () = List.iter - (fun (s,b) -> + (fun (s,b) -> if Flags.do_beautify () then with_option beautify_file (Vernac.load_vernac b) s else @@ -96,7 +93,7 @@ let load_vernacular () = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj -let load_vernac_obj () = +let load_vernac_obj () = List.iter (fun f -> Library.require_library_from_file None f None) (List.rev !load_vernacular_obj) @@ -109,7 +106,7 @@ let require () = let compile_list = ref ([] : (bool * string) list) let add_compile verbose s = set_batch_mode (); - Flags.make_silent true; + Flags.make_silent true; compile_list := (verbose,s) :: !compile_list let compile_files () = let init_state = States.freeze() in @@ -124,6 +121,12 @@ let compile_files () = Vernac.compile v f) (List.rev !compile_list) +let set_compat_version = function + | "8.2" -> compat_version := Some V8_2 + | "8.1" -> warning "Compatibility with version 8.1 not supported." + | "8.0" -> warning "Compatibility with version 8.0 not supported." + | s -> error ("Unknown compatibility version \""^s^"\".") + let re_exec_version = ref "" let set_byte () = re_exec_version := "byte" let set_opt () = re_exec_version := "opt" @@ -145,11 +148,11 @@ let re_exec is_ide = if (is_native && s = "byte") || ((not is_native) && s = "opt") then begin let s = if s = "" then if is_native then "opt" else "byte" else s in - let newprog = + let newprog = let dir = Filename.dirname prog in let coqtop = if is_ide then "coqide." else "coqtop." in let com = coqtop ^ s ^ Coq_config.exec_extension in - if dir <> "." then Filename.concat dir com else com + if dir <> "." then Filename.concat dir com else com in Sys.argv.(0) <- newprog; Unix.handle_unix_error (Unix.execvp newprog) Sys.argv @@ -186,12 +189,12 @@ let parse_args is_ide = let glob_opt = ref false in let rec parse = function | [] -> () - | "-with-geoproof" :: s :: rem -> + | "-with-geoproof" :: s :: rem -> if s = "yes" then Coq_config.with_geoproof := true else if s = "no" then Coq_config.with_geoproof := false else usage (); parse rem - | "-impredicative-set" :: rem -> + | "-impredicative-set" :: rem -> set_engagement Declarations.ImpredicativeSet; parse rem | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem @@ -218,13 +221,13 @@ let parse_args is_ide = | "-full" :: rem -> warning "option -full deprecated\n"; parse rem | "-batch" :: rem -> set_batch_mode (); parse rem - | "-boot" :: rem -> boot := true; no_load_rc (); parse rem + | "-boot" :: rem -> boot := true; no_load_rc (); parse rem | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem | "-outputstate" :: s :: rem -> set_outputstate s; parse rem | "-outputstate" :: [] -> usage () | "-nois" :: rem -> set_inputstate ""; parse rem - + | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem | ("-inputstate"|"-is") :: [] -> usage () @@ -234,11 +237,11 @@ let parse_args is_ide = | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem | "-load-ml-source" :: [] -> usage () - | ("-load-vernac-source"|"-l") :: f :: rem -> + | ("-load-vernac-source"|"-l") :: f :: rem -> add_load_vernacular false f; parse rem | ("-load-vernac-source"|"-l") :: [] -> usage () - | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> + | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> add_load_vernacular true f; parse rem | ("-load-vernac-source-verbose"|"-lv") :: [] -> usage () @@ -270,11 +273,14 @@ let parse_args is_ide = | "-debug" :: rem -> set_debug (); parse rem + | "-compat" :: v :: rem -> set_compat_version v; parse rem + | "-compat" :: [] -> usage () + | "-vm" :: rem -> use_vm := true; parse rem | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem - | "-emacs-U" :: rem -> Flags.print_emacs := true; + | "-emacs-U" :: rem -> Flags.print_emacs := true; Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem - + | "-unicode" :: rem -> Flags.unicode_syntax := true; parse rem | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem @@ -296,7 +302,9 @@ let parse_args is_ide = | "-user" :: u :: rem -> set_rcuser u; parse rem | "-user" :: [] -> usage () - | "-notactics" :: rem -> remove_top_ml (); parse rem + | "-notactics" :: rem -> + warning "Obsolete option \"-notactics\"."; + remove_top_ml (); parse rem | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem @@ -312,7 +320,7 @@ let parse_args is_ide = | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem - | s :: rem -> + | s :: rem -> if is_ide then begin ide_args := s :: !ide_args; parse rem @@ -322,7 +330,7 @@ let parse_args is_ide = in try parse (List.tl (Array.to_list Sys.argv)) - with + with | UserError(_,s) as e -> begin try Stream.empty s; exit 1 @@ -359,17 +367,19 @@ let init is_ide = exit 1 end; if !batch_mode then - (flush_all(); + (flush_all(); if !output_context then Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ()); - Profile.print_profile (); + Profile.print_profile (); exit 0); Lib.declare_initial_state () +let init_toplevel () = init false + let init_ide () = init true; List.rev !ide_args let start () = - init false; + init_toplevel (); Toplevel.loop(); (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index b5a1106c..87f4bdeb 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -6,17 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: coqtop.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (* The Coq main module. The following function [start] will parse the - command line, print the banner, initialize the load path, load the input + command line, print the banner, initialize the load path, load the input state, load the files given on the command line, load the ressource file, produce the output state if any, and finally will launch [Toplevel.loop]. *) val start : unit -> unit -(* [init_ide] is to be used by the Coq IDE. - It does everything [start] does, except launching the toplevel loop. +(* [init_ide] is to be used by the Coq IDE. + It does everything [start] does, except launching the toplevel loop. It returns the list of Coq files given on the command line. *) val init_ide : unit -> string list diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index ae9a243f..4c21e491 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: discharge.ml 10861 2008-04-28 08:19:14Z herbelin $ *) +(* $Id$ *) open Names open Util @@ -36,26 +36,26 @@ let detype_param = function *) let abstract_inductive hyps nparams inds = - let ntyp = List.length inds in + let ntyp = List.length inds in let nhyp = named_context_length hyps in let args = instance_from_named_context (List.rev hyps) in let subs = list_tabulate (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) ntyp in let inds' = List.map - (function (tname,arity,cnames,lc) -> + (function (tname,arity,cnames,lc) -> let lc' = List.map (substl subs) lc in let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in (tname,arity',cnames,lc'')) inds in let nparams' = nparams + 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 +(* 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 nparams' arity in List.map detype_param params in - let ind'' = - List.map + let ind'' = + List.map (fun (a,arity,c,lc) -> let _, short_arity = decompose_prod_n_assum nparams' arity in let shortlc = @@ -70,7 +70,7 @@ let abstract_inductive hyps nparams inds = let process_inductive sechyps modlist mib = let nparams = mib.mind_nparams in - let inds = + let inds = array_map_to_list (fun mip -> let arity = expmod_constr modlist (Termops.refresh_universes_strict (Inductive.type_of_inductive (Global.env()) (mib,mip))) in diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index dcf88f31..c6496cd4 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: discharge.mli 6748 2005-02-18 22:17:50Z herbelin $ i*) +(*i $Id$ i*) open Sign open Cooking open Declarations open Entries -val process_inductive : +val process_inductive : named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/fhimsg.mli b/toplevel/fhimsg.mli deleted file mode 100644 index 1ab786d1..00000000 --- a/toplevel/fhimsg.mli +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: fhimsg.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -(*i*) -open Pp -open Names -open Term -open Sign -open Environ -open Type_errors -(*i*) - -(* This module provides functions to explain the various typing errors. - It is parameterized by a function to pretty-print a term in a given - context. *) - -module type Printer = sig - val pr_term : path_kind -> env -> constr -> std_ppcmds -end - -(*s The result is a module which provides a function [explain_type_error] - to explain a type error for a given kind in a given env, which are - usually the three arguments carried by the exception [TypeError] - (see \refsec{typeerrors}). *) - -module Make (P : Printer) : sig - -val explain_type_error : path_kind -> env -> type_error -> std_ppcmds - -val pr_ne_ctx : std_ppcmds -> path_kind -> env -> std_ppcmds - -val explain_unbound_rel : path_kind -> env -> int -> std_ppcmds - -val explain_not_type : path_kind -> env -> constr -> std_ppcmds - -val explain_bad_assumption : path_kind -> env -> constr -> std_ppcmds - -val explain_reference_variables : identifier -> std_ppcmds - -val explain_elim_arity : - path_kind -> env -> constr -> constr list -> constr - -> unsafe_judgment -> (constr * constr * string) option -> std_ppcmds - -val explain_case_not_inductive : - path_kind -> env -> unsafe_judgment -> std_ppcmds - -val explain_number_branches : - path_kind -> env -> unsafe_judgment -> int -> std_ppcmds - -val explain_ill_formed_branch : - path_kind -> env -> constr -> int -> constr -> constr -> std_ppcmds - -val explain_generalization : - path_kind -> env -> name * types -> constr -> std_ppcmds - -val explain_actual_type : - path_kind -> env -> constr -> constr -> constr -> std_ppcmds - -val explain_ill_formed_rec_body : - path_kind -> env -> guard_error -> - name array -> int -> constr array -> std_ppcmds - -val explain_ill_typed_rec_body : - path_kind -> env -> int -> name list -> unsafe_judgment array - -> types array -> std_ppcmds - -end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 0cda7c71..19f42f5d 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: himsg.ml 11986 2009-03-17 11:44:20Z herbelin $ *) +(* $Id$ *) open Pp open Util open Flags open Names open Nameops +open Namegen open Term open Termops open Inductive @@ -92,7 +93,7 @@ let explain_elim_arity env ind sorts c pj okinds = | WrongArity -> "wrong arity" in let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in - let ppt = pr_lconstr_env env (snd (decompose_prod_assum pj.uj_type)) in + let ppt = pr_lconstr_env env ((strip_prod_assum pj.uj_type)) in hov 0 (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++ str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++ @@ -233,21 +234,20 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = match names.(j) with Name id -> pr_id id | Anonymous -> str "the " ++ nth i ++ str " definition" in + let pr_db x = quote (pr_db env x) in let vars = match (lt,le) with ([],[]) -> assert false - | ([],[x]) -> - str "a subterm of " ++ pr_db env x - | ([],_) -> - str "a subterm of the following variables: " ++ - prlist_with_sep pr_spc (pr_db env) le - | ([x],_) -> pr_db env x + | ([],[x]) -> str "a subterm of " ++ pr_db x + | ([],_) -> str "a subterm of the following variables: " ++ + prlist_with_sep pr_spc pr_db le + | ([x],_) -> pr_db x | _ -> str "one of the following variables: " ++ - prlist_with_sep pr_spc (pr_db env) lt in + prlist_with_sep pr_spc pr_db lt in str "Recursive call to " ++ called ++ spc () ++ - str "has principal argument equal to" ++ spc () ++ - pr_lconstr_env env arg ++ fnl () ++ str "instead of " ++ vars + strbrk "has principal argument equal to" ++ spc () ++ + pr_lconstr_env env arg ++ strbrk " instead of " ++ vars | NotEnoughArgumentsForFixCall j -> let called = @@ -288,7 +288,11 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = in prt_name i ++ str " is ill-formed." ++ fnl () ++ pr_ne_context_of (str "In environment") env ++ - st ++ str "." + st ++ str "." ++ fnl () ++ + (try (* May fail with unresolved globals. *) + let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in + str"Recursive definition is:" ++ spc () ++ pvd ++ str "." + with _ -> mt ()) let explain_ill_typed_rec_body env i names vdefj vargs = let env = make_all_name_different env in @@ -326,7 +330,7 @@ let explain_hole_kind env evi = function str "the type of " ++ Nameops.pr_id id | BinderType Anonymous -> str "the type of this anonymous binder" - | ImplicitArg (c,(n,ido)) -> + | ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++ @@ -346,6 +350,8 @@ let explain_hole_kind env evi = function str "an existential variable" | ImpossibleCase -> str "the type of an impossible pattern-matching clause" + | MatchingVar _ -> + assert false let explain_not_clean env ev t k = let env = make_all_name_different env in @@ -365,17 +371,17 @@ let explain_typeclass_resolution env evi k = match k with | GoalEvar | InternalHole | ImplicitArg _ -> (match Typeclasses.class_of_constr evi.evar_concl with - | Some c -> + | Some c -> let env = Evd.evar_env evi in - fnl () ++ str "Could not find an instance for " ++ - pr_lconstr_env env evi.evar_concl ++ + fnl () ++ str "Could not find an instance for " ++ + pr_lconstr_env env evi.evar_concl ++ pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env | None -> mt()) | _ -> mt() - + let explain_unsolvable_implicit env evi k explain = - str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ - explain_unsolvability explain ++ str "." ++ + str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ + explain_unsolvability explain ++ str "." ++ explain_typeclass_resolution env evi k let explain_var_not_found env id = @@ -414,7 +420,7 @@ let explain_refiner_cannot_generalize env ty = let explain_no_occurrence_found env c id = str "Found no subterm matching " ++ pr_lconstr_env env c ++ - str " in " ++ + str " in " ++ (match id with | Some id -> pr_id id | None -> str"the current goal") ++ str "." @@ -427,11 +433,21 @@ let explain_cannot_unify_binding_type env m n = let explain_cannot_find_well_typed_abstraction env p l = str "Abstracting over the " ++ - str (plural (List.length l) "term") ++ spc () ++ + str (plural (List.length l) "term") ++ spc () ++ hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ + str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ str "which is ill-typed." +let explain_abstraction_over_meta _ m n = + strbrk "Too complex unification problem: cannot find a solution for both " ++ + pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." + +let explain_non_linear_unification env m t = + strbrk "Cannot unambiguously instantiate " ++ + pr_name m ++ str ":" ++ + strbrk " which would require to abstract twice on " ++ + pr_lconstr_env env t ++ str "." + let explain_type_error env err = let env = make_all_name_different env in match err with @@ -485,25 +501,26 @@ let explain_pretype_error env err = | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n | CannotFindWellTypedAbstraction (p,l) -> explain_cannot_find_well_typed_abstraction env p l + | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n + | NonLinearUnification (m,c) -> explain_non_linear_unification env m c - (* Typeclass errors *) let explain_not_a_class env c = pr_constr_env env c ++ str" is not a declared type class." let explain_unbound_method env cid id = - str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++ + str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." -let pr_constr_exprs exprs = - hv 0 (List.fold_right +let pr_constr_exprs exprs = + hv 0 (List.fold_right (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) exprs (mt ())) let explain_no_instance env (_,id) l = str "No instance found for class " ++ Nameops.pr_id id ++ spc () ++ - str "applied to arguments" ++ spc () ++ + str "applied to arguments" ++ spc () ++ prlist_with_sep pr_spc (pr_lconstr_env env) l let pr_constraints printenv env evm = @@ -512,40 +529,41 @@ let pr_constraints printenv env evm = if List.for_all (fun (ev', evi') -> eq_named_context_val evi.evar_hyps evi'.evar_hyps) l then - let pe = pr_ne_context_of (str "In environment:") (mt ()) + let pe = pr_ne_context_of (str "In environment:") (mt ()) (reset_with_named_context evi.evar_hyps env) in (if printenv then pe ++ fnl () else mt ()) ++ - prlist_with_sep (fun () -> fnl ()) + prlist_with_sep (fun () -> fnl ()) (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l else pr_evar_map evm - + let explain_unsatisfiable_constraints env evd constr = - let evm = Evd.evars_of evd in + let evm = Evarutil.nf_evars evd in + let undef = Evd.undefined_evars evm in match constr with | None -> str"Unable to satisfy the following constraints:" ++ fnl() ++ pr_constraints true env evm - | Some (evi, k) -> - explain_unsolvable_implicit env evi k None ++ fnl () ++ - if List.length (Evd.to_list evm) > 1 then - str"With the following constraints:" ++ fnl() ++ - pr_constraints false env evm + | Some (ev, k) -> + explain_unsolvable_implicit env (Evd.find evm ev) k None ++ fnl () ++ + if List.length (Evd.to_list undef) > 1 then + str"With the following constraints:" ++ fnl() ++ + pr_constraints false env (Evd.remove undef ev) else mt () - -let explain_mismatched_contexts env c i j = + +let explain_mismatched_contexts env c i j = str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ - hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++ + hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++ hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) -let explain_typeclass_error env err = +let explain_typeclass_error env err = match err with | NotAClass c -> explain_not_a_class env c | UnboundMethod (cid, id) -> explain_unbound_method env cid id | NoInstance (id, l) -> explain_no_instance env id l | UnsatisfiableConstraints (evd, c) -> explain_unsatisfiable_constraints env evd c | MismatchedContextInstance (c, i, j) -> explain_mismatched_contexts env c i j - + (* Refiner errors *) let explain_refiner_bad_type arg ty conclty = @@ -555,9 +573,9 @@ let explain_refiner_bad_type arg ty conclty = str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." let explain_refiner_unresolved_bindings l = - str "Unable to find an instance for the " ++ + str "Unable to find an instance for the " ++ str (plural (List.length l) "variable") ++ spc () ++ - prlist_with_sep pr_coma pr_name l ++ str"." + prlist_with_sep pr_comma pr_name l ++ str"." let explain_refiner_cannot_apply t harg = str "In refiner, a term of type" ++ brk(1,1) ++ @@ -579,9 +597,9 @@ let explain_non_linear_proof c = spc () ++ str "because a metavariable has several occurrences." let explain_meta_in_type c = - str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ + str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ str " of another meta" - + let explain_refiner_error = function | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t @@ -610,9 +628,9 @@ let error_ill_formed_constructor env id c v nparams nargs = let pv = pr_lconstr_env env v in let atomic = (nb_prod c = 0) in str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++ - str "is not valid;" ++ brk(1,1) ++ - strbrk (if atomic then "it must be " else "its conclusion must be ") ++ - pv ++ + str "is not valid;" ++ brk(1,1) ++ + strbrk (if atomic then "it must be " else "its conclusion must be ") ++ + pv ++ (* warning: because of implicit arguments it is difficult to say which parameters must be explicitly given *) (if nparams<>0 then @@ -643,7 +661,7 @@ let error_same_names_constructors id = let error_same_names_overlap idl = strbrk "The following names are used both as type names and constructor " ++ str "names:" ++ spc () ++ - prlist_with_sep pr_coma pr_id idl ++ str "." + prlist_with_sep pr_comma pr_id idl ++ str "." let error_not_an_arity id = str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity." @@ -658,7 +676,7 @@ let error_large_non_prop_inductive_not_in_type () = let error_not_allowed_case_analysis isrec kind i = str (if isrec then "Induction" else "Case analysis") ++ - strbrk " on sort " ++ pr_sort kind ++ + strbrk " on sort " ++ pr_sort kind ++ strbrk " is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str "." @@ -788,39 +806,46 @@ let explain_reduction_tactic_error = function spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' e -let explain_ltac_call_trace (last,trace,loc) = - let calls = last :: List.rev (List.map snd trace) in - let pr_call = function - | Proof_type.LtacNotationCall s -> quote (str s) - | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) - | Proof_type.LtacVarCall (id,t) -> - quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" - | Proof_type.LtacAtomCall (te,otac) -> quote - (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (dummy_loc,te))) - ++ (match !otac with - | Some te' when (Obj.magic te' <> te) -> - strbrk " (expanded to " ++ quote - (Pptactic.pr_tactic (Global.env()) - (Tacexpr.TacAtom (dummy_loc,te'))) - ++ str ")" - | _ -> mt ()) - | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) -> - let filter = - function (id,None) -> None | (id,Some id') -> Some(id,mkVar id') in - let unboundvars = list_map_filter filter unboundvars in - quote (pr_rawconstr_env (Global.env()) c) ++ - (if unboundvars <> [] or vars <> [] then - strbrk " (with " ++ prlist_with_sep pr_coma (fun (id,c) -> - pr_id id ++ str ":=" ++ Printer.pr_lconstr c) - (List.rev vars @ unboundvars) ++ str ")" +let explain_ltac_call_trace (nrep,last,trace,loc) = + let calls = + (nrep,last) :: List.rev (List.map(fun(n,_,ck)->(n,ck))trace) in + let pr_call (n,ck) = + (match ck with + | Proof_type.LtacNotationCall s -> quote (str s) + | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Proof_type.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Proof_type.LtacAtomCall (te,otac) -> quote + (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (dummy_loc,te))) + ++ (match !otac with + | Some te' when (Obj.magic te' <> te) -> + strbrk " (expanded to " ++ quote + (Pptactic.pr_tactic (Global.env()) + (Tacexpr.TacAtom (dummy_loc,te'))) + ++ str ")" + | _ -> mt ()) + | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) -> + let filter = + function (id,None) -> None | (id,Some id') -> Some(id,([],mkVar id')) in + let unboundvars = list_map_filter filter unboundvars in + quote (pr_rawconstr_env (Global.env()) c) ++ + (if unboundvars <> [] or vars <> [] then + strbrk " (with " ++ + prlist_with_sep pr_comma + (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + (List.rev vars @ unboundvars) ++ str ")" + else mt())) ++ + (if n=2 then str " (repeated twice)" + else if n>2 then str " (repeated "++int n++str" times)" else mt()) in - if calls <> [] then - let kind_of_last_call = match list_last calls with - | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed." + if calls <> [] then + let kind_of_last_call = match list_last calls with + | (_,Proof_type.LtacConstrInterp _) -> ", last term evaluation failed." | _ -> ", last call failed." in - hov 0 (str "In nested Ltac calls to " ++ + hov 0 (str "In nested Ltac calls to " ++ pr_enum pr_call calls ++ strbrk kind_of_last_call) else mt () diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index ff5991de..848fec79 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: himsg.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Pp @@ -29,7 +29,7 @@ val explain_pretype_error : env -> pretype_error -> std_ppcmds val explain_inductive_error : inductive_error -> std_ppcmds -val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds +val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds @@ -41,5 +41,6 @@ val explain_pattern_matching_error : val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds -val explain_ltac_call_trace : - Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> std_ppcmds +val explain_ltac_call_trace : + int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> + std_ppcmds diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 4b97f8b2..492b21e0 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -6,97 +6,171 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ind_tables.ml 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) -open Names -open Mod_subst - -let eq_scheme_map = ref Indmap.empty - -let cache_scheme (_,(ind,const)) = - eq_scheme_map := Indmap.add ind const (!eq_scheme_map) - -let export_scheme obj = - Some obj - - - -let _ = Summary.declare_summary "eqscheme" - { Summary.freeze_function = (fun () -> !eq_scheme_map); - Summary.unfreeze_function = (fun fs -> eq_scheme_map := fs); - Summary.init_function = (fun () -> eq_scheme_map := Indmap.empty); - Summary.survive_module = false; - Summary.survive_section = true} - -let find_eq_scheme ind = - Indmap.find ind !eq_scheme_map - -let check_eq_scheme ind = - Indmap.mem ind !eq_scheme_map - -let bl_map = ref Indmap.empty -let lb_map = ref Indmap.empty -let dec_map = ref Indmap.empty - - -let cache_bl (_,(ind,const)) = - bl_map := Indmap.add ind const (!bl_map) - -let cache_lb (_,(ind,const)) = - lb_map := Indmap.add ind const (!lb_map) - -let cache_dec (_,(ind,const)) = - dec_map := Indmap.add ind const (!dec_map) - -let export_bool_leib obj = - Some obj - -let export_leib_bool obj = - Some obj - -let export_dec_proof obj = - Some obj - - - -let _ = Summary.declare_summary "bl_proof" - { Summary.freeze_function = (fun () -> !bl_map); - Summary.unfreeze_function = (fun fs -> bl_map := fs); - Summary.init_function = (fun () -> bl_map := Indmap.empty); - Summary.survive_module = false; - Summary.survive_section = true} - -let find_bl_proof ind = - Indmap.find ind !bl_map - -let check_bl_proof ind = - Indmap.mem ind !bl_map - -let _ = Summary.declare_summary "lb_proof" - { Summary.freeze_function = (fun () -> !lb_map); - Summary.unfreeze_function = (fun fs -> lb_map := fs); - Summary.init_function = (fun () -> lb_map := Indmap.empty); - Summary.survive_module = false; - Summary.survive_section = true} - -let find_lb_proof ind = - Indmap.find ind !lb_map - -let check_lb_proof ind = - Indmap.mem ind !lb_map - -let _ = Summary.declare_summary "eq_dec_proof" - { Summary.freeze_function = (fun () -> !dec_map); - Summary.unfreeze_function = (fun fs -> dec_map := fs); - Summary.init_function = (fun () -> dec_map := Indmap.empty); - Summary.survive_module = false; - Summary.survive_section = true} - -let find_eq_dec_proof ind = - Indmap.find ind !dec_map - -let check_dec_proof ind = - Indmap.mem ind !dec_map +(* File created by Vincent Siles, Oct 2007, extended into a generic + support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *) +(* This file provides support for registering inductive scheme builders, + declaring schemes and generating schemes on demand *) +open Names +open Mod_subst +open Libobject +open Nameops +open Declarations +open Term +open Util +open Declare +open Entries +open Decl_kinds + +(**********************************************************************) +(* Registering schemes in the environment *) + +type mutual_scheme_object_function = mutual_inductive -> constr array +type individual_scheme_object_function = inductive -> constr + +type 'a scheme_kind = string + +let scheme_map = ref Indmap.empty + +let cache_one_scheme kind (ind,const) = + let map = try Indmap.find ind !scheme_map with Not_found -> Stringmap.empty in + scheme_map := Indmap.add ind (Stringmap.add kind const map) !scheme_map + +let cache_scheme (_,(kind,l)) = + Array.iter (cache_one_scheme kind) l + +let subst_one_scheme subst ((mind,i),const) = + (* Remark: const is a def: the result of substitution is a constant *) + ((subst_ind subst mind,i),fst (subst_con subst const)) + +let subst_scheme (subst,(kind,l)) = + (kind,Array.map (subst_one_scheme subst) l) + +let discharge_scheme (_,(kind,l)) = + Some (kind,Array.map (fun (ind,const) -> + (Lib.discharge_inductive ind,Lib.discharge_con const)) l) + +let (inScheme,_) = + declare_object {(default_object "SCHEME") with + cache_function = cache_scheme; + load_function = (fun _ -> cache_scheme); + subst_function = subst_scheme; + classify_function = (fun obj -> Substitute obj); + discharge_function = discharge_scheme} + +(**********************************************************************) +(* Saving/restoring the table of scheme *) + +let freeze_schemes () = !scheme_map +let unfreeze_schemes sch = scheme_map := sch +let init_schemes () = scheme_map := Indmap.empty + +let _ = + Summary.declare_summary "Schemes" + { Summary.freeze_function = freeze_schemes; + Summary.unfreeze_function = unfreeze_schemes; + Summary.init_function = init_schemes } + +(**********************************************************************) +(* The table of scheme building functions *) + +type individual +type mutual + +type scheme_object_function = + | MutualSchemeFunction of (mutual_inductive -> constr array) + | IndividualSchemeFunction of (inductive -> constr) + +let scheme_object_table = + (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) + +let declare_scheme_object s aux f = + (try check_ident ("ind"^s) with _ -> + error ("Illegal induction scheme suffix: "^s)); + let key = if aux = "" then s else aux in + try + let _ = Hashtbl.find scheme_object_table key in +(* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) + error ("Scheme object "^key^" already declared.") + with Not_found -> + Hashtbl.add scheme_object_table key (s,f); + key + +let declare_mutual_scheme_object s ?(aux="") f = + declare_scheme_object s aux (MutualSchemeFunction f) + +let declare_individual_scheme_object s ?(aux="") f = + declare_scheme_object s aux (IndividualSchemeFunction f) + +(**********************************************************************) +(* Defining/retrieving schemes *) + +let declare_scheme kind indcl = + Lib.add_anonymous_leaf (inScheme (kind,indcl)) + +let define internal id c = + (* TODO: specify even more by distinguish between KernelVerbose and + * UserVerbose *) + let fd = match internal with + | KernelSilent -> declare_internal_constant + | _ -> declare_constant in + let kn = fd id + (DefinitionEntry + { const_entry_body = c; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Flags.boxed_definitions() }, + Decl_kinds.IsDefinition Scheme) in + (match internal with + | KernelSilent -> () + | _-> definition_message id); + kn + +let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) = + let c = f ind in + let mib = Global.lookup_mind mind in + let id = match idopt with + | Some id -> id + | None -> add_suffix mib.mind_packets.(i).mind_typename suff in + let const = define internal id c in + declare_scheme kind [|ind,const|]; + const + +let define_individual_scheme kind internal names (mind,i as ind) = + match Hashtbl.find scheme_object_table kind with + | _,MutualSchemeFunction f -> assert false + | s,IndividualSchemeFunction f -> + define_individual_scheme_base kind s f internal names ind + +let define_mutual_scheme_base kind suff f internal names mind = + let cl = f mind in + let mib = Global.lookup_mind mind in + let ids = Array.init (Array.length mib.mind_packets) (fun i -> + try List.assoc i names + with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in + let consts = array_map2 (define internal) ids cl in + declare_scheme kind (Array.mapi (fun i cst -> ((mind,i),cst)) consts); + consts + +let define_mutual_scheme kind internal names mind = + match Hashtbl.find scheme_object_table kind with + | _,IndividualSchemeFunction _ -> assert false + | s,MutualSchemeFunction f -> + define_mutual_scheme_base kind s f internal names mind + +let find_scheme kind (mind,i as ind) = + try Stringmap.find kind (Indmap.find ind !scheme_map) + with Not_found -> + match Hashtbl.find scheme_object_table kind with + | s,IndividualSchemeFunction f -> + define_individual_scheme_base kind s f KernelSilent None ind + | s,MutualSchemeFunction f -> + (define_mutual_scheme_base kind s f KernelSilent [] mind).(i) + +let check_scheme kind ind = + try let _ = Stringmap.find kind (Indmap.find ind !scheme_map) in true + with Not_found -> false diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index 2edb294f..a8012bc7 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -11,30 +11,42 @@ open Names open Libnames open Mod_subst open Sign +open Declarations +(* This module provides support for registering inductive scheme builders, + declaring schemes and generating schemes on demand *) -val cache_scheme :(object_name*(Indmap.key*constr)) -> unit -val export_scheme : (Indmap.key*constr) -> (Indmap.key*constr) option +(* A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *) -val find_eq_scheme : Indmap.key -> constr -val check_eq_scheme : Indmap.key -> bool +type mutual +type individual +type 'a scheme_kind -val cache_bl: (object_name*(Indmap.key*constr)) -> unit -val cache_lb: (object_name*(Indmap.key*constr)) -> unit -val cache_dec : (object_name*(Indmap.key*constr)) -> unit +type mutual_scheme_object_function = mutual_inductive -> constr array +type individual_scheme_object_function = inductive -> constr -val export_bool_leib : (Indmap.key*constr) -> (Indmap.key*constr) option -val export_leib_bool : (Indmap.key*constr) -> (Indmap.key*constr) option -val export_dec_proof : (Indmap.key*constr) -> (Indmap.key*constr) option +(* Main functions to register a scheme builder *) -val find_bl_proof : Indmap.key -> constr -val find_lb_proof : Indmap.key -> constr -val find_eq_dec_proof : Indmap.key -> constr +val declare_mutual_scheme_object : string -> ?aux:string -> + mutual_scheme_object_function -> mutual scheme_kind -val check_bl_proof: Indmap.key -> bool -val check_lb_proof: Indmap.key -> bool -val check_dec_proof: Indmap.key -> bool +val declare_individual_scheme_object : string -> ?aux:string -> + individual_scheme_object_function -> individual scheme_kind +(* +val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit +*) +(* Force generation of a (mutually) scheme with possibly user-level names *) +val define_individual_scheme : individual scheme_kind -> + Declare.internal_flag (* internal *) -> + identifier option -> inductive -> constant +val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (* internal *) -> + (int * identifier) list -> mutual_inductive -> constant array + +(* Main function to retrieve a scheme in the cache or to generate it *) +val find_scheme : 'a scheme_kind -> inductive -> constant + +val check_scheme : 'a scheme_kind -> inductive -> bool diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml new file mode 100644 index 00000000..58f77b90 --- /dev/null +++ b/toplevel/indschemes.ml @@ -0,0 +1,460 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(* Created by Hugo Herbelin from contents related to inductive schemes + initially developed by Christine Paulin (induction schemes), Vincent + Siles (decidable equality and boolean equality) and Matthieu Sozeau + (combined scheme) in file command.ml, Sep 2009 *) + +(* This file provides entry points for manually or automatically + declaring new schemes *) + +open Pp +open Flags +open Util +open Names +open Declarations +open Entries +open Term +open Inductive +open Decl_kinds +open Indrec +open Declare +open Libnames +open Goptions +open Nameops +open Termops +open Typeops +open Inductiveops +open Pretyping +open Topconstr +open Nametab +open Smartlocate +open Vernacexpr +open Ind_tables +open Auto_ind_decl +open Eqschemes +open Elimschemes + +(* Flags governing automatic synthesis of schemes *) + +let elim_flag = ref true +let _ = + declare_bool_option + { optsync = true; + optname = "automatic declaration of induction schemes"; + optkey = ["Elimination";"Schemes"]; + optread = (fun () -> !elim_flag) ; + optwrite = (fun b -> elim_flag := b) } + +let case_flag = ref true +let _ = + declare_bool_option + { optsync = true; + optname = "automatic declaration of case analysis schemes"; + optkey = ["Case";"Analysis";"Schemes"]; + optread = (fun () -> !case_flag) ; + optwrite = (fun b -> case_flag := b) } + +let eq_flag = ref true +let _ = + declare_bool_option + { optsync = true; + optname = "automatic declaration of boolean equality"; + optkey = ["Boolean";"Equality";"Schemes"]; + optread = (fun () -> !eq_flag) ; + optwrite = (fun b -> eq_flag := b) } +let _ = (* compatibility *) + declare_bool_option + { optsync = true; + optname = "automatic declaration of boolean equality"; + optkey = ["Equality";"Scheme"]; + optread = (fun () -> !eq_flag) ; + optwrite = (fun b -> eq_flag := b) } + +let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 + +let eq_dec_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optname = "automatic declaration of decidable equality"; + optkey = ["Decidable";"Equality";"Schemes"]; + optread = (fun () -> !eq_dec_flag) ; + optwrite = (fun b -> eq_dec_flag := b) } + +let rewriting_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optname ="automatic declaration of rewriting schemes for equality types"; + optkey = ["Rewriting";"Schemes"]; + optread = (fun () -> !rewriting_flag) ; + optwrite = (fun b -> rewriting_flag := b) } + +(* Util *) + +let define id internal c t = + (* TODO: specify even more by distinguish KernelVerbose and UserVerbose *) + let f = match internal with + | KernelSilent -> declare_internal_constant + | _ -> declare_constant in + let kn = f id + (DefinitionEntry + { const_entry_body = c; + const_entry_type = t; + const_entry_opaque = false; + const_entry_boxed = Flags.boxed_definitions() }, + Decl_kinds.IsDefinition Scheme) in + definition_message id; + kn + +(* Boolean equality *) + +let declare_beq_scheme_gen internal names kn = + ignore (define_mutual_scheme beq_scheme_kind internal names kn) + +let alarm what internal msg = + let debug = false in + (* TODO: specify even more by distinguish KernelVerbose and UserVerbose *) + match internal with + | KernelSilent -> + (if debug then + Flags.if_verbose Pp.msg_warning + (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) + | _ -> errorlabstrm "" msg + +let try_declare_scheme what f internal names kn = + try f internal names kn + with + | ParameterWithoutEquality cst -> + alarm what internal + (str "Boolean equality not found for parameter " ++ pr_con cst ++ + str".") + | InductiveWithProduct -> + alarm what internal + (str "Unable to decide equality of functional arguments.") + | InductiveWithSort -> + alarm what internal + (str "Unable to decide equality of type arguments.") + | NonSingletonProp ind -> + alarm what internal + (str "Cannot extract computational content from proposition " ++ + quote (Printer.pr_inductive (Global.env()) ind) ++ str ".") + | EqNotFound (ind',ind) -> + alarm what internal + (str "Boolean equality on " ++ + quote (Printer.pr_inductive (Global.env()) ind') ++ + strbrk " is missing.") + | UndefinedCst s -> + alarm what internal + (strbrk "Required constant " ++ str s ++ str " undefined.") + | AlreadyDeclared msg -> + alarm what internal (msg ++ str ".") + | _ -> + alarm what internal + (str "Unknown exception during scheme creation.") + +let beq_scheme_msg mind = + let mib = Global.lookup_mind mind in + (* TODO: mutual inductive case *) + str "Boolean equality on " ++ + pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind)) + (list_tabulate (fun i -> (mind,i)) (Array.length mib.mind_packets)) + +let declare_beq_scheme_with l kn = + try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn + +(* TODO : maybe switch to KernelVerbose to have the right behaviour *) +let try_declare_beq_scheme kn = + (* TODO: handle Fix, see e.g. TheoryList.In_spec, eventually handle + proof-irrelevance; improve decidability by depending on decidability + for the parameters rather than on the bl and lb properties *) + try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen KernelSilent [] kn + +let declare_beq_scheme = declare_beq_scheme_with [] + +(* Case analysis schemes *) +(* TODO: maybe switch to KernelVerbose *) +let declare_one_case_analysis_scheme ind = + let (mib,mip) = Global.lookup_inductive ind in + let kind = inductive_sort_family mip in + let dep = if kind = InProp then case_scheme_kind_from_prop else case_dep_scheme_kind_from_type in + let kelim = elim_sorts (mib,mip) in + (* in case the inductive has a type elimination, generates only one + induction scheme, the other ones share the same code with the + apropriate type *) + if List.mem InType kelim then + ignore (define_individual_scheme dep KernelSilent None ind) + +(* Induction/recursion schemes *) + +let kinds_from_prop = + [InType,rect_scheme_kind_from_prop; + InProp,ind_scheme_kind_from_prop; + InSet,rec_scheme_kind_from_prop] + +let kinds_from_type = + [InType,rect_dep_scheme_kind_from_type; + InProp,ind_dep_scheme_kind_from_type; + InSet,rec_dep_scheme_kind_from_type] + + (* TODO: maybe switch to kernel verbose *) +let declare_one_induction_scheme ind = + let (mib,mip) = Global.lookup_inductive ind in + let kind = inductive_sort_family mip in + let from_prop = kind = InProp in + let kelim = elim_sorts (mib,mip) in + let elims = + list_map_filter (fun (sort,kind) -> + if List.mem sort kelim then Some kind else None) + (if from_prop then kinds_from_prop else kinds_from_type) in + List.iter (fun kind -> ignore (define_individual_scheme kind KernelSilent None ind)) + elims + +let declare_induction_schemes kn = + let mib = Global.lookup_mind kn in + if mib.mind_finite then begin + for i = 0 to Array.length mib.mind_packets - 1 do + declare_one_induction_scheme (kn,i); + done; + end + +(* Decidable equality *) + +let declare_eq_decidability_gen internal names kn = + let mib = Global.lookup_mind kn in + if mib.mind_finite then + ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn) + +let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) + str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind) + +let declare_eq_decidability_scheme_with l kn = + try_declare_scheme (eq_dec_scheme_msg (kn,0)) + declare_eq_decidability_gen UserVerbose l kn + +(* TODO: maybe switch to kernel verbose *) +let try_declare_eq_decidability kn = + try_declare_scheme (eq_dec_scheme_msg (kn,0)) + declare_eq_decidability_gen KernelSilent [] kn + +let declare_eq_decidability = declare_eq_decidability_scheme_with [] + +let ignore_error f x = try ignore (f x) with _ -> () + +let declare_rewriting_schemes ind = + if Hipattern.is_inductive_equality ind then begin + ignore (define_individual_scheme rew_r2l_scheme_kind KernelSilent None ind); + ignore (define_individual_scheme rew_r2l_dep_scheme_kind KernelSilent None ind); + ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind + KernelSilent None ind); + (* These ones expect the equality to be symmetric; the first one also *) + (* needs eq *) + ignore_error (define_individual_scheme rew_l2r_scheme_kind KernelSilent None) ind; + ignore_error + (define_individual_scheme rew_l2r_dep_scheme_kind KernelSilent None) ind; + ignore_error + (define_individual_scheme rew_l2r_forward_dep_scheme_kind KernelSilent None) ind + end + +(* TODO: maybe switch to kernel verbose *) +let declare_congr_scheme ind = + if Hipattern.is_equality_type (mkInd ind) then begin + if + try Coqlib.check_required_library Coqlib.logic_module_name; true + with _ -> false + then + ignore (define_individual_scheme congr_scheme_kind KernelSilent None ind) + else + warning "Cannot build congruence scheme because eq is not found" + end + +(* TODO: maybe switch to kernel verbose *) +let declare_sym_scheme ind = + if Hipattern.is_inductive_equality ind then + (* Expect the equality to be symmetric *) + ignore_error (define_individual_scheme sym_scheme_kind KernelSilent None) ind + +(* Scheme command *) + +let rec split_scheme l = + let env = Global.env() in + match l with + | [] -> [],[] + | (Some id,t)::q -> let l1,l2 = split_scheme q in + ( match t with + | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 + | EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2) + ) +(* + if no name has been provided, we build one from the types of the ind +requested +*) + | (None,t)::q -> + let l1,l2 = split_scheme q in + ( match t with + | InductionScheme (x,y,z) -> + let ind = smart_global_inductive y in + let sort_of_ind = Retyping.get_sort_family_of env Evd.empty (mkInd ind) in + let z' = family_of_sort (interp_sort z) in + let suffix = ( + match sort_of_ind with + | InProp -> + if x then (match z' with + | InProp -> "_ind_nodep" + | InSet -> "_rec_nodep" + | InType -> "_rect_nodep") + else ( match z' with + | InProp -> "_ind" + | InSet -> "_rec" + | InType -> "_rect" ) + | _ -> + if x then (match z' with + | InProp -> "_ind" + | InSet -> "_rec" + | InType -> "_rect" ) + else (match z' with + | InProp -> "_ind_dep" + | InSet -> "_rec_dep" + | InType -> "_rect_dep") + ) in + let newid = add_suffix (basename_of_global (IndRef ind)) suffix in + let newref = (dummy_loc,newid) in + ((newref,x,ind,z)::l1),l2 + | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) + ) + +let do_mutual_induction_scheme lnamedepindsort = + let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort + and sigma = Evd.empty + and env0 = Global.env() in + let lrecspec = + List.map + (fun (_,dep,ind,sort) -> (ind,dep,interp_elimination_sort sort)) + lnamedepindsort + in + let listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in + let rec declare decl fi lrecref = + let decltype = Retyping.get_type_of env0 Evd.empty decl in + let decltype = refresh_universes decltype in + let cst = define fi UserVerbose decl (Some decltype) in + ConstRef cst :: lrecref + in + let _ = List.fold_right2 declare listdecl lrecnames [] in + fixpoint_message None lrecnames + +let get_common_underlying_mutual_inductive = function + | [] -> assert false + | (id,(mind,i as ind))::l as all -> + match List.filter (fun (_,(mind',_)) -> mind <> mind') l with + | (_,ind')::_ -> + raise (RecursionSchemeError (NotMutualInScheme (ind,ind'))) + | [] -> + if not (list_distinct (List.map snd (List.map snd all))) then + error "A type occurs twice"; + mind, + list_map_filter + (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all + +let do_scheme l = + let ischeme,escheme = split_scheme l in +(* we want 1 kind of scheme at a time so we check if the user +tried to declare different schemes at once *) + if (ischeme <> []) && (escheme <> []) + then + error "Do not declare equality and induction scheme at the same time." + else ( + if ischeme <> [] then do_mutual_induction_scheme ischeme + else + let mind,l = get_common_underlying_mutual_inductive escheme in + declare_beq_scheme_with l mind; + declare_eq_decidability_scheme_with l mind + ) + +(**********************************************************************) +(* Combined scheme *) +(* Matthieu Sozeau, Dec 2006 *) + +let list_split_rev_at index l = + let rec aux i acc = function + hd :: tl when i = index -> acc, tl + | hd :: tl -> aux (succ i) (hd :: acc) tl + | [] -> failwith "list_split_when: Invalid argument" + in aux 0 [] l + +let fold_left' f = function + [] -> raise (Invalid_argument "fold_left'") + | hd :: tl -> List.fold_left f hd tl + +let build_combined_scheme env schemes = + let defs = List.map (fun cst -> (cst, Typeops.type_of_constant env cst)) schemes in +(* let nschemes = List.length schemes in *) + let find_inductive ty = + let (ctx, arity) = decompose_prod ty in + let (_, last) = List.hd ctx in + match kind_of_term last with + | App (ind, args) -> + let ind = destInd ind in + let (_,spec) = Inductive.lookup_mind_specif env ind in + ctx, ind, spec.mind_nrealargs + | _ -> ctx, destInd last, 0 + in + let (c, t) = List.hd defs in + let ctx, ind, nargs = find_inductive t in + (* Number of clauses, including the predicates quantification *) + let prods = nb_prod t - (nargs + 1) in + let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in + let relargs = rel_vect 0 prods in + let concls = List.rev_map + (fun (cst, t) -> + mkApp(mkConst cst, relargs), + snd (decompose_prod_n prods t)) defs in + let concl_bod, concl_typ = + fold_left' + (fun (accb, acct) (cst, x) -> + mkApp (coqconj, [| x; acct; cst; accb |]), + mkApp (coqand, [| x; acct |])) concls + in + let ctx, _ = + list_split_rev_at prods + (List.rev_map (fun (x, y) -> x, None, y) ctx) in + let typ = it_mkProd_wo_LetIn concl_typ ctx in + let body = it_mkLambda_or_LetIn concl_bod ctx in + (body, typ) + +let do_combined_scheme name schemes = + let csts = + List.map (fun x -> + let refe = Ident x in + let qualid = qualid_of_reference refe in + try Nametab.locate_constant (snd qualid) + with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) + schemes + in + let body,typ = build_combined_scheme (Global.env ()) csts in + ignore (define (snd name) UserVerbose body (Some typ)); + fixpoint_message None [snd name] + +(**********************************************************************) + +let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done + +let mutual_inductive_size kn = Array.length (Global.lookup_mind kn).mind_packets + +let declare_default_schemes kn = + let n = mutual_inductive_size kn in + if !elim_flag then declare_induction_schemes kn; + if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; + if is_eq_flag() then try_declare_beq_scheme kn; + if !eq_dec_flag then try_declare_eq_decidability kn; + if !rewriting_flag then map_inductive_block declare_congr_scheme kn n; + if !rewriting_flag then map_inductive_block declare_sym_scheme kn n; + if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli new file mode 100644 index 00000000..9aa32b7b --- /dev/null +++ b/toplevel/indschemes.mli @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id$ i*) + +(*i*) +open Util +open Names +open Term +open Environ +open Libnames +open Rawterm +open Genarg +open Vernacexpr +open Ind_tables +(*i*) + +(* See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *) + +(* Build and register the boolean equalities associated to an inductive type *) + +val declare_beq_scheme : mutual_inductive -> unit + +val declare_eq_decidability : mutual_inductive -> unit + +(* Build and register a congruence scheme for an equality-like inductive type *) + +val declare_congr_scheme : inductive -> unit + +(* Build and register rewriting schemes for an equality-like inductive type *) + +val declare_rewriting_schemes : inductive -> unit + +(* Mutual Minimality/Induction scheme *) + +val do_mutual_induction_scheme : + (identifier located * bool * inductive * rawsort) list -> unit + +(* Main calls to interpret the Scheme command *) + +val do_scheme : (identifier located option * scheme) list -> unit + +(* Combine a list of schemes into a conjunction of them *) + +val build_combined_scheme : env -> constant list -> constr * types + +val do_combined_scheme : identifier located -> identifier located list -> unit + +(* Hook called at each inductive type definition *) + +val declare_default_schemes : mutual_inductive -> unit diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml new file mode 100644 index 00000000..446d6315 --- /dev/null +++ b/toplevel/lemmas.ml @@ -0,0 +1,347 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(* Created by Hugo Herbelin from contents related to lemma proofs in + file command.ml, Aug 2009 *) + +open Util +open Flags +open Pp +open Names +open Term +open Declarations +open Entries +open Environ +open Nameops +open Libnames +open Decls +open Decl_kinds +open Declare +open Pretyping +open Termops +open Namegen +open Evd +open Evarutil +open Reductionops +open Topconstr +open Constrintern +open Impargs +open Tacticals + +(* Support for mutually proved theorems *) + +let retrieve_first_recthm = function + | VarRef id -> + (pi2 (Global.lookup_named id),variable_opacity id) + | ConstRef cst -> + let {const_body=body;const_opaque=opaq} = Global.lookup_constant cst in + (Option.map Declarations.force body,opaq) + | _ -> assert false + +let adjust_guardness_conditions const = function + | [] -> const (* Not a recursive statement *) + | possible_indexes -> + (* Try all combinations... not optimal *) + match kind_of_term const.const_entry_body with + | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> +(* let possible_indexes = + List.map2 (fun i c -> match i with Some i -> i | None -> + interval 0 (List.length ((lam_assum c)))) + lemma_guard (Array.to_list fixdefs) in +*) + let indexes = + search_guard dummy_loc (Global.env()) possible_indexes fixdecls in + { const with const_entry_body = mkFix ((indexes,0),fixdecls) } + | c -> const + +let find_mutually_recursive_statements thms = + let n = List.length thms in + let inds = List.map (fun (id,(t,impls,annot)) -> + let (hyps,ccl) = decompose_prod_assum t in + let x = (id,(t,impls)) in + match annot with + (* Explicit fixpoint decreasing argument is given *) + | Some (Some (_,id),CStructRec) -> + let i,b,typ = lookup_rel_id id hyps in + (match kind_of_term t with + | Ind (kn,_ as ind) when + let mind = Global.lookup_mind kn in + mind.mind_finite & b = None -> + [ind,x,i],[] + | _ -> + error "Decreasing argument is not an inductive assumption.") + (* Unsupported cases *) + | Some (_,(CWfRec _|CMeasureRec _)) -> + error "Only structural decreasing is supported for mutual statements." + (* Cofixpoint or fixpoint w/o explicit decreasing argument *) + | None | Some (None, CStructRec) -> + let whnf_hyp_hds = map_rel_context_in_env + (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c)) + (Global.env()) hyps in + let ind_hyps = + List.flatten (list_map_i (fun i (_,b,t) -> + match kind_of_term t with + | Ind (kn,_ as ind) when + let mind = Global.lookup_mind kn in + mind.mind_finite & b = None -> + [ind,x,i] + | _ -> + []) 0 (List.rev whnf_hyp_hds)) in + let ind_ccl = + let cclenv = push_rel_context hyps (Global.env()) in + let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in + match kind_of_term whnf_ccl with + | Ind (kn,_ as ind) when + let mind = Global.lookup_mind kn in + mind.mind_ntypes = n & not mind.mind_finite -> + [ind,x,0] + | _ -> + [] in + ind_hyps,ind_ccl) thms in + let inds_hyps,ind_ccls = List.split inds in + let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in + (* Check if all conclusions are coinductive in the same type *) + (* (degenerated cartesian product since there is at most one coind ccl) *) + let same_indccl = + list_cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] ind_ccls in + let ordered_same_indccl = + List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in + (* Check if some hypotheses are inductive in the same type *) + let common_same_indhyp = + list_cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] inds_hyps in + let ordered_inds,finite,guard = + match ordered_same_indccl, common_same_indhyp with + | indccl::rest, _ -> + assert (rest=[]); + (* One occ. of common coind ccls and no common inductive hyps *) + if common_same_indhyp <> [] then + if_verbose warning "Assuming mutual coinductive statements."; + flush_all (); + indccl, true, [] + | [], _::_ -> + if same_indccl <> [] && + list_distinct (List.map pi1 (List.hd same_indccl)) then + if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all (); + let possible_guards = List.map (List.map pi3) inds_hyps in + (* assume the largest indices as possible *) + list_last common_same_indhyp, false, possible_guards + | _, [] -> + error + ("Cannot find common (mutual) inductive premises or coinductive" ^ + " conclusions in the statements.") + in + (finite,guard,None), ordered_inds + +let look_for_possibly_mutual_statements = function + | [id,(t,impls,None)] -> + (* One non recursively proved theorem *) + None,[id,(t,impls)],None + | _::_ as thms -> + (* More than one statement and/or an explicit decreasing mark: *) + (* we look for a common inductive hyp or a common coinductive conclusion *) + let recguard,ordered_inds = find_mutually_recursive_statements thms in + let thms = List.map pi2 ordered_inds in + Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) + | [] -> anomaly "Empty list of theorems." + +(* Saving a goal *) + +let save id const do_guard (locality,kind) hook = + let const = adjust_guardness_conditions const do_guard in + let {const_entry_body = pft; + const_entry_type = tpo; + const_entry_opaque = opacity } = const in + let k = logical_kind_of_goal_kind kind in + let l,r = match locality with + | Local when Lib.sections_are_opened () -> + let c = SectionLocalDef (pft, tpo, opacity) in + let _ = declare_variable id (Lib.cwd(), c, k) in + (Local, VarRef id) + | Local | Global -> + let kn = declare_constant id (DefinitionEntry const, k) in + Autoinstance.search_declaration (ConstRef kn); + (Global, ConstRef kn) in + Pfedit.delete_current_proof (); + definition_message id; + hook l r + +let save_hook = ref ignore +let set_save_hook f = save_hook := f + +let save_named opacity = + let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in + let const = { const with const_entry_opaque = opacity } in + save id const do_guard persistence hook + +let default_thm_id = id_of_string "Unnamed_thm" + +let compute_proof_name locality = function + | Some (loc,id) -> + (* We check existence here: it's a bit late at Qed time *) + if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || + locality=Global && Nametab.exists_cci (Lib.make_path_except_section id) + then + user_err_loc (loc,"",pr_id id ++ str " already exists."); + id + | None -> + next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) + +let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) = + match body with + | None -> + (match local with + | Local -> + let impl=false in (* copy values from Vernacentries *) + let k = IsAssumption Conjectural in + let c = SectionLocalAssum (t_i,impl) in + let _ = declare_variable id (Lib.cwd(),c,k) in + (Local,VarRef id,imps) + | Global -> + let k = IsAssumption Conjectural in + let kn = declare_constant id (ParameterEntry (t_i,false), k) in + (Global,ConstRef kn,imps)) + | Some body -> + let k = logical_kind_of_goal_kind kind in + let body_i = match kind_of_term body with + | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) + | CoFix (0,decls) -> mkCoFix (i,decls) + | _ -> anomaly "Not a proof by induction" in + match local with + | Local -> + let c = SectionLocalDef (body_i, Some t_i, opaq) in + let _ = declare_variable id (Lib.cwd(), c, k) in + (Local,VarRef id,imps) + | Global -> + let const = + { const_entry_body = body_i; + const_entry_type = Some t_i; + const_entry_opaque = opaq; + const_entry_boxed = false (* copy of what cook_proof does *)} in + let kn = declare_constant id (DefinitionEntry const, k) in + (Global,ConstRef kn,imps) + +(* 4.2| General support for goals *) + +let check_anonymity id save_ident = + if atompart_of_id id <> "Unnamed_thm" then + error "This command can only be used for unnamed theorem." + +let save_anonymous opacity save_ident = + let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in + let const = { const with const_entry_opaque = opacity } in + check_anonymity id save_ident; + save save_ident const do_guard persistence hook + +let save_anonymous_with_strength kind opacity save_ident = + let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in + let const = { const with const_entry_opaque = opacity } in + check_anonymity id save_ident; + (* we consider that non opaque behaves as local for discharge *) + save save_ident const do_guard (Global, Proof kind) hook + +(* Starting a goal *) + +let start_hook = ref ignore +let set_start_hook = (:=) start_hook + +let start_proof id kind c ?init_tac ?(compute_guard=[]) hook = + let sign = Global.named_context () in + let sign = clear_proofs sign in + !start_hook c; + Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook + +let rec_tac_initializer finite guard thms snl = + if finite then + match List.map (fun (id,(t,_)) -> (id,t)) thms with + | (id,_)::l -> Hiddentac.h_mutual_cofix true id l + | _ -> assert false + else + (* nl is dummy: it will be recomputed at Qed-time *) + let nl = match snl with + | None -> List.map succ (List.map list_last guard) + | Some nl -> nl + in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with + | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l + | _ -> assert false + +let start_proof_with_initialization kind recguard thms snl hook = + let intro_tac (_, (_, (ids, _))) = + Refiner.tclMAP (function + | Name id -> Tactics.intro_mustbe_force id + | Anonymous -> Tactics.intro) (List.rev ids) in + let init_tac,guard = match recguard with + | Some (finite,guard,init_tac) -> + let rec_tac = rec_tac_initializer finite guard thms snl in + Some (match init_tac with + | None -> + if Flags.is_auto_intros () then + tclTHENS rec_tac (List.map intro_tac thms) + else + rec_tac + | Some tacl -> + tclTHENS rec_tac + (if Flags.is_auto_intros () then + List.map2 (fun tac thm -> tclTHEN tac (intro_tac thm)) tacl thms + else + tacl)),guard + | None -> + assert (List.length thms = 1); + (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in + match thms with + | [] -> anomaly "No proof to start" + | (id,(t,(_,imps)))::other_thms -> + let hook strength ref = + let other_thms_data = + if other_thms = [] then [] else + (* there are several theorems defined mutually *) + let body,opaq = retrieve_first_recthm ref in + list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in + let thms_data = (strength,ref,imps)::other_thms_data in + List.iter (fun (strength,ref,imps) -> + maybe_declare_manual_implicits false ref imps; + hook strength ref) thms_data in + start_proof id kind t ?init_tac hook ~compute_guard:guard + +let start_proof_com kind thms hook = + let evdref = ref (create_evar_defs Evd.empty) in + let env0 = Global.env () in + let thms = List.map (fun (sopt,(bl,t,guard)) -> + let (env, ctx), imps = interp_context_evars evdref env0 bl in + let t', imps' = interp_type_evars_impls ~evdref env t in + Sign.iter_rel_context (check_evars env Evd.empty !evdref) ctx; + let ids = List.map pi1 ctx in + (compute_proof_name (fst kind) sopt, + (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), + (ids, imps @ lift_implicits (List.length ids) imps'), + guard))) + thms in + let recguard,thms,snl = look_for_possibly_mutual_statements thms in + start_proof_with_initialization kind recguard thms snl hook + +(* Admitted *) + +let admit () = + let (id,k,typ,hook) = Pfedit.current_proof_statement () in + let kn = + declare_constant id (ParameterEntry (typ,false),IsAssumption Conjectural) in + Pfedit.delete_current_proof (); + assumption_message id; + hook Global (ConstRef kn) + +(* Miscellaneous *) + +let get_current_context () = + try Pfedit.get_current_goal_context () + with e when Logic.catchable_exception e -> + (Evd.empty, Global.env()) diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli new file mode 100644 index 00000000..8af9b1e8 --- /dev/null +++ b/toplevel/lemmas.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.fix_expr *) +(************************************************************************) + +(*i $Id$ i*) + +(*i*) +open Names +open Term +open Decl_kinds +open Topconstr +open Tacexpr +open Vernacexpr +open Proof_type +open Pfedit +(*i*) + +(* A hook start_proof calls on the type of the definition being started *) +val set_start_hook : (types -> unit) -> unit + +val start_proof : identifier -> goal_kind -> types -> + ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> + declaration_hook -> unit + +val start_proof_com : goal_kind -> + (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list -> + declaration_hook -> unit + +val start_proof_with_initialization : + goal_kind -> (bool * lemma_possible_guards * tactic list option) option -> + (identifier * (types * (name list * Impargs.manual_explicitation list))) list + -> int list option -> declaration_hook -> unit + +(* A hook the next three functions pass to cook_proof *) +val set_save_hook : (Refiner.pftreestate -> unit) -> unit + +(*s [save_named b] saves the current completed proof under the name it +was started; boolean [b] tells if the theorem is declared opaque; it +fails if the proof is not completed *) + +val save_named : bool -> unit + +(* [save_anonymous b name] behaves as [save_named] but declares the theorem +under the name [name] and respects the strength of the declaration *) + +val save_anonymous : bool -> identifier -> unit + +(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but + declares the theorem under the name [name] and gives it the + strength [strength] *) + +val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit + +(* [admit ()] aborts the current goal and save it as an assmumption *) + +val admit : unit -> unit + +(* [get_current_context ()] returns the evar context and env of the + current open proof if any, otherwise returns the empty evar context + and the current global env *) + +val get_current_context : unit -> Evd.evar_map * Environ.env diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml new file mode 100644 index 00000000..04064025 --- /dev/null +++ b/toplevel/libtypes.ml @@ -0,0 +1,111 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Term +open Summary +open Libobject +open Libnames +open Names +(* + * Module construction + *) + +(* let reduce c = Reductionops.head_unfold_under_prod *) +(* (Auto.Hint_db.transparent_state (Auto.searchtable_map "typeclass_instances")) *) +(* (Global.env()) Evd.empty c *) + +let reduce c = c + +module TypeDnet = Term_dnet.Make + (struct + type t = Libnames.global_reference + let compare = RefOrdered.compare + let subst s gr = fst (Libnames.subst_global s gr) + let constr_of = Global.type_of_global + end) + (struct let reduce = reduce + let direction = false + end) + +type result = Libnames.global_reference * (constr*existential_key) * Termops.subst + +let all_types = ref TypeDnet.empty +let defined_types = ref TypeDnet.empty + +(* + * Bookeeping & States + *) + +let freeze () = + (!all_types,!defined_types) + +let unfreeze (lt,dt) = + all_types := lt; + defined_types := dt + +let init () = + all_types := TypeDnet.empty; + defined_types := TypeDnet.empty + +let _ = + declare_summary "type-library-state" + { freeze_function = freeze; + unfreeze_function = unfreeze; + init_function = init } + +let load (_,d) = +(* Profile.print_logical_stats !all_types; + Profile.print_logical_stats d;*) + all_types := TypeDnet.union d !all_types + +let subst s t = TypeDnet.subst s t +(* +let subst_key = Profile.declare_profile "subst" +let subst a b = Profile.profile2 subst_key TypeDnet.subst a b + +let load_key = Profile.declare_profile "load" +let load a = Profile.profile1 load_key load a +*) +let (input,output) = + declare_object + { (default_object "LIBTYPES") with + load_function = (fun _ -> load); + subst_function = (fun (s,t) -> subst s t); + classify_function = (fun x -> Substitute x) + } + +let update () = Lib.add_anonymous_leaf (input !defined_types) + +(* + * Search interface + *) + +let search_pattern pat = TypeDnet.search_pattern !all_types pat +let search_concl pat = TypeDnet.search_concl !all_types pat +let search_head_concl pat = TypeDnet.search_head_concl !all_types pat +let search_eq_concl eq pat = TypeDnet.search_eq_concl !all_types eq pat + +let add typ gr = + defined_types := TypeDnet.add typ gr !defined_types; + all_types := TypeDnet.add typ gr !all_types +(* +let add_key = Profile.declare_profile "add" +let add a b = Profile.profile1 add_key add a b +*) + +(* + * Hooks declaration + *) + +let _ = Declare.add_cache_hook + ( fun sp -> + let gr = Nametab.global_of_path sp in + let ty = Global.type_of_global gr in + add ty gr ) + +let _ = Declaremods.set_end_library_hook update diff --git a/toplevel/libtypes.mli b/toplevel/libtypes.mli new file mode 100644 index 00000000..d57ecb94 --- /dev/null +++ b/toplevel/libtypes.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id:$ *) + +(*i*) +open Term +(*i*) + +(* + * Persistent library of all declared object, + * indexed by their types (uses Dnets) + *) + +(* results are the reference of the object, together with a context +(constr+evar) and a substitution under this context *) +type result = Libnames.global_reference * (constr*existential_key) * Termops.subst + +(* this is the reduction function used in the indexing process *) +val reduce : types -> types + +(* The different types of search available. + * See term_dnet.mli for more explanations *) +val search_pattern : types -> result list +val search_concl : types -> result list +val search_head_concl : types -> result list +val search_eq_concl : constr -> types -> result list diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml deleted file mode 100644 index 77f5198a..00000000 --- a/toplevel/line_oriented_parser.ml +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: line_oriented_parser.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -let line_oriented_channel_to_option stop_string input_channel = - let count = ref 0 in - let buff = ref "" in - let current_length = ref 0 in - fun i -> - if (i - !count) >= !current_length then begin - count := !count + !current_length + 1; - buff := input_line input_channel; - if !buff = stop_string then - None - else begin - current_length := String.length !buff; - Some '\n' - end - end else - Some (String.get !buff (i - !count)) - -let flush_until_end_of_stream char_stream = - Stream.iter (function _ -> ()) char_stream diff --git a/toplevel/line_oriented_parser.mli b/toplevel/line_oriented_parser.mli deleted file mode 100644 index f37472c0..00000000 --- a/toplevel/line_oriented_parser.mli +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: line_oriented_parser.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -val line_oriented_channel_to_option: string -> in_channel -> int -> char option - -val flush_until_end_of_stream : 'a Stream.t -> unit diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 821a73f7..5e497846 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -6,9 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: metasyntax.ml 12882 2010-03-23 22:34:38Z herbelin $ *) +(* $Id$ *) open Pp +open Flags open Util open Names open Topconstr @@ -24,34 +25,39 @@ open Libnames open Lexer open Egrammar open Notation +open Nameops (**********************************************************************) (* Tokens *) -let cache_token (_,s) = Compat.using Pcoq.lexer ("", s) +let cache_token (_,s) = add_token ("", s) let (inToken, outToken) = declare_object {(default_object "TOKEN") with open_function = (fun i o -> if i=1 then cache_token o); cache_function = cache_token; subst_function = Libobject.ident_subst_function; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x)} + classify_function = (fun o -> Substitute o)} let add_token_obj s = Lib.add_anonymous_leaf (inToken s) (**********************************************************************) (* Tactic Notation *) +let interp_prod_item lev = function + | TacTerm s -> GramTerminal s + | TacNonTerm (loc, nt, po) -> + let sep = match po with Some (_,sep) -> sep | _ -> "" in + let (etyp, e) = interp_entry_name true (Some lev) nt sep in + GramNonTerminal (loc, etyp, e, Option.map fst po) + let make_terminal_status = function - | VTerm s -> Some s - | VNonTerm _ -> None - -let rec make_tags lev = function - | VTerm s :: l -> make_tags lev l - | VNonTerm (loc, nt, po) :: l -> - let (etyp, _) = Egrammar.interp_entry_name lev nt in - etyp :: make_tags lev l + | GramTerminal s -> Some s + | GramNonTerminal _ -> None + +let rec make_tags = function + | GramTerminal s :: l -> make_tags l + | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l | [] -> [] let cache_tactic_notation (_,(pa,pp)) = @@ -61,7 +67,7 @@ let cache_tactic_notation (_,(pa,pp)) = let subst_tactic_parule subst (key,n,p,(d,tac)) = (key,n,p,(d,Tacinterp.subst_tactic subst tac)) -let subst_tactic_notation (_,subst,(pa,pp)) = +let subst_tactic_notation (subst,(pa,pp)) = (subst_tactic_parule subst pa,pp) let (inTacticGrammar, outTacticGrammar) = @@ -69,15 +75,14 @@ let (inTacticGrammar, outTacticGrammar) = open_function = (fun i o -> if i=1 then cache_tactic_notation o); cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x)} + classify_function = (fun o -> Substitute o)} let cons_production_parameter l = function - | VTerm _ -> l - | VNonTerm (_,_,ido) -> Option.List.cons ido l + | GramTerminal _ -> l + | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l let rec tactic_notation_key = function - | VTerm id :: _ -> id + | GramTerminal id :: _ -> id | _ :: l -> tactic_notation_key l | [] -> "terminal_free_notation" @@ -86,7 +91,8 @@ let rec next_key_away key t = else key let add_tactic_notation (n,prods,e) = - let tags = make_tags n prods in + let prods = List.map (interp_prod_item n) prods in + let tags = make_tags prods in let key = next_key_away (tactic_notation_key prods) tags in let pprule = (key,tags,(n,List.map make_terminal_status prods)) in let ids = List.fold_left cons_production_parameter [] prods in @@ -109,14 +115,14 @@ let print_grammar = function Gram.Entry.print Pcoq.Constr.operconstr; | "pattern" -> Gram.Entry.print Pcoq.Constr.pattern - | "tactic" -> + | "tactic" -> msgnl (str "Entry tactic_expr is"); Gram.Entry.print Pcoq.Tactic.tactic_expr; msgnl (str "Entry binder_tactic is"); Gram.Entry.print Pcoq.Tactic.binder_tactic; msgnl (str "Entry simple_tactic is"); Gram.Entry.print Pcoq.Tactic.simple_tactic; - | "vernac" -> + | "vernac" -> msgnl (str "Entry vernac is"); Gram.Entry.print Pcoq.Vernac_.vernac; msgnl (str "Entry command is"); @@ -168,7 +174,7 @@ let parse_format (loc,str) = (* Parse " // " *) | '/' when i <= String.length str & str.[i+1] = '/' -> (* We forget the useless n spaces... *) - push_token (UnpCut PpFnl) + push_token (UnpCut PpFnl) (parse_token (close_quotation (i+2))) (* Parse " .. / .. " *) | '/' when i <= String.length str -> @@ -234,16 +240,14 @@ let parse_format (loc,str) = type symbol_token = WhiteSpace of int | String of string -(* Decompose the notation string into tokens *) - let split_notation_string str = let push_token beg i l = if beg = i then l else let s = String.sub str beg (i - beg) in - String s :: l + String s :: l in let push_whitespace beg i l = - if beg = i then l else WhiteSpace (i-beg) :: l + if beg = i then l else WhiteSpace (i-beg) :: l in let rec loop beg i = if i < String.length str then @@ -271,7 +275,7 @@ let out_nt = function NonTerminal x -> x | _ -> assert false let rec find_pattern nt xl = function | Break n as x :: l, Break n' :: l' when n=n' -> find_pattern nt (x::xl) (l,l') - | Terminal s as x :: l, Terminal s' :: l' when s = s' -> + | Terminal s as x :: l, Terminal s' :: l' when s = s' -> find_pattern nt (x::xl) (l,l') | [], NonTerminal x' :: l' -> (out_nt nt,x',List.rev xl),l' @@ -279,8 +283,10 @@ let rec find_pattern nt xl = function error ("The token "^s^" occurs on one side of \"..\" but not on the other side.") | [], Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") - | ((SProdList _ | NonTerminal _) :: _ | []), _ -> + | _, [] -> error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".") + | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> + anomaly "Only Terminal or Break expected on left, non-SProdList on right" let rec interp_list_parser hd = function | [] -> [], [], List.rev hd @@ -292,7 +298,7 @@ let rec interp_list_parser hd = function (* remove the second copy of it afterwards *) (y,x)::yl, x::xl, SProdList (x,sl) :: tl'' | (Terminal _ | Break _) as s :: tl -> - if hd = [] then + if hd = [] then let yl,xl,tl' = interp_list_parser [] tl in yl, xl, s :: tl' else @@ -305,10 +311,6 @@ let rec interp_list_parser hd = function (* Find non-terminal tokens of notation *) -let unquote_notation_token s = - let n = String.length s in - if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s - let is_normal_token str = try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false @@ -319,36 +321,43 @@ let quote_notation_token x = if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'" else x -let rec raw_analyse_notation_tokens = function - | [] -> [], [] - | String ".." :: sl -> - let (vars,l) = raw_analyse_notation_tokens sl in - (list_add_set ldots_var vars, NonTerminal ldots_var :: l) +let rec raw_analyze_notation_tokens = function + | [] -> [] + | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl | String "_" :: _ -> error "_ must be quoted." | String x :: sl when is_normal_token x -> Lexer.check_ident x; - let id = Names.id_of_string x in - let (vars,l) = raw_analyse_notation_tokens sl in - if List.mem id vars then - error ("Variable "^x^" occurs more than once."); - (id::vars, NonTerminal id :: l) + NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl | String s :: sl -> Lexer.check_keyword s; - let (vars,l) = raw_analyse_notation_tokens sl in - (vars, Terminal (unquote_notation_token s) :: l) + Terminal (drop_simple_quotes s) :: raw_analyze_notation_tokens sl | WhiteSpace n :: sl -> - let (vars,l) = raw_analyse_notation_tokens sl in - (vars, Break n :: l) + Break n :: raw_analyze_notation_tokens sl -let is_numeral symbs = +let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> (try let _ = Bigint.of_string x in true with _ -> false) | _ -> false -let analyse_notation_tokens l = - let vars,l = raw_analyse_notation_tokens l in +let rec get_notation_vars = function + | [] -> [] + | NonTerminal id :: sl -> + let vars = get_notation_vars sl in + if List.mem id vars then + if id <> ldots_var then + error ("Variable "^string_of_id id^" occurs more than once.") + else + vars + else + id::vars + | (Terminal _ | Break _) :: sl -> get_notation_vars sl + | SProdList _ :: _ -> assert false + +let analyze_notation_tokens l = + let l = raw_analyze_notation_tokens l in + let vars = get_notation_vars l in let extrarecvars,recvars,l = interp_list_parser [] l in (if extrarecvars = [] then [], [], vars, l else extrarecvars, recvars, list_subtract vars recvars, l) @@ -360,10 +369,10 @@ let remove_extravars extrarecvars (vars,recvars) = error "Two end variables of a recursive notation are not in the same scope." else - List.remove_assoc x l) + List.remove_assoc x l) extrarecvars (List.remove_assoc ldots_var vars) in (vars,recvars) - + (**********************************************************************) (* Build pretty-printing rules *) @@ -381,7 +390,6 @@ let precedence_of_entry_type from = function n, let (lp,rp) = prec_assoc a in if b=Left then lp else rp | ETConstr (NumLevel n,InternalProd) -> n, Prec n | ETConstr (NextLevel,_) -> from, L - | ETOther ("constr","annot") -> 10, Prec 10 | _ -> 0, E (* ?? *) (* Some breaking examples *) @@ -455,7 +463,7 @@ let make_hunks etyps symbols from = else if is_operator s then if ws = CanBreak then UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods) - else + else UnpTerminal s :: add_break 1 (make NoBreak prods) else if is_ident_tail s.[String.length s - 1] then let sep = if is_prod_ident (List.hd prods) then "" else " " in @@ -500,14 +508,14 @@ let error_format () = error "The format does not match the notation." let rec split_format_at_ldots hd = function | UnpTerminal s :: fmt when s = string_of_id ldots_var -> List.rev hd, fmt - | u :: fmt -> + | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt | [] -> raise Exit and check_no_ldots_in_box = function | UnpBox (_,fmt) -> - (try + (try let _ = split_format_at_ldots [] fmt in error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.") with Exit -> ()) @@ -531,19 +539,19 @@ let read_recursive_format sl fmt = let slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) -let hunks_of_format (from,(vars,typs)) symfmt = +let hunks_of_format (from,(vars,typs)) symfmt = let rec aux = function | symbs, (UnpTerminal s' as u) :: fmt when s' = String.make (String.length s') ' ' -> let symbs, l = aux (symbs,fmt) in symbs, u :: l | Terminal s :: symbs, (UnpTerminal s') :: fmt - when s = unquote_notation_token s' -> + when s = drop_simple_quotes s' -> let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' -> let i = list_index s vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l - | symbs, UnpBox (a,b) :: fmt -> + | symbs, UnpBox (a,b) :: fmt -> let symbs', b' = aux (symbs,b) in let symbs', l = aux (symbs',fmt) in symbs', UnpBox (a,b') :: l @@ -575,45 +583,62 @@ let is_not_small_constr = function | _ -> false let rec define_keywords_aux = function - NonTerm(_,Some(_,e)) as n1 :: Term("IDENT",k) :: l + | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal("IDENT",k) :: l when is_not_small_constr e -> message ("Defining '"^k^"' as keyword"); Lexer.add_token("",k); - n1 :: Term("",k) :: define_keywords_aux l + n1 :: GramConstrTerminal("",k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l | [] -> [] + (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function - Term("IDENT",k)::l -> + | GramConstrTerminal("IDENT",k)::l -> message ("Defining '"^k^"' as keyword"); Lexer.add_token("",k); - Term("",k) :: define_keywords_aux l + GramConstrTerminal("",k) :: define_keywords_aux l | l -> define_keywords_aux l +let distribute a ll = List.map (fun l -> a @ l) ll + + (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep) + as many times as expected in [n] argument *) +let rec expand_list_rule typ tkl x n i hds ll = + if i = n then + let hds = + GramConstrListMark (n,true) :: hds + @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in + distribute hds ll + else + let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in + let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in + let tks = List.map (fun x -> GramConstrTerminal x) tkl in + distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @ + expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll + let make_production etyps symbols = let prod = List.fold_right - (fun t l -> match t with + (fun t ll -> match t with | NonTerminal m -> let typ = List.assoc m etyps in - NonTerm (typ, Some (m,typ)) :: l + distribute [GramConstrNonTerminal (typ, Some m)] ll | Terminal s -> - Term (terminal s) :: l + distribute [GramConstrTerminal (terminal s)] ll | Break _ -> - l + ll | SProdList (x,sl) -> - let sl = List.flatten - (List.map (function Terminal s -> [terminal s] + let tkl = List.flatten + (List.map (function Terminal s -> [terminal s] | Break _ -> [] | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in - let y = match List.assoc x etyps with + let typ = match List.assoc x etyps with | ETConstr x -> x | _ -> error "Component of recursive patterns in notation must be constr." in - let typ = ETConstrList (y,sl) in - NonTerm (typ, Some (x,typ)) :: l) - symbols [] in - define_keywords prod + expand_list_rule typ tkl x 1 0 [] ll) + symbols [[]] in + List.map define_keywords prod let rec find_symbols c_current c_next c_last = function | [] -> [] @@ -622,7 +647,7 @@ let rec find_symbols c_current c_next c_last = function (id, prec) :: (find_symbols c_next c_next c_last sl) | Terminal s :: sl -> find_symbols c_next c_next c_last sl | Break n :: sl -> find_symbols c_current c_next c_last sl - | SProdList (x,_) :: sl' -> + | SProdList (x,_) :: sl' -> (x,c_next)::(find_symbols c_next c_next c_last sl') let border = function @@ -648,17 +673,17 @@ let pr_arg_level from = function let pr_level ntn (from,args) = str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ - prlist_with_sep pr_coma (pr_arg_level from) args + prlist_with_sep pr_comma (pr_arg_level from) args let error_incompatible_level ntn oldprec prec = errorlabstrm "" - (str ("Notation "^ntn^" is already defined") ++ spc() ++ - pr_level ntn oldprec ++ - spc() ++ str "while it is now required to be" ++ spc() ++ + (str ("Notation "^ntn^" is already defined") ++ spc() ++ + pr_level ntn oldprec ++ + spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") let cache_one_syntax_extension (prec,ntn,gr,pp) = - try + try let oldprec = Notation.level_of_notation ntn in if prec <> oldprec then error_incompatible_level ntn oldprec prec with Not_found -> @@ -676,23 +701,19 @@ let subst_parsing_rule subst x = x let subst_printing_rule subst x = x -let subst_syntax_extension (_,subst,(local,sy)) = +let subst_syntax_extension (subst,(local,sy)) = (local, List.map (fun (prec,ntn,gr,pp) -> (prec,ntn, subst_parsing_rule subst gr, subst_printing_rule subst pp)) sy) -let classify_syntax_definition (_,(local,_ as o)) = +let classify_syntax_definition (local,_ as o) = if local then Dispose else Substitute o -let export_syntax_definition (local,_ as o) = - if local then None else Some o - let (inSyntaxExtension, outSyntaxExtension) = declare_object {(default_object "SYNTAX-EXTENSION") with open_function = (fun i o -> if i=1 then cache_syntax_extension o); cache_function = cache_syntax_extension; subst_function = subst_syntax_extension; - classify_function = classify_syntax_definition; - export_function = export_syntax_definition} + classify_function = classify_syntax_definition} (**************************************************************************) (* Precedences *) @@ -734,25 +755,25 @@ let interp_modifiers modl = let check_infix_modifiers modifiers = let (assoc,level,t,b,fmt) = interp_modifiers modifiers in if t <> [] then - error "explicit entry level or type unexpected in infix notation." + error "Explicit entry level or type unexpected in infix notation." -let no_syntax_modifiers modifiers = +let no_syntax_modifiers modifiers = modifiers = [] or modifiers = [SetOnlyParsing] (* Compute precedences from modifiers (or find default ones) *) let set_entry_type etyps (x,typ) = - let typ = try + let typ = try match List.assoc x etyps, typ with | ETConstr (n,()), (_,BorderProd (left,_)) -> ETConstr (n,BorderProd (left,None)) | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) - | (ETPattern | ETIdent | ETBigint | ETOther _ | ETReference as t), _ -> t + | (ETPattern | ETName | ETBigint | ETOther _ | ETReference as t), _ -> t | (ETConstrList _, _) -> assert false with Not_found -> ETConstr typ in (x,typ) -let check_rule_productivity l = +let check_rule_productivity l = if List.for_all (function NonTerminal _ -> true | _ -> false) l then error "A notation must include at least one symbol."; if (match l with SProdList _ :: _ -> true | _ -> false) then @@ -768,9 +789,9 @@ let find_precedence lev etyps symbols = (try match List.assoc x etyps with | ETConstr _ -> error "The level of the leftmost non-terminal cannot be changed." - | ETIdent | ETBigint | ETReference -> - if lev = None then - Flags.if_verbose msgnl (str "Setting notation at level 0.") + | ETName | ETBigint | ETReference -> + if lev = None then + if_verbose msgnl (str "Setting notation at level 0.") else if lev <> Some 0 then error "A notation starting with an atomic expression must be at level 0."; @@ -780,15 +801,15 @@ let find_precedence lev etyps symbols = error "Need an explicit level." else Option.get lev | ETConstrList _ -> assert false (* internally used in grammar only *) - with Not_found -> + with Not_found -> if lev = None then error "A left-recursive notation must have an explicit level." else Option.get lev) | Terminal _ ::l when (match list_last symbols with Terminal _ -> true |_ -> false) - -> + -> if lev = None then - (Flags.if_verbose msgnl (str "Setting notation at level 0."); 0) + (if_verbose msgnl (str "Setting notation at level 0."); 0) else Option.get lev | _ -> if lev = None then error "Cannot determine the level."; @@ -796,18 +817,18 @@ let find_precedence lev etyps symbols = let check_curly_brackets_notation_exists () = try let _ = Notation.level_of_notation "{ _ }" in () - with Not_found -> + with Not_found -> error "Notations involving patterns of the form \"{ _ }\" are treated \n\ specially and require that the notation \"{ _ }\" is already reserved." (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) -let remove_curly_brackets l = +let remove_curly_brackets l = let rec next = function | Break _ :: l -> next l | l -> l in let rec aux deb = function | [] -> [] - | Terminal "{" as t1 :: l -> + | Terminal "{" as t1 :: l -> (match next l with | NonTerminal _ as x :: l' as l0 -> (match next l' with @@ -828,7 +849,7 @@ let compute_syntax_data (df,modifiers) = (* Notation defaults to NONA *) let assoc = match assoc with None -> Some Gramext.NonA | a -> a in let toks = split_notation_string df in - let (extrarecvars,recvars,vars,symbols) = analyse_notation_tokens toks in + let (extrarecvars,recvars,vars,symbols) = analyze_notation_tokens toks in let ntn_for_interp = make_notation_key symbols in let symbols' = remove_curly_brackets symbols in let need_squash = (symbols <> symbols') in @@ -846,7 +867,7 @@ let compute_syntax_data (df,modifiers) = let typs = List.map (set_entry_type etyps) typs in let prec = (n,List.map (assoc_of_type n) typs) in let sy_data = (ntn_for_grammar,prec,need_squash,(n,typs,symbols',fmt)) in - let df' = (Lib.library_dp(),df) in + let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in let i_data = (onlyparse,extrarecvars,recvars,vars,(ntn_for_interp,df')) in (i_data,sy_data) @@ -869,23 +890,19 @@ let cache_notation o = load_notation 1 o; open_notation 1 o -let subst_notation (_,subst,(lc,scope,pat,b,ndf)) = +let subst_notation (subst,(lc,scope,pat,b,ndf)) = (lc,scope,subst_interpretation subst pat,b,ndf) -let classify_notation (_,(local,_,_,_,_ as o)) = +let classify_notation (local,_,_,_,_ as o) = if local then Dispose else Substitute o -let export_notation (local,_,_,_,_ as o) = - if local then None else Some o - let (inNotation, outNotation) = declare_object {(default_object "NOTATION") with open_function = open_notation; cache_function = cache_notation; subst_function = subst_notation; load_function = load_notation; - classify_function = classify_notation; - export_function = export_notation} + classify_function = classify_notation} (**********************************************************************) (* Recovering existing syntax *) @@ -896,17 +913,17 @@ let contract_notation ntn = if i <= String.length ntn - 5 then let ntn' = if String.sub ntn i 5 = "{ _ }" then - String.sub ntn 0 i ^ "_" ^ + String.sub ntn 0 i ^ "_" ^ String.sub ntn (i+5) (String.length ntn -i-5) else ntn in - aux ntn' (i+1) + aux ntn' (i+1) else ntn in aux ntn 0 exception NoSyntaxRule let recover_syntax ntn = - try + try let prec = Notation.level_of_notation ntn in let pprule,_ = Notation.find_notation_printing_rule ntn in let gr = Egrammar.recover_notation_grammar ntn prec in @@ -924,7 +941,7 @@ let recover_notation_syntax rawntn = (**********************************************************************) (* Main entry point for building parsing and printing rules *) - + let make_pa_rule (n,typs,symbols,_) ntn = let assoc = recompute_assoc typs in let prod = make_production typs symbols in @@ -954,78 +971,77 @@ let add_notation_in_scope local df c mods scope = Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)); (* Declare interpretation *) let (onlyparse,extrarecvars,recvars,vars,df') = i_data in - let (acvars,ac) = interp_aconstr [] (vars,recvars) c in + let (acvars,ac) = interp_aconstr (vars,recvars) c in let a = (remove_extravars extrarecvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in - Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')) + Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')); + df' -let add_notation_interpretation_core local df names c scope onlyparse = +let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse = let dfs = split_notation_string df in - let (extrarecvars,recvars,vars,symbs) = analyse_notation_tokens dfs in + let (extrarecvars,recvars,vars,symbs) = analyze_notation_tokens dfs in (* Redeclare pa/pp rules *) if not (is_numeral symbs) then begin let sy_rules = recover_notation_syntax (make_notation_key symbs) in Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) end; (* Declare interpretation *) - let df' = (make_notation_key symbs,(Lib.library_dp(),df)) in - let (acvars,ac) = interp_aconstr names (vars,recvars) c in + let path = (Lib.library_dp(),Lib.current_dirpath true) in + let df' = (make_notation_key symbs,(path,df)) in + let (acvars,ac) = interp_aconstr ~impls (vars,recvars) c in let a = (remove_extravars extrarecvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in - Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')) + Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')); + df' (* Notations without interpretation (Reserved Notation) *) -let add_syntax_extension local mv = - let (_,sy_data) = compute_syntax_data mv in +let add_syntax_extension local ((loc,df),mods) = + let (_,sy_data) = compute_syntax_data (df,mods) in let sy_rules = make_syntax_rules sy_data in Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) -let add_notation_interpretation df names c sc = - try add_notation_interpretation_core false df names c sc false +let add_notation_interpretation ((loc,df),c,sc) = + let df' = add_notation_interpretation_core false df c sc false in + Dumpglob.dump_notation (loc,df') sc true + +let set_notation_for_interpretation impls ((_,df),c,sc) = + (try ignore + (silently (add_notation_interpretation_core false df ~impls c sc) false); with NoSyntaxRule -> - error "Parsing rule for this notation has to be previously declared." + error "Parsing rule for this notation has to be previously declared."); + Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) -let add_notation local c (df,modifiers) sc = - if no_syntax_modifiers modifiers then +let add_notation local c ((loc,df),modifiers) sc = + let df' = + if no_syntax_modifiers modifiers then (* No syntax data: try to rely on a previously declared rule *) let onlyparse = modifiers=[SetOnlyParsing] in - try add_notation_interpretation_core local df [] c sc onlyparse + try add_notation_interpretation_core local df c sc onlyparse with NoSyntaxRule -> (* Try to determine a default syntax rule *) add_notation_in_scope local df c modifiers sc - else + else (* Declare both syntax and interpretation *) add_notation_in_scope local df c modifiers sc + in + Dumpglob.dump_notation (loc,df') sc true (* Infix notations *) let inject_var x = CRef (Ident (dummy_loc, id_of_string x)) -let add_infix local (inf,modifiers) pr sc = +let add_infix local ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) let metas = [inject_var "x"; inject_var "y"] in - let c = mkAppC (mkRefC pr,metas) in + let c = mkAppC (pr,metas) in let df = "x "^(quote_notation_token inf)^" y" in - add_notation local c (df,modifiers) sc - -(**********************************************************************) -(* Miscellaneous *) - -let standardize_locatable_notation ntn = - let unquote = function - | String s -> [unquote_notation_token s] - | _ -> [] in - if String.contains ntn ' ' then - String.concat " " - (List.flatten (List.map unquote (split_notation_string ntn))) - else - unquote_notation_token ntn + add_notation local c ((loc,df),modifiers) sc (**********************************************************************) (* Delimiters and classes bound to scopes *) @@ -1045,23 +1061,37 @@ let cache_scope_command o = load_scope_command 1 o; open_scope_command 1 o -let subst_scope_command (_,subst,(scope,o as x)) = match o with - | ScopeClasses cl -> +let subst_scope_command (subst,(scope,o as x)) = match o with + | ScopeClasses cl -> let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else scope, ScopeClasses cl' | _ -> x -let (inScopeCommand,outScopeCommand) = +let (inScopeCommand,outScopeCommand) = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; open_function = open_scope_command; load_function = load_scope_command; subst_function = subst_scope_command; - classify_function = (fun (_,obj) -> Substitute obj); - export_function = (fun x -> Some x) } + classify_function = (fun obj -> Substitute obj)} let add_delimiters scope key = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) -let add_class_scope scope cl = +let add_class_scope scope cl = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) + +(* Check if abbreviation to a name and avoid early insertion of + maximal implicit arguments *) +let try_interp_name_alias = function + | [], CRef ref -> intern_reference ref + | _ -> raise Not_found + +let add_syntactic_definition ident (vars,c) local onlyparse = + let vars,pat = + try [], ARef (try_interp_name_alias (vars,c)) + with Not_found -> let (vars,_),pat = interp_aconstr (vars,[]) c in vars,pat + in + let onlyparse = onlyparse or is_not_printable pat in + Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) + diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index fefc0b27..a0680693 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -6,10 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: metasyntax.mli 11481 2008-10-20 19:23:51Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Util +open Names open Libnames open Ppextend open Extend @@ -23,16 +24,16 @@ val add_token_obj : string -> unit (* Adding a tactic notation in the environment *) -val add_tactic_notation : - int * grammar_production list * raw_tactic_expr -> unit +val add_tactic_notation : + int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit (* Adding a (constr) notation in the environment*) -val add_infix : locality_flag -> (string * syntax_modifier list) -> - reference -> scope_name option -> unit +val add_infix : locality_flag -> (lstring * syntax_modifier list) -> + constr_expr -> scope_name option -> unit val add_notation : locality_flag -> constr_expr -> - (string * syntax_modifier list) -> scope_name option -> unit + (lstring * syntax_modifier list) -> scope_name option -> unit (* Declaring delimiter keys and default scopes *) @@ -41,22 +42,26 @@ val add_class_scope : scope_name -> Classops.cl_typ -> unit (* Add only the interpretation of a notation that already has pa/pp rules *) -val add_notation_interpretation : string -> Constrintern.implicits_env -> - constr_expr -> scope_name option -> unit +val add_notation_interpretation : + (lstring * constr_expr * scope_name option) -> unit -(* Add only the parsing/printing rule of a notation *) +(* Add a notation interpretation for supporting the "where" clause *) -val add_syntax_extension : - locality_flag -> (string * syntax_modifier list) -> unit +val set_notation_for_interpretation : Constrintern.full_internalization_env -> + (lstring * constr_expr * scope_name option) -> unit -(* Print the Camlp4 state of a grammar *) +(* Add only the parsing/printing rule of a notation *) -val print_grammar : string -> unit +val add_syntax_extension : + locality_flag -> (lstring * syntax_modifier list) -> unit + +(* Add a syntactic definition (as in "Notation f := ...") *) -(* Removes quotes in a notation *) +val add_syntactic_definition : identifier -> identifier list * constr_expr -> + bool -> bool -> unit -val standardize_locatable_notation : string -> string +(* Print the Camlp4 state of a grammar *) -(* Evaluate whether a notation is not printable *) +val print_grammar : string -> unit -val is_not_printable : aconstr -> bool +val check_infix_modifiers : syntax_modifier list -> unit diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index b54700d3..ee437030 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -11,7 +11,7 @@ * camlp4deps will not work for this file unless Makefile system enhanced. *) -(* $Id: mltop.ml4 12341 2009-09-17 16:03:19Z glondu $ *) +(* $Id$ *) open Util open Pp @@ -25,12 +25,12 @@ open Vernacinterp (* Code to hook Coq into the ML toplevel -- depends on having the objective-caml compiler mostly visible. The functions implemented here are: \begin{itemize} - \item [dir_ml_load name]: Loads the ML module fname from the current ML - path. + \item [dir_ml_load name]: Loads the ML module fname from the current ML + path. \item [dir_ml_use]: Directive #use of Ocaml toplevel \item [add_ml_dir]: Directive #directory of Ocaml toplevel \end{itemize} - + How to build an ML module interface with these functions. The idea is that the ML directory path is like the Coq directory path. So we can maintain the two in parallel. @@ -53,13 +53,13 @@ let keep_copy_mlpath path = coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy (* If there is a toplevel under Coq *) -type toplevel = { +type toplevel = { load_obj : string -> unit; use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } -(* Determines the behaviour of Coq with respect to ML files (compiled +(* Determines the behaviour of Coq with respect to ML files (compiled or not) *) type kind_load = | WithTop of toplevel @@ -93,7 +93,7 @@ let ocaml_toploop () = | _ -> () (* Dynamic loading of .cmo/.cma *) -let dir_ml_load s = +let dir_ml_load s = match !load with | WithTop t -> (try t.load_obj s @@ -133,7 +133,7 @@ let add_ml_dir s = | _ -> () (* For Rec Add ML Path *) -let add_rec_ml_dir dir = +let add_rec_ml_dir dir = List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir) (* Adding files to Coq and ML loadpath *) @@ -149,8 +149,8 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Names.id_of_string d - with _ -> - if_verbose warning + with _ -> + if_verbose warning ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); flush_all (); failwith "caught" @@ -165,18 +165,18 @@ let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath = List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs; add_ml_dir dir; List.iter (Library.add_load_path false) dirs; - Library.add_load_path true (dir,Names.make_dirpath prefix) + Library.add_load_path true (dir,coq_dirpath) else msg_warning (str ("Cannot open " ^ dir)) -(* convertit un nom quelconque en nom de fichier ou de module *) +(* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = let base = if Filename.check_suffix name ".cmo" then Filename.chop_suffix name ".cmo" - else + else name - in + in String.capitalize base let get_ml_object_suffix name = @@ -218,38 +218,34 @@ let file_of_name name = if is_in_path !coq_mlpath_copy name then name else fail (base ^ ".cm[oa]") -(* TODO: supprimer ce hack, si possible *) -(* Initialisation of ML modules that need the state (ex: tactics like - * natural, omega ...) - * Each module may add some inits (function of type unit -> unit). - * These inits are executed right after the initial state loading if the - * module is statically linked, or after the loading if it is required. *) - -let init_list = ref ([] : (unit -> unit) list) - -let add_init_with_state init_fun = - init_list := init_fun :: !init_list - -let init_with_state () = - List.iter (fun f -> f()) (List.rev !init_list); init_list := [] +(** Is the ML code of the standard library placed into loadable plugins + or statically compiled into coqtop ? For the moment this choice is + made according to the presence of native dynlink : even if bytecode + coqtop could always load plugins, we prefer to have uniformity between + bytecode and native versions. *) +let stdlib_use_plugins = Coq_config.has_natdynlink (* [known_loaded_module] contains the names of the loaded ML modules - * (linked or loaded with load_object). It is used not to load a + * (linked or loaded with load_object). It is used not to load a * module twice. It is NOT the list of ML modules Coq knows. *) -type ml_module_object = { mnames : string list } +type ml_module_object = { + mlocal : Vernacexpr.locality_flag; + mnames : string list +} let known_loaded_modules = ref Stringset.empty let add_known_module mname = + let mname = String.capitalize mname in known_loaded_modules := Stringset.add mname !known_loaded_modules -let module_is_known mname = Stringset.mem mname !known_loaded_modules +let module_is_known mname = + Stringset.mem (String.capitalize mname) !known_loaded_modules let load_object mname fname= dir_ml_load fname; - init_with_state(); add_known_module mname (* Summary of declared ML Modules *) @@ -271,19 +267,17 @@ let unfreeze_ml_modules x = if has_dynlink then let fname = file_of_name mname in load_object mname fname - else + else errorlabstrm "Mltop.unfreeze_ml_modules" (str"Loading of ML object file forbidden in a native Coq."); add_loaded_module mname) x -let _ = +let _ = Summary.declare_summary "ML-MODULES" { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules())); Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x); - Summary.init_function = (fun () -> init_ml_modules ()); - Summary.survive_module = false; - Summary.survive_section = true } + Summary.init_function = (fun () -> init_ml_modules ()) } (* Same as restore_ml_modules, but verbosely *) @@ -292,40 +286,42 @@ let cache_ml_module_object (_,{mnames=mnames}) = (fun name -> let mname = mod_of_name name in if not (module_is_known mname) then - let fname = file_of_name mname in - begin - try - if_verbose + if has_dynlink then + let fname = file_of_name mname in + try + if_verbose msg (str"[Loading ML file " ++ str fname ++ str" ..."); load_object mname fname; - if_verbose msgnl (str" done]") - with e -> - if_verbose msgnl (str" failed]"); + if_verbose msgnl (str" done]"); + add_loaded_module mname + with e -> + if_verbose msgnl (str" failed]"); raise e - end; - add_loaded_module mname) + else + (if_verbose msgnl (str" failed]"); + error ("Dynamic link not supported (module "^name^")"))) mnames -let export_ml_module_object x = Some x - +let classify_ml_module_object ({mlocal=mlocal} as o) = + if mlocal then Dispose else Substitute o + let (inMLModule,outMLModule) = declare_object {(default_object "ML-MODULE") with load_function = (fun _ -> cache_ml_module_object); cache_function = cache_ml_module_object; - export_function = export_ml_module_object; - subst_function = (fun (_,_,o) -> o); - classify_function = (fun (_,o) -> Substitute o) } + subst_function = (fun (_,o) -> o); + classify_function = classify_ml_module_object } + +let declare_ml_modules local l = + Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l}) -let declare_ml_modules l = - Lib.add_anonymous_leaf (inMLModule {mnames=l}) - let print_ml_path () = let l = !coq_mlpath_copy in ppnl (str"ML Load Path:" ++ fnl () ++ str" " ++ hv 0 (prlist_with_sep pr_fnl pr_str l)) (* Printing of loaded ML modules *) - + let print_ml_modules () = let l = get_loaded_modules () in pp (str"Loaded ML Modules: " ++ pr_vertical_list pr_str l) diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index 875fb423..4230f0ee 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mltop.mli 11528 2008-10-31 08:40:42Z glondu $ i*) +(*i $Id$ i*) -(* If there is a toplevel under Coq, it is described by the following +(* If there is a toplevel under Coq, it is described by the following record. *) -type toplevel = { +type toplevel = { load_obj : string -> unit; use_file : string -> unit; add_dir : string -> unit; @@ -48,9 +48,6 @@ val add_rec_ml_dir : string -> unit val add_path : unix_path:string -> coq_root:Names.dir_path -> unit val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit -val add_init_with_state : (unit -> unit) -> unit -val init_with_state : unit -> unit - (* List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool @@ -62,11 +59,15 @@ val add_loaded_module : string -> unit val init_ml_modules : unit -> unit val unfreeze_ml_modules : string list -> unit -type ml_module_object = { mnames: string list } +type ml_module_object = { + mlocal: Vernacexpr.locality_flag; + mnames: string list; +} val inMLModule : ml_module_object -> Libobject.obj val outMLModule : Libobject.obj -> ml_module_object -val declare_ml_modules : string list -> unit +val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit + val print_ml_path : unit -> unit val print_ml_modules : unit -> unit diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml deleted file mode 100644 index caf32305..00000000 --- a/toplevel/protectedtoplevel.ml +++ /dev/null @@ -1,176 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: protectedtoplevel.ml 11784 2009-01-14 11:36:32Z herbelin $ *) - -open Pp -open Line_oriented_parser -open Vernac -open Vernacexpr - -(* The toplevel parsing loop we propose here is more robust to printing - errors. The philosophy is that all commands should be individually wrapped - in predefined markers. If there is a parsing error, everything down to - the closing marker will be discarded. Also there is always an aknowledge - message associated to a wrapped command. *) - - -(* It is also possible to have break signals sent by other programs. However, - there are some operations that should not be interrupted, especially, those - operations that are outputing data. -*) - -let break_happened = ref false - -(* Before outputing any data, output_results makes sure that no interrupt - is going to disturb the process. *) -let output_results_nl stream = - let _ = Sys.signal Sys.sigint - (Sys.Signal_handle(fun i -> break_happened := true;())) - in - msgnl stream - -let rearm_break () = - let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in - () - -let check_break () = - if !break_happened then begin - break_happened := false; - raise Sys.Break - end - -(* All commands are acknowledged. *) - -let global_request_id = ref 013 - -let acknowledge_command_ref = - ref(fun request_id command_count opt_exn - -> (fnl () ++ str "acknowledge command number " ++ - int request_id ++ fnl () ++ - str "successfully executed " ++ int command_count ++ fnl () ++ - str "error message" ++ fnl () ++ - (match opt_exn with - Some e -> Cerrors.explain_exn e - | None -> (mt ())) ++ fnl () ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl ())) - -let set_acknowledge_command f = - acknowledge_command_ref := f - -let acknowledge_command request_id = !acknowledge_command_ref request_id - -(* The markers are chosen to be likely to be different from any existing text. *) - -let start_marker = ref "protected_loop_start_command" -let end_marker = ref "protected_loop_end_command" -let start_length = ref (String.length !start_marker) -let start_marker_buffer = ref (String.make !start_length ' ') - -let set_start_marker s = - start_marker := s; - start_length := String.length s; - start_marker_buffer := String.make !start_length ' ' - -let set_end_marker s = - end_marker := s - -exception E_with_rank of int * exn - -let rec parse_one_command_group input_channel = - let count = ref 0 in - let this_line = input_line input_channel in - if (String.length this_line) >= !start_length then begin - String.blit this_line 0 !start_marker_buffer 0 !start_length; - if !start_marker_buffer = !start_marker then - let req_id_line = input_line input_channel in - begin - (try - global_request_id := int_of_string req_id_line - with - | e -> failwith ("could not parse the request identifier |"^ - req_id_line ^ "|")) ; - let count_line = input_line input_channel in - begin - (try - count := int_of_string count_line - with - | e -> failwith("could not parse the count|" ^ count_line - ^ "|")); - let stream_tail = - Stream.from - (line_oriented_channel_to_option - !end_marker input_channel) in - begin - check_break(); - rearm_break(); - let rec execute_n_commands rank = - if rank = !count then - None - else - let first_cmd_status = - try - raw_do_vernac - (Pcoq.Gram.parsable stream_tail); - None - with e -> Some(rank,e) in - match first_cmd_status with - None -> - execute_n_commands (rank + 1) - | v -> v in - let r = execute_n_commands 0 in - (match r with - None -> - output_results_nl - (acknowledge_command - !global_request_id !count None) - | Some(rank, e) -> - (match e with - | DuringCommandInterp(a,e1) - | Stdpp.Exc_located (a,DuringSyntaxChecking e1) -> - output_results_nl - (acknowledge_command - !global_request_id rank (Some e1)) - | e -> - output_results_nl - (acknowledge_command - !global_request_id rank (Some e)))); - rearm_break(); - flush_until_end_of_stream stream_tail - end - end - end - else - parse_one_command_group input_channel - end else - parse_one_command_group input_channel - -let protected_loop input_chan = - let rec explain_and_restart e = - begin - output_results_nl(Cerrors.explain_exn e); - rearm_break(); - looprec input_chan; - end - and looprec input_chan = - try - while true do parse_one_command_group input_chan done - with - | Vernacexpr.Drop -> raise Vernacexpr.Drop - | Vernacexpr.Quit -> exit 0 - | End_of_file -> exit 0 - | DuringCommandInterp(loc, Vernacexpr.Quit) -> raise Vernacexpr.Quit - | DuringCommandInterp(loc, Vernacexpr.Drop) -> raise Vernacexpr.Drop - | DuringCommandInterp(loc, e) - | Stdpp.Exc_located (loc,DuringSyntaxChecking e) -> - explain_and_restart e - | e -> explain_and_restart e in - begin - msgnl (str "Starting Centaur Specialized loop"); - looprec input_chan - end diff --git a/toplevel/protectedtoplevel.mli b/toplevel/protectedtoplevel.mli deleted file mode 100644 index 1d4ba9fc..00000000 --- a/toplevel/protectedtoplevel.mli +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: protectedtoplevel.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -(*i*) -open Pp -(*i*) - -(* A protected toplevel (used in Pcoq). *) - -val break_happened : bool ref -val global_request_id : int ref -val output_results_nl : std_ppcmds -> unit -val rearm_break : unit -> unit -val check_break : unit -> unit -val set_acknowledge_command : (int -> int -> exn option -> std_ppcmds) -> unit -val set_start_marker : string -> unit -val set_end_marker : string -> unit -val parse_one_command_group : in_channel -> unit -val protected_loop : in_channel -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 4c0e34cd..320030e1 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: record.ml 12080 2009-04-11 16:56:20Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -31,30 +31,27 @@ open Topconstr (********** definition d'un record (structure) **************) -let interp_evars evdref env ?(impls=([],[])) k typ = - let typ' = intern_gen true ~impls (Evd.evars_of !evdref) env typ in +let interp_evars evdref env impls k typ = + let impls = set_internalization_env_params impls [] in + let typ' = intern_gen true ~impls !evdref env typ in let imps = Implicit_quantifiers.implicits_of_rawterm typ' in imps, Pretyping.Default.understand_tcc_evars evdref env k typ' -let mk_interning_data env na impls typ = - let impl = Impargs.compute_implicits_with_manual env typ (Impargs.is_implicit_args()) impls - in (na, (Constrintern.Method, [], impl, Notation.compute_arguments_scope typ)) - -let interp_fields_evars isevars env nots l = +let interp_fields_evars evars env nots l = List.fold_left2 (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> - let impl, t' = interp_evars isevars env ~impls Pretyping.IsType t in - let b' = Option.map (fun x -> snd (interp_evars isevars env ~impls (Pretyping.OfType (Some t')) x)) b in - let impls = + let impl, t' = interp_evars evars env impls Pretyping.IsType t in + let b' = Option.map (fun x -> snd (interp_evars evars env impls (Pretyping.OfType (Some t')) x)) b in + let impls = match i with | Anonymous -> impls - | Name na -> (fst impls, mk_interning_data env na impl t' :: snd impls) + | Name id -> (id, compute_internalization_data env Constrintern.Method t' impl) :: impls in let d = (i,b',t') in - (* Temporary declaration of notations and scopes *) - Option.iter (declare_interning_data impls) no; - (push_rel d env, impl :: uimpls, d::params, impls)) - (env, [], [], ([], [])) nots l + let impls' = set_internalization_env_params impls [] in + List.iter (Metasyntax.set_notation_for_interpretation impls') no; + (push_rel d env, impl :: uimpls, d::params, impls)) + (env, [], [], []) nots l let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) @@ -64,7 +61,7 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields id t ps nots fs = let env0 = Global.env () in - let evars = ref (Evd.create_evar_defs Evd.empty) in + let evars = ref Evd.empty in let (env1,newps), imps = interp_context_evars ~fail_anonymous:false evars env0 ps in let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in @@ -73,7 +70,7 @@ let typecheck_params_and_fields id t ps nots fs = in let evars,_ = Evarconv.consider_remaining_unif_problems env_ar !evars in let evars = Typeclasses.resolve_typeclasses env_ar evars in - let sigma = Evd.evars_of evars in + let sigma = evars in let newps = Evarutil.nf_rel_context_evar sigma newps in let newfs = Evarutil.nf_rel_context_evar sigma newfs in let ce t = Evarutil.check_evars env0 Evd.empty evars t in @@ -84,7 +81,7 @@ let typecheck_params_and_fields id t ps nots fs = let degenerate_decl (na,b,t) = let id = match na with | Name id -> id - | Anonymous -> anomaly "Unnamed record variable" in + | Anonymous -> anomaly "Unnamed record variable" in match b with | None -> (id, Entries.LocalAssum t) | Some b -> (id, Entries.LocalDef b) @@ -99,21 +96,21 @@ let warning_or_error coe indsp err = let s,have = if List.length projs > 1 then "s","were" else "","was" in (str(string_of_id fi) ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ - prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ + prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") | BadTypedProj (fi,ctx,te) -> match te with | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> - (pr_id fi ++ + (pr_id fi ++ strbrk" cannot be defined because it is informative and " ++ Printer.pr_inductive (Global.env()) indsp ++ - strbrk " is not.") + strbrk " is not.") | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> - (pr_id fi ++ + (pr_id fi ++ strbrk" cannot be defined because it is large and " ++ Printer.pr_inductive (Global.env()) indsp ++ strbrk " is not.") - | _ -> + | _ -> (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in if coe then errorlabstrm "structure" st; @@ -136,20 +133,20 @@ let subst_projection fid l c = let rec substrec depth c = match kind_of_term c with | Rel k -> (* We are in context [[params;fields;x:ind;...depth...]] *) - if k <= depth+1 then + if k <= depth+1 then c else if k-depth-1 <= lv then match List.nth l (k-depth-2) with | Projection t -> lift depth t | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k | NoProjection Anonymous -> assert false - else + else mkRel (k-lv) | _ -> map_constr_with_binders succ substrec depth c in let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) let c'' = substrec 0 c' in - if !bad_projs <> [] then + if !bad_projs <> [] then raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); c'' @@ -165,7 +162,7 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls let r = mkInd indsp in let rp = applist (r, extended_rel_list 0 paramdecls) in let paramargs = extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) - let x = match name with Some n -> Name n | None -> Termops.named_hd (Global.env()) r Anonymous in + let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in let fields = instantiate_possibly_recursive_type indsp paramdecls fields in let lifted_fields = lift_rel_context 1 fields in let (_,kinds,sp_projs,_) = @@ -222,8 +219,24 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls (List.length fields,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) -let declare_structure finite id idbuild paramimpls params arity fieldimpls fields - ?(kind=StructureComponent) ?name is_coe coers = +let structure_signature ctx = + let rec deps_to_evar evm l = + match l with [] -> Evd.empty + | [(_,_,typ)] -> Evd.add evm (Evarutil.new_untyped_evar()) + (Evd.make_evar Environ.empty_named_context_val typ) + | (_,_,typ)::tl -> + let ev = Evarutil.new_untyped_evar() in + let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val typ) in + let new_tl = Util.list_map_i + (fun pos (n,c,t) -> n,c, + Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in + deps_to_evar evm new_tl in + deps_to_evar Evd.empty (List.rev ctx) + +open Typeclasses + +let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields + ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = extended_rel_list nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in @@ -238,7 +251,7 @@ let declare_structure finite id idbuild paramimpls params arity fieldimpls field but isn't *) (* there is probably a way to push this to "declare_mutual" *) begin match finite with - | BiFinite -> + | BiFinite -> if dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record." | _ -> () @@ -248,44 +261,40 @@ let declare_structure finite id idbuild paramimpls params arity fieldimpls field mind_entry_record = true; mind_entry_finite = recursivity_flag_of_kind finite; mind_entry_inds = [mie_ind] } in - let kn = Command.declare_mutual_with_eliminations true mie [(paramimpls,[])] in +(* TODO : maybe switch to KernelVerbose *) + let kn = Command.declare_mutual_inductive_with_eliminations KernelSilent mie [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) + let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in - let build = ConstructRef (rsp,1) in - if is_coe then Class.try_add_new_coercion build Global; - Recordops.declare_structure(rsp,(rsp,1),List.rev kinds,List.rev sp_projs); - kn,0 + let build = ConstructRef cstr in + if is_coe then Class.try_add_new_coercion build Global; + Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); + if infer then + Evd.fold (fun ev evi () -> Recordops.declare_method (ConstructRef cstr) ev sign) sign (); + rsp let implicits_of_context ctx = list_map_i (fun i name -> - let explname = - match name with + let explname = + match name with | Name n -> Some n | Anonymous -> None - in ExplByPos (i, explname), (true, true)) + in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map pi1 ctx))) -open Typeclasses - -let typeclasses_db = "typeclass_instances" - let qualid_of_con c = Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c)) -let set_rigid c = - Auto.add_hints false [typeclasses_db] - (Vernacexpr.HintsTransparency ([qualid_of_con c], false)) - let declare_instance_cst glob con = let instance = Typeops.type_of_constant (Global.env ()) con in - let _, r = Sign.decompose_prod_assum instance in + let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some tc -> add_instance (new_instance tc None glob con) + | Some tc -> add_instance (new_instance tc None glob (ConstRef con)) | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.") -let declare_class finite def id idbuild paramimpls params arity fieldimpls fields - ?(kind=StructureComponent) ?name is_coe coers = - let fieldimpls = +let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields + ?(kind=StructureComponent) ?name is_coe coers sign = + let fieldimpls = (* Make the class and all params implicits in the projections *) let ctx_impls = implicits_of_context params in let len = succ (List.length params) in @@ -303,37 +312,37 @@ let declare_class finite def id idbuild paramimpls params arity fieldimpls field const_entry_boxed = false } in let cst = Declare.declare_constant (snd id) - (DefinitionEntry class_entry, IsDefinition Definition) + (DefinitionEntry class_entry, IsDefinition Definition) in let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in - let proj_entry = + let proj_entry = { const_entry_body = proj_body; const_entry_type = Some proj_type; const_entry_opaque = false; const_entry_boxed = false } in let proj_cst = Declare.declare_constant proj_name - (DefinitionEntry proj_entry, IsDefinition Definition) + (DefinitionEntry proj_entry, IsDefinition Definition) in let cref = ConstRef cst in - Impargs.declare_manual_implicits false cref paramimpls; - Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls); - set_rigid cst; (* set_rigid proj_cst; *) - cref, [proj_name, Some proj_cst] + Impargs.declare_manual_implicits false cref paramimpls; + Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls); + Classes.set_typeclass_transparency (EvalConstRef cst) false; + if infer then Evd.fold (fun ev evi _ -> Recordops.declare_method (ConstRef cst) ev sign) sign (); + cref, [proj_name, Some proj_cst] | _ -> - let idarg = Nameops.next_ident_away (snd id) (ids_of_context (Global.env())) in - let ind = declare_structure BiFinite (snd id) idbuild paramimpls + let idarg = Namegen.next_ident_away (snd id) (ids_of_context (Global.env())) in + let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls params (Option.cata (fun x -> x) (new_Type ()) arity) fieldimpls fields - ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) + ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign in - (* List.iter (Option.iter (declare_interning_data ((),[]))) notations; *) IndRef ind, (List.map2 (fun (id, _, _) y -> (Nameops.out_name id, y)) (List.rev fields) (Recordops.lookup_projections ind)) in let ctx_context = - List.map (fun (na, b, t) -> + List.map (fun (na, b, t) -> match Typeclasses.class_of_constr t with | Some cl -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) | None -> None) @@ -345,16 +354,24 @@ let declare_class finite def id idbuild paramimpls params arity fieldimpls field cl_props = fields; cl_projs = projs } in - List.iter2 (fun p sub -> + List.iter2 (fun p sub -> if sub then match snd p with Some p -> declare_instance_cst true p | None -> ()) k.cl_projs coers; - add_class k; impl + add_class k; impl + +let interp_and_check_sort sort = + Option.map (fun sort -> + let env = Global.env() and sigma = Evd.empty in + let s = interp_constr sigma env sort in + if isSort (Reductionops.whd_betadeltaiota env sigma s) then s + else user_err_loc (constr_loc sort,"", str"Sort expected.")) sort open Vernacexpr +open Autoinstance -(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean +(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean list telling if the corresponding fields must me declared as coercion *) -let definition_structure (kind,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = +let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let coers,fs = List.split cfs in let extract_name acc = function @@ -364,16 +381,21 @@ let definition_structure (kind,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let allnames = idstruc::(List.fold_left extract_name [] fs) in if not (list_distinct allnames) then error "Two objects have the same name"; (* Now, younger decl in params and fields is on top *) - let sc = Option.map mkSort s in - let implpars, params, implfs, fields = + let sc = interp_and_check_sort s in + let implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields idstruc sc ps notations fs) () - in + typecheck_params_and_fields idstruc sc ps notations fs) () in + let sign = structure_signature (fields@params) in match kind with - | Class b -> - declare_class finite b (loc,idstruc) idbuild implpars params sc implfs fields is_coe coers + | Class def -> + let gr = declare_class finite def infer (loc,idstruc) idbuild + implpars params sc implfs fields is_coe coers sign in + if infer then search_record declare_class_instance gr sign; + gr | _ -> - let arity = Option.cata (fun x -> x) (new_Type ()) sc in + let arity = Option.default (new_Type ()) sc in let implfs = List.map - (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs - in IndRef (declare_structure finite idstruc idbuild implpars params arity implfs fields is_coe coers) + (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in + let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs fields is_coe coers sign in + if infer then search_record declare_record_instance (ConstructRef (ind,1)) sign; + IndRef ind diff --git a/toplevel/record.mli b/toplevel/record.mli index b49c26bc..b9864f08 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: record.mli 11809 2009-01-20 11:39:55Z aspiwack $ i*) +(*i $Id$ i*) (*i*) open Names @@ -24,18 +24,20 @@ open Libnames val declare_projections : inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> - bool list -> manual_explicitation list list -> rel_context -> + bool list -> manual_explicitation list list -> rel_context -> (name * bool) list * constant option list -val declare_structure : Decl_kinds.recursivity_kind -> - identifier -> identifier -> +val declare_structure : Decl_kinds.recursivity_kind -> + bool (*infer?*) -> identifier -> identifier -> manual_explicitation list -> rel_context -> (* params *) constr -> (* arity *) - Impargs.manual_explicitation list list -> Sign.rel_context -> (* fields *) + Impargs.manual_explicitation list list -> rel_context -> (* fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> bool -> (* coercion? *) bool list -> (* field coercions *) + Evd.evar_map -> inductive val definition_structure : - inductive_kind*Decl_kinds.recursivity_kind *lident with_coercion * local_binder list * - (local_decl_expr with_coercion with_notation) list * identifier * sorts option -> global_reference + inductive_kind * Decl_kinds.recursivity_kind * bool(*infer?*)* lident with_coercion * local_binder list * + (local_decl_expr with_coercion with_notation) list * + identifier * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml new file mode 100644 index 00000000..075c80c9 --- /dev/null +++ b/toplevel/search.ml @@ -0,0 +1,236 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +open Pp +open Util +open Names +open Nameops +open Term +open Rawterm +open Declarations +open Libobject +open Declare +open Environ +open Pattern +open Matching +open Printer +open Libnames +open Nametab + +(* The functions print_constructors and crible implement the behavior needed + for the Coq searching commands. + These functions take as first argument the procedure + that will be called to treat each entry. This procedure receives the name + of the object, the assumptions that will make it possible to print its type, + and the constr term that represent its type. *) + +let print_constructors indsp fn env nconstr = + for i = 1 to nconstr do + fn (ConstructRef (indsp,i)) env (Inductiveops.type_of_constructor env (indsp,i)) + done + +let rec head_const c = match kind_of_term c with + | Prod (_,_,d) -> head_const d + | LetIn (_,_,_,d) -> head_const d + | App (f,_) -> head_const f + | Cast (d,_,_) -> head_const d + | _ -> c + +(* General search, restricted to head constant if [only_head] *) + +let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = + let env = Global.env () in + let crible_rec (sp,kn) lobj = match object_tag lobj with + | "VARIABLE" -> + (try + let (id,_,typ) = Global.lookup_named (basename sp) in + if refopt = None + || head_const typ = constr_of_global (Option.get refopt) + then + fn (VarRef id) env typ + with Not_found -> (* we are in a section *) ()) + | "CONSTANT" -> + let cst = Global.constant_of_delta(constant_of_kn kn) in + let typ = Typeops.type_of_constant env cst in + if refopt = None + || head_const typ = constr_of_global (Option.get refopt) + then + fn (ConstRef cst) env typ + | "INDUCTIVE" -> + let mind = Global.mind_of_delta(mind_of_kn kn) in + let mib = Global.lookup_mind mind in + (match refopt with + | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' -> + print_constructors ind fn env + (Array.length (mib.mind_packets.(tyi).mind_user_lc)) + | Some _ -> () + | _ -> + Array.iteri + (fun i mip -> print_constructors (mind,i) fn env + (Array.length mip.mind_user_lc)) mib.mind_packets) + | _ -> () + in + try + Declaremods.iter_all_segments crible_rec + with Not_found -> + () + +let crible ref = gen_crible (Some ref) + +(* Fine Search. By Yves Bertot. *) + +exception No_full_path + +let rec head c = + let c = strip_outer_cast c in + match kind_of_term c with + | Prod (_,_,c) -> head c + | LetIn (_,_,_,c) -> head c + | _ -> c + +let constr_to_full_path c = match kind_of_term c with + | Const sp -> sp + | _ -> raise No_full_path + +let xor a b = (a or b) & (not (a & b)) + +let plain_display ref a c = + let pc = pr_lconstr_env a c in + let pr = pr_global ref in + msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ()) + +let filter_by_module (module_list:dir_path list) (accept:bool) + (ref:global_reference) _ _ = + try + let sp = path_of_global ref in + let sl = dirpath sp in + let rec filter_aux = function + | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl) + | [] -> true + in + xor accept (filter_aux module_list) + with No_full_path -> + false + +let ref_eq = Libnames.encode_mind Coqlib.logic_module (id_of_string "eq"), 0 +let c_eq = mkInd ref_eq +let gref_eq = IndRef ref_eq + +let mk_rewrite_pattern1 eq pattern = + PApp (PRef eq, [| PMeta None; pattern; PMeta None |]) + +let mk_rewrite_pattern2 eq pattern = + PApp (PRef eq, [| PMeta None; PMeta None; pattern |]) + +let pattern_filter pat _ a c = + try + try + is_matching pat (head c) + with _ -> + is_matching + pat (head (Typing.type_of (Global.env()) Evd.empty c)) + with UserError _ -> + false + +let filtered_search filter_function display_function ref = + crible ref + (fun s a c -> if filter_function s a c then display_function s a c) + +let rec id_from_pattern = function + | PRef gr -> gr +(* should be appear as a PRef (VarRef sp) !! + | PVar id -> Nametab.locate (make_qualid [] (string_of_id id)) + *) + | PApp (p,_) -> id_from_pattern p + | _ -> error "The pattern is not simple enough." + +let raw_pattern_search extra_filter display_function pat = + let name = id_from_pattern pat in + filtered_search + (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) + display_function name + +let raw_search_rewrite extra_filter display_function pattern = + filtered_search + (fun s a c -> + ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) || + (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) + && extra_filter s a c) + display_function gref_eq + +let raw_search_by_head extra_filter display_function pattern = + Util.todo "raw_search_by_head" + +let name_of_reference ref = string_of_id (basename_of_global ref) + +(* + * functions to use the new Libtypes facility + *) + +let raw_search search_function extra_filter display_function pat = + let env = Global.env() in + List.iter + (fun (gr,_,_) -> + let typ = Global.type_of_global gr in + if extra_filter gr env typ then + display_function gr env typ + ) (search_function pat) + +let text_pattern_search extra_filter = + raw_search Libtypes.search_concl extra_filter plain_display + +let text_search_rewrite extra_filter = + raw_search (Libtypes.search_eq_concl c_eq) extra_filter plain_display + +let text_search_by_head extra_filter = + raw_search Libtypes.search_head_concl extra_filter plain_display + +let filter_by_module_from_list = function + | [], _ -> (fun _ _ _ -> true) + | l, outside -> filter_by_module l (not outside) + +let filter_subproof gr _ _ = + not (string_string_contains (name_of_reference gr) "_subproof") + +let (&&&&&) f g x y z = f x y z && g x y z + +let search_by_head pat inout = + text_search_by_head (filter_by_module_from_list inout &&&&& filter_subproof) pat + +let search_rewrite pat inout = + text_search_rewrite (filter_by_module_from_list inout &&&&& filter_subproof) pat + +let search_pattern pat inout = + text_pattern_search (filter_by_module_from_list inout &&&&& filter_subproof) pat + +let gen_filtered_search filter_function display_function = + gen_crible None + (fun s a c -> if filter_function s a c then display_function s a c) + +(** SearchAbout *) + +type glob_search_about_item = + | GlobSearchSubPattern of constr_pattern + | GlobSearchString of string + +let search_about_item (itemref,typ) = function + | GlobSearchSubPattern pat -> is_matching_appsubterm ~closed:false pat typ + | GlobSearchString s -> string_string_contains (name_of_reference itemref) s + +let raw_search_about filter_modules display_function l = + let filter ref' env typ = + filter_modules ref' env typ && + List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && + filter_subproof ref' () () + in + gen_filtered_search filter display_function + +let search_about ref inout = + raw_search_about (filter_by_module_from_list inout) plain_display ref diff --git a/toplevel/search.mli b/toplevel/search.mli new file mode 100644 index 00000000..cc764fbd --- /dev/null +++ b/toplevel/search.mli @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id$ i*) + +open Pp +open Names +open Term +open Environ +open Pattern +open Libnames +open Nametab + +(*s Search facilities. *) + +type glob_search_about_item = + | GlobSearchSubPattern of constr_pattern + | GlobSearchString of string + +val search_by_head : constr -> dir_path list * bool -> unit +val search_rewrite : constr -> dir_path list * bool -> unit +val search_pattern : constr -> dir_path list * bool -> unit +val search_about : + (bool * glob_search_about_item) list -> dir_path list * bool -> unit + +(* The filtering function that is by standard search facilities. + It can be passed as argument to the raw search functions. + It is used in pcoq. *) + +val filter_by_module_from_list : + dir_path list * bool -> global_reference -> env -> 'a -> bool + +(* raw search functions can be used for various extensions. + They are also used for pcoq. *) +val gen_filtered_search : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> unit +val filtered_search : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> global_reference -> unit +val raw_pattern_search : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> constr_pattern -> unit +val raw_search_rewrite : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> constr_pattern -> unit +val raw_search_about : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> + (bool * glob_search_about_item) list -> unit +val raw_search_by_head : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> constr_pattern -> unit diff --git a/toplevel/searchisos.mli b/toplevel/searchisos.mli deleted file mode 100644 index 184725b2..00000000 --- a/toplevel/searchisos.mli +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: searchisos.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -val search_in_lib : bool ref -val type_search : Term.constr -> unit -val require_module2 : bool option -> string -> string option -> bool -> unit -val upd_tbl_ind_one : unit -> unit -val seetime : bool ref -val load_leaf_entry : string -> Names.section_path * Libobject.obj -> unit diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 9d64f983..ee821a48 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: toplevel.ml 12891 2010-03-30 11:40:02Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -15,12 +15,11 @@ open Cerrors open Vernac open Vernacexpr open Pcoq -open Protectedtoplevel (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) -type input_buffer = { +type input_buffer = { mutable prompt : unit -> string; mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) @@ -72,7 +71,7 @@ let prompt_char ic ibuf count = ibuf.str.[ibuf.len] <- c; ibuf.len <- ibuf.len + 1; Some c - with End_of_file -> + with End_of_file -> None (* Reinitialize the char stream (after a Drop) *) @@ -94,34 +93,49 @@ let get_bols_of_loc ibuf (bp,ep) = if b < 0 or e < b then anomaly "Bad location"; match lines with | ([],None) -> ([], Some (b,e)) - | (fl,oe) -> ((b,e)::fl, oe) + | (fl,oe) -> ((b,e)::fl, oe) in let rec lines_rec ba after = function | [] -> add_line (0,ba) after | ll::_ when ll <= bp -> add_line (ll,ba) after | ll::fl -> let nafter = if ll < ep then add_line (ll,ba) after else after in - lines_rec ll nafter fl + lines_rec ll nafter fl in let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in (fl,Option.get ll) let dotted_location (b,e) = - if e-b < 3 then + if e-b < 3 then ("", String.make (e-b) ' ') - else + else (String.make (e-b-1) '.', " ") +let blanch_utf8_string s bp ep = + let s' = String.make (ep-bp) ' ' in + let j = ref 0 in + for i = bp to ep - 1 do + let n = Char.code s.[i] in + (* Heuristic: assume utf-8 chars are printed using a single + fixed-size char and therefore contract all utf-8 code into one + space; in any case, preserve tabulation so + that its effective interpretation in terms of spacing is preserved *) + if s.[i] = '\t' then s'.[!j] <- '\t'; + if n < 0x80 || 0xC0 <= n then incr j + done; + String.sub s' 0 !j + let print_highlight_location ib loc = let (bp,ep) = unloc loc in - let bp = bp - ib.start + let bp = bp - ib.start and ep = ep - ib.start in let highlight_lines = match get_bols_of_loc ib (bp,ep) with - | ([],(bl,el)) -> + | ([],(bl,el)) -> + let shift = blanch_utf8_string ib.str bl bp in + let span = String.length (blanch_utf8_string ib.str bp ep) in (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ - str"> " ++ str(String.make (bp-bl) ' ') ++ - str(String.make (ep-bp) '^')) + str"> " ++ str(shift) ++ str(String.make span '^')) | ((b1,e1)::ml,(bn,en)) -> let (d1,s1) = dotted_location (b1,bp) in let (dn,sn) = dotted_location (ep,en) in @@ -131,9 +145,9 @@ let print_highlight_location ib loc = prlist (fun (bi,ei) -> (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ - str sn ++ str dn) in + str sn ++ str dn) in (l1 ++ li ++ ln) - in + in let loc = make_loc (bp,ep) in (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ str":" ++ fnl () ++ highlight_lines ++ fnl ()) @@ -171,7 +185,7 @@ let print_location_in_file s inlibrary fname loc = with e -> (close_in ic; hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) - + let print_command_location ib dloc = match dloc with | Some (bp,ep) -> @@ -185,10 +199,10 @@ let valid_loc dloc loc = | Some dloc -> let (bd,ed) = unloc dloc in let (b,e) = unloc loc in bd<=b & e<=ed | _ -> true - + let valid_buffer_loc ib dloc loc = - valid_loc dloc loc & - let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e + valid_loc dloc loc & + let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e (*s The Coq prompt is the name of the focused proof, if any, and "Coq" otherwise. We trap all exceptions to prevent the error message printing @@ -196,35 +210,35 @@ let valid_buffer_loc ib dloc loc = let make_prompt () = try (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " - with _ -> + with _ -> "Coq < " -(*let build_pending_list l = +(*let build_pending_list l = let pl = ref ">" in let l' = ref l in - let res = - while List.length !l' > 1 do + let res = + while List.length !l' > 1 do pl := !pl ^ "|" Names.string_of_id x; l':=List.tl !l' done in let last = try List.hd !l' with _ -> in "<"^l' -*) +*) (* the coq prompt added to the default one when in emacs mode The prompt contains the current state label [n] (for global backtracking) and the current proof state [p] (for proof backtracking) plus the list of open (nested) proofs (for proof aborting when backtracking). It looks like: - + "n |lem1|lem2|lem3| p < " *) let make_emacs_prompt() = let statnum = string_of_int (Lib.current_command_label ()) in let dpth = Pfedit.current_proof_depth() in let pending = Pfedit.get_all_proof_names() in - let pendingprompt = - List.fold_left + let pendingprompt = + List.fold_left (fun acc x -> acc ^ (if acc <> "" then "|" else "") ^ Names.string_of_id x) "" pending in let proof_info = if dpth >= 0 then string_of_int dpth else "0" in @@ -235,9 +249,9 @@ let make_emacs_prompt() = * initialized when a vernac command is immediately followed by "\n", * or after a Drop. *) let top_buffer = - let pr() = - emacs_prompt_startstring() - ^ make_prompt() + let pr() = + emacs_prompt_startstring() + ^ make_prompt() ^ make_emacs_prompt() ^ emacs_prompt_endstring() in @@ -250,7 +264,7 @@ let top_buffer = let set_prompt prompt = top_buffer.prompt - <- (fun () -> + <- (fun () -> emacs_prompt_startstring() ^ prompt () ^ emacs_prompt_endstring()) @@ -262,7 +276,7 @@ let rec is_pervasive_exn = function | Error_in_file (_,_,e) -> is_pervasive_exn e | Stdpp.Exc_located (_,e) -> is_pervasive_exn e | DuringCommandInterp (_,e) -> is_pervasive_exn e - | DuringSyntaxChecking e -> is_pervasive_exn e + | DuringSyntaxChecking (_,e) -> is_pervasive_exn e | _ -> false (* Toplevel error explanation, dealing with locations, Drop, Ctrl-D @@ -272,33 +286,31 @@ let print_toplevel_error exc = let (dloc,exc) = match exc with | DuringCommandInterp (loc,ie) - | Stdpp.Exc_located (loc, DuringSyntaxChecking ie) -> + | DuringSyntaxChecking (loc,ie) -> if loc = dummy_loc then (None,ie) else (Some loc, ie) - | _ -> (None, exc) + | _ -> (None, exc) in let (locstrm,exc) = match exc with | Stdpp.Exc_located (loc, ie) -> if valid_buffer_loc top_buffer dloc loc then (print_highlight_location top_buffer loc, ie) - else + else ((mt ()) (* print_command_location top_buffer dloc *), ie) | Error_in_file (s, (inlibrary, fname, loc), ie) -> (print_location_in_file s inlibrary fname loc, ie) - | _ -> + | _ -> ((mt ()) (* print_command_location top_buffer dloc *), exc) in match exc with - | End_of_input -> + | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise Vernacexpr.Drop; (str"Error: There is no ML toplevel." ++ fnl ()) - | Vernacexpr.ProtectedLoop -> - raise Vernacexpr.ProtectedLoop - | Vernacexpr.Quit -> + | Vernacexpr.Quit -> raise Vernacexpr.Quit - | _ -> + | _ -> (if is_pervasive_exn exc then (mt ()) else locstrm) ++ Cerrors.explain_exn exc @@ -308,14 +320,14 @@ let parse_to_dot = | ("", ".") -> () | ("EOI", "") -> raise End_of_input | _ -> dot st - in + in Gram.Entry.of_parser "Coqtoplevel.dot" dot - + (* We assume that when a lexer error occurs, at least one char was eaten *) let rec discard_to_dot () = - try + try Gram.Entry.parse parse_to_dot top_buffer.tokens - with Stdpp.Exc_located(_,(Token.Error _|Lexer.Error _)) -> + with Stdpp.Exc_located(_,(Token.Error _|Lexer.Error _)) -> discard_to_dot() @@ -323,14 +335,14 @@ let rec discard_to_dot () = * in encountered. *) let process_error = function - | DuringCommandInterp _ - | Stdpp.Exc_located (_,DuringSyntaxChecking _) as e -> e + | DuringCommandInterp _ + | DuringSyntaxChecking _ as e -> e | e -> - if is_pervasive_exn e then + if is_pervasive_exn e then e - else - try - discard_to_dot (); e + else + try + discard_to_dot (); e with | End_of_input -> End_of_input | de -> if is_pervasive_exn de then de else e @@ -344,11 +356,11 @@ let do_vernac () = msgerrnl (mt ()); if !print_emacs then msgerr (str (top_buffer.prompt())); resynch_buffer top_buffer; - begin - try + begin + try raw_do_vernac top_buffer.tokens - with e -> - msgnl (print_toplevel_error (process_error e)) + with e -> + msgnl (print_toplevel_error (process_error e)) end; flush_all() @@ -356,30 +368,20 @@ let do_vernac () = * Ctrl-C will raise the exception Break instead of aborting Coq. * Here we catch the exceptions terminating the Coq loop, and decide * if we really must quit. - * The boolean value is used to choose between a protected loop, which - * we think is more suited for communication with other programs, or - * plain communication. *) + *) -let rec coq_switch b = +let rec loop () = Sys.catch_break true; (* ensure we have a command separator object (DOT) so that the first command can be reseted. *) Lib.mark_end_of_command(); try - if b then begin - reset_input_buffer stdin top_buffer; - while true do do_vernac() done - end else - protected_loop stdin + reset_input_buffer stdin top_buffer; + while true do do_vernac() done with | Vernacexpr.Drop -> () - | Vernacexpr.ProtectedLoop -> - Lib.declare_initial_state(); - coq_switch false | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Quit -> exit 0 | e -> msgerrnl (str"Anomaly. Please report."); - coq_switch b - -let loop () = coq_switch true + loop () diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli index f4d2e28a..3f2fa83a 100644 --- a/toplevel/toplevel.mli +++ b/toplevel/toplevel.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: toplevel.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Pp @@ -18,7 +18,7 @@ open Pcoq (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) -type input_buffer = { +type input_buffer = { mutable prompt : unit -> string; mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib new file mode 100644 index 00000000..4c229d16 --- /dev/null +++ b/toplevel/toplevel.mllib @@ -0,0 +1,24 @@ +Himsg +Cerrors +Class +Vernacexpr +Metasyntax +Auto_ind_decl +Libtypes +Search +Autoinstance +Lemmas +Indschemes +Command +Classes +Record +Ppvernac +Vernacinterp +Mltop +Vernacentries +Whelp +Vernac +Toplevel +Usage +Coqinit +Coqtop diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 96ff8cbc..25766048 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: usage.ml 11858 2009-01-26 13:27:23Z notin $ *) +(* $Id$ *) let version () = Printf.printf "The Coq Proof Assistant, version %s (%s)\n" @@ -23,7 +23,7 @@ let print_usage_channel co command = " -I dir -as coqdir map physical dir to logical coqdir -I dir map directory dir to the empty logical path -include dir (idem) - -R dir -as coqdir recursively map physical dir to logical coqdir + -R dir -as coqdir recursively map physical dir to logical coqdir -R dir coqdir (idem) -top coqdir set the toplevel name to be coqdir instead of Top -notop r set the toplevel name to be the empty logical path @@ -33,11 +33,12 @@ let print_usage_channel co command = -is f (idem) -nois start with an empty state -outputstate f write state in file f.coq + -compat X.Y provides compatibility support for Coq version X.Y - -load-ml-object f load ML object file f - -load-ml-source f load ML file f + -load-ml-object f load ML object file f + -load-ml-source f load ML file f -load-vernac-source f load Coq file f.v (Load f.) - -l f (idem) + -l f (idem) -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.) -lv f (idem) -load-vernac-object f load Coq object file f.vo @@ -49,6 +50,7 @@ let print_usage_channel co command = -byte run the bytecode version of Coq -where print Coq's standard library location and exit + -config print Coq's configuration information and exit -v print Coq version and exit -q skip loading of rcfile @@ -57,7 +59,7 @@ let print_usage_channel co command = -batch batch mode (exits just after arguments parsing) -boot boot mode (implies -q and -batch) -emacs tells Coq it is executed under Emacs - -noglob f do not dump globalizations + -noglob do not dump globalizations -dump-glob f dump globalizations in file f (to be used by coqdoc) -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes) -impredicative-set set sort Set impredicative @@ -86,7 +88,7 @@ options are: (* Print the configuration information *) -let print_config () = +let print_config () = if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n"; Printf.printf "COQLIB=%s/\n" Coq_config.coqlib; Printf.printf "COQSRC=%s/\n" Coq_config.coqsrc; @@ -96,3 +98,4 @@ let print_config () = Printf.printf "CAMLP4BIN=%s\n" Coq_config.camlp4bin; Printf.printf "CAMLP4LIB=%s\n" Coq_config.camlp4lib + diff --git a/toplevel/usage.mli b/toplevel/usage.mli index 0ee58f4d..fb973e3b 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -6,18 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: usage.mli 11830 2009-01-22 06:45:13Z notin $ i*) +(*i $Id$ i*) (*s Prints the version number on the standard output and exits (with 0). *) val version : unit -> 'a -(*s Prints the usage on the error output, preceded by a user-provided message. *) +(*s Prints the usage on the error output, preceeded by a user-provided message. *) val print_usage : string -> unit (*s Prints the usage on the error output. *) val print_usage_coqtop : unit -> unit val print_usage_coqc : unit -> unit -(*s Prints the configuration information. *) +(*s Prints the configuration information *) val print_config : unit -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index c5549503..96a19e30 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: vernac.ml 11801 2009-01-18 20:11:41Z herbelin $ *) +(* $Id$ *) (* Parsing of vernacular. *) @@ -25,6 +25,8 @@ open Ppvernac exception DuringCommandInterp of Util.loc * exn +exception HasNotFailed + (* Specifies which file is read. The intermediate file names are discarded here. The Drop exception becomes an error. We forget if the error ocurred during interpretation or not *) @@ -33,8 +35,8 @@ let raise_with_file file exc = let (cmdloc,re) = match exc with | DuringCommandInterp(loc,e) - | Stdpp.Exc_located (loc,DuringSyntaxChecking e) -> (loc,e) - | e -> (dummy_loc,e) + | DuringSyntaxChecking(loc,e) -> (loc,e) + | e -> (dummy_loc,e) in let (inner,inex) = match re with @@ -43,7 +45,7 @@ let raise_with_file file exc = | Stdpp.Exc_located (loc, e) when loc <> dummy_loc -> ((false,file, loc), e) | _ -> ((false,file,cmdloc), re) - in + in raise (Error_in_file (file, inner, disable_drop inex)) let real_error = function @@ -51,6 +53,8 @@ let real_error = function | Error_in_file (_, _, e) -> e | e -> e +let timeout_handler _ = raise Timeout + (* Opening and closing a channel. Open it twice when verbose: the first channel is used to read the commands, and the second one to print them. Note: we could use only one thanks to seek_in, but seeking on and on in @@ -66,7 +70,7 @@ let open_file_twice_if verbosely fname = (in_chan, longfname, (po, verb_ch)) let close_input in_chan (_,verb) = - try + try close_in in_chan; match verb with | Some verb_ch -> close_in verb_ch @@ -86,7 +90,7 @@ let verbose_phrase verbch loc = | _ -> () exception End_of_input - + let parse_phrase (po, verbch) = match Pcoq.Gram.Entry.parse Pcoq.main_entry po with | Some (loc,_ as com) -> verbose_phrase verbch loc; com @@ -131,7 +135,7 @@ let rec vernac_com interpfun (loc,com) = (* end translator state *) (* coqdoc state *) let cds = Dumpglob.coqdoc_freeze() in - if !Flags.beautify_file then + if !Flags.beautify_file then begin let _,f = find_file_in_path ~warn:(Flags.is_verbose()) (Library.get_load_paths ()) @@ -139,7 +143,7 @@ let rec vernac_com interpfun (loc,com) = chan_beautify := open_out (f^beautify_suffix); Pp.comments := [] end; - begin + begin try read_vernac_file verbosely (make_suffix fname ".v"); if !Flags.beautify_file then close_out !chan_beautify; @@ -147,7 +151,7 @@ let rec vernac_com interpfun (loc,com) = Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds - with e -> + with e -> if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; Lexer.restore_com_state cs; @@ -155,23 +159,52 @@ let rec vernac_com interpfun (loc,com) = Dumpglob.coqdoc_unfreeze cds; raise e end - + | VernacList l -> List.iter (fun (_,v) -> interp v) l + | VernacFail v -> + if not !just_parsing then begin try + interp v; raise HasNotFailed + with e -> match real_error e with + | HasNotFailed -> + errorlabstrm "Fail" (str "The command has not failed !") + | e -> + (* if [e] is an anomaly, the next function will re-raise it *) + let msg = Cerrors.explain_exn_no_anomaly e in + msgnl (str "The command has indeed failed with message:" ++ + fnl () ++ str "=> " ++ hov 0 msg) + end + | VernacTime v -> - let tstart = System.get_time() in - if not !just_parsing then interp v; - let tend = System.get_time() in - msgnl (str"Finished transaction in " ++ - System.fmt_time_difference tstart tend) + if not !just_parsing then begin + let tstart = System.get_time() in + interp v; + let tend = System.get_time() in + msgnl (str"Finished transaction in " ++ + System.fmt_time_difference tstart tend) + end + + | VernacTimeout(n,v) -> + if not !just_parsing then begin + let psh = + Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in + ignore (Unix.alarm n); + let stop() = + (* stop alarm *) + ignore(Unix.alarm 0); + (* restore handler *) + Sys.set_signal Sys.sigalrm psh in + try interp v; stop() + with e -> stop(); raise e + end | v -> if not !just_parsing then interpfun v - in + in try if do_beautify () then pr_new_syntax loc (Some com); interp com - with e -> + with e -> Format.set_formatter_out_channel stdout; raise (DuringCommandInterp (loc, e)) @@ -181,10 +214,10 @@ and vernac interpfun input = and read_vernac_file verbosely s = Flags.make_warn verbosely; let interpfun = - if verbosely then + if verbosely then Vernacentries.interp - else - Flags.silently Vernacentries.interp + else + Flags.silently Vernacentries.interp in let (in_chan, fname, input) = open_file_twice_if verbosely s in try @@ -221,17 +254,17 @@ let set_xml_end_library f = xml_end_library := f let load_vernac verb file = chan_beautify := if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout; - try + try read_vernac_file verb file; if !Flags.beautify_file then close_out !chan_beautify; - with e -> + with e -> if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file e (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in - if Dumpglob.multi_dump () then + if Dumpglob.multi_dump () then Dumpglob.open_glob_file (f ^ ".glob"); Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); if !Flags.xml_export then !xml_start_library (); @@ -242,3 +275,4 @@ let compile verbosely f = if Dumpglob.multi_dump () then Dumpglob.close_glob_file (); Library.save_library_to ldir (long_f_dot_v ^ "o") + diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 4f95376f..4dff36e5 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernac.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (* Parsing of vernacular. *) @@ -41,6 +41,6 @@ val compile : bool -> string -> unit (* Interpret a vernac AST *) -val vernac_com : +val vernac_com : (Vernacexpr.vernac_expr -> unit) -> Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 385afbec..c4286900 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacentries.ml 12343 2009-09-17 17:02:03Z glondu $ i*) +(*i $Id$ i*) (* Concrete syntax of the mathematical vernacular MV V2.6 *) @@ -36,6 +36,7 @@ open Topconstr open Pretyping open Redexpr open Syntax_def +open Lemmas (* Pcoq hooks *) @@ -44,7 +45,7 @@ type pcoq_hook = { solve : int -> unit; abort : string -> unit; search : searchable -> dir_path list * bool -> unit; - print_name : reference -> unit; + print_name : reference Genarg.or_by_notation -> unit; print_check : Environ.env -> Environ.unsafe_judgment -> unit; print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr -> Environ.unsafe_judgment -> unit; @@ -59,7 +60,7 @@ let set_pcoq_hook f = pcoq := Some f let cl_of_qualid = function | FunClass -> Classops.CL_FUN | SortClass -> Classops.CL_SORT - | RefClass r -> Class.class_of_global (global_with_alias r) + | RefClass r -> Class.class_of_global (Smartlocate.smart_global r) (*******************) (* "Show" commands *) @@ -72,7 +73,7 @@ let show_proof () = msgnl (str"LOC: " ++ prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ str"Subgoals" ++ fnl () ++ - prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ + prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ pr_ltype ty ++ fnl ()) meta_types ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm)) @@ -90,7 +91,7 @@ let show_node () = str" " ++ hov 0 (prlist_with_sep pr_fnl pr_goal (List.map goal_of_proof spfl))))) - + let show_script () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts @@ -101,9 +102,9 @@ let show_thesis () = msgnl (anomaly "TODO" ) let show_top_evars () = - let pfts = get_pftreestate () in - let gls = top_goal_of_pftreestate pfts in - let sigma = project gls in + let pfts = get_pftreestate () in + let gls = top_goal_of_pftreestate pfts in + let sigma = project gls in msg (pr_evars_int 1 (Evarutil.non_instantiated sigma)) let show_prooftree () = @@ -119,40 +120,40 @@ let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () let show_intro all = let pf = get_pftreestate() in let gl = nth_goal_of_pftreestate 1 pf in - let l,_= Sign.decompose_prod_assum (strip_outer_cast (pf_concl gl)) in - if all - then - let lid = Tactics.find_intro_names l gl in + let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in + if all + then + let lid = Tactics.find_intro_names l gl in msgnl (hov 0 (prlist_with_sep spc pr_id lid)) - else - try + else + try let n = list_last l in msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl))) with Failure "list_last" -> message "" -let id_of_name = function - | Names.Anonymous -> id_of_string "x" +let id_of_name = function + | Names.Anonymous -> id_of_string "x" | Names.Name x -> x (* Building of match expression *) (* From ide/coq.ml *) -let make_cases s = +let make_cases s = let qualified_name = Libnames.qualid_of_string s in let glob_ref = Nametab.locate qualified_name in match glob_ref with - | Libnames.IndRef i -> + | Libnames.IndRef i -> let {Declarations.mind_nparams = np} - , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } + , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } = Global.lookup_inductive i in - Util.array_fold_right2 - (fun n t l -> + Util.array_fold_right2 + (fun n t l -> let (al,_) = Term.decompose_prod t in let al,_ = Util.list_chop (List.length al - np) al in - let rec rename avoid = function + let rec rename avoid = function | [] -> [] - | (n,_)::l -> - let n' = Termops.next_global_ident_away true (id_of_name n) avoid in + | (n,_)::l -> + let n' = Namegen.next_ident_away_in_goal (id_of_name n) avoid in string_of_id n' :: rename (n'::avoid) l in let al' = rename [] (List.rev al) in (string_of_id n :: al') :: l) @@ -160,18 +161,18 @@ let make_cases s = | _ -> raise Not_found -let show_match id = +let show_match id = try let s = string_of_id (snd id) in - let patterns = make_cases s in - let cases = - List.fold_left - (fun acc x -> + let patterns = List.rev (make_cases s) in + let cases = + List.fold_left + (fun acc x -> match x with | [] -> assert false | [x] -> "| "^ x ^ " => \n" ^ acc - | x::l -> - "| (" ^ List.fold_left (fun acc s -> acc ^ " " ^ s) x l ^ ")" + | x::l -> + "| (" ^ List.fold_left (fun acc s -> acc ^ " " ^ s) x l ^ ")" ^ " => \n" ^ acc) "end" patterns in msg (str ("match # with\n" ^ cases)) @@ -196,7 +197,7 @@ let print_modules () = and loaded = Library.loaded_libraries () in let loaded_opened = list_intersect loaded opened and only_loaded = list_subtract loaded opened in - str"Loaded and imported library files: " ++ + str"Loaded and imported library files: " ++ pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ str"Loaded and not imported library files: " ++ pr_vertical_list pr_dirpath only_loaded @@ -213,7 +214,7 @@ let print_module r = with Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid) -let print_modtype r = +let print_modtype r = let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in @@ -226,7 +227,7 @@ let dump_universes s = try Univ.dump_universes output (Global.universes ()); close_out output; - msgnl (str ("Universes written to file \""^s^"\".")) + msgnl (str ("Universes written to file \""^s^"\".")) with e -> close_out output; raise e @@ -252,7 +253,7 @@ let msg_notfound_library loc qid = function strbrk "Cannot find a physical path bound to logical path " ++ pr_dirpath dir ++ str".") | Library.LibNotFound -> - msgnl (hov 0 + msgnl (hov 0 (strbrk "Unable to locate library " ++ pr_qualid qid ++ str".")) | e -> assert false @@ -261,22 +262,31 @@ let print_located_library r = try msg_found_library (Library.locate_qualified_library false qid) with e -> msg_notfound_library loc qid e -let print_located_module r = +let print_located_module r = let (loc,qid) = qualid_of_reference r in let msg = - try + try let dir = Nametab.full_name_module qid in str "Module " ++ pr_dirpath dir with Not_found -> (if fst (repr_qualid qid) = empty_dirpath then str "No module is referred to by basename " - else + else str "No module is referred to by name ") ++ pr_qualid qid - in msgnl msg + in msgnl msg -let global_with_alias r = - let gr = global_with_alias r in - Dumpglob.add_glob (loc_of_reference r) gr; +let print_located_tactic r = + let (loc,qid) = qualid_of_reference r in + msgnl + (try + str "Ltac " ++ + pr_path (Nametab.path_of_tactic (Nametab.locate_tactic qid)) + with Not_found -> + str "No Ltac definition is referred to by " ++ pr_qualid qid) + +let smart_global r = + let gr = Smartlocate.smart_global r in + Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr; gr (**********) @@ -286,13 +296,13 @@ let vernac_syntax_extension = Metasyntax.add_syntax_extension let vernac_delimiters = Metasyntax.add_delimiters -let vernac_bind_scope sc cll = +let vernac_bind_scope sc cll = List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll let vernac_open_close_scope = Notation.open_close_scope let vernac_arguments_scope local r scl = - Notation.declare_arguments_scope local (global_with_alias r) scl + Notation.declare_arguments_scope local (smart_global r) scl let vernac_infix = Metasyntax.add_infix @@ -306,28 +316,26 @@ let start_proof_and_print k l hook = print_subgoals (); if !pcoq <> None then (Option.get !pcoq).start_proof () -let vernac_definition (local,_,_ as k) (loc,id as lid) def hook = - Dumpglob.dump_definition lid false "def"; +let vernac_definition (local,boxed,k) (loc,id as lid) def hook = + if local = Local then Dumpglob.dump_definition lid true "var" + else Dumpglob.dump_definition lid false "def"; (match def with | ProveBody (bl,t) -> (* local binders, typ *) - if Lib.is_modtype () then - errorlabstrm "Vernacentries.VernacDefinition" - (str "Proof editing mode not supported in module types") - else - let hook _ _ = () in - start_proof_and_print (local,DefinitionBody Definition) - [Some lid, (bl,t)] hook + let hook _ _ = () in + start_proof_and_print (local,DefinitionBody Definition) + [Some lid, (bl,t,None)] hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with | None -> None - | Some r -> - let (evc,env)= Command.get_current_context () in + | Some r -> + let (evc,env)= get_current_context () in Some (interp_redexp env evc r) in - declare_definition id k bl red_option c typ_opt hook) - + let ce,imps = interp_definition boxed bl red_option c typ_opt in + declare_definition id (local,k) ce imps hook) + let vernac_start_proof kind l lettop hook = if Dumpglob.dump () then - List.iter (fun (id, _) -> + List.iter (fun (id, _) -> match id with | Some lid -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; @@ -335,9 +343,6 @@ let vernac_start_proof kind l lettop hook = if lettop then errorlabstrm "Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); - if Lib.is_modtype () then - errorlabstrm "Vernacentries.StartProof" - (str "Proof editing mode not supported in module types."); start_proof_and_print (Global, Proof kind) l hook let vernac_end_proof = function @@ -361,95 +366,90 @@ let vernac_exact_proof c = else errorlabstrm "Vernacentries.ExactProof" (strbrk "Command 'Proof ...' can only be used at the beginning of the proof.") - + let vernac_assumption kind l nl= + if Pfedit.refining () then + errorlabstrm "" + (str "Cannot declare an assumption while in proof editing mode."); let global = fst kind = Global in - List.iter (fun (is_coe,(idl,c)) -> + List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then - List.iter (fun lid -> - if global then Dumpglob.dump_definition lid false "ax" + List.iter (fun lid -> + if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl; - declare_assumption idl is_coe kind [] c false [] nl) l + let t,imps = interp_assumption [] c in + declare_assumptions idl is_coe kind t imps false nl) l -let vernac_record k finite struc binders sort nameopt cfs = - let const = match nameopt with +let vernac_record k finite infer struc binders sort nameopt cfs = + let const = match nameopt with | None -> add_prefix "Build_" (snd (snd struc)) | Some (_,id as lid) -> Dumpglob.dump_definition lid false "constr"; id in - let sigma = Evd.empty in - let env = Global.env() in - let s = Option.map (fun x -> - let s = Reductionops.whd_betadeltaiota env sigma (interp_constr sigma env x) in - match kind_of_term s with - | Sort s -> s - | _ -> user_err_loc - (constr_loc x,"definition_structure", str "Sort expected.")) sort - in if Dumpglob.dump () then ( Dumpglob.dump_definition (snd struc) false "rec"; List.iter (fun ((_, x), _) -> match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); - ignore(Record.definition_structure (k,finite,struc,binders,cfs,const,s)) - -let vernac_inductive finite indl = + ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort)) + +let vernac_inductive finite infer indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> - match cstrs with - | Constructors cstrs -> - Dumpglob.dump_definition lid false "ind"; - List.iter (fun (_, (lid, _)) -> - Dumpglob.dump_definition lid false "constr") cstrs - | _ -> () (* dumping is done by vernac_record (called below) *) ) - indl; + match cstrs with + | Constructors cstrs -> + Dumpglob.dump_definition lid false "ind"; + List.iter (fun (_, (lid, _)) -> + Dumpglob.dump_definition lid false "constr") cstrs + | _ -> () (* dumping is done by vernac_record (called below) *) ) + indl; match indl with - | [ ( id , bl , c , b, RecordDecl (oc,fs) ), None ] -> + | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class true -> Class false | _ -> b) - finite id bl c oc fs - | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> - let f = + finite infer id bl c oc fs + | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> + let f = let (coe, ((loc, id), ce)) = l in - ((coe, AssumExpr ((loc, Name id), ce)), None) - in vernac_record (Class true) finite id bl c None [f] - | [ ( id , bl , c , Class true, _), _ ] -> + ((coe, AssumExpr ((loc, Name id), ce)), []) + in vernac_record (Class true) finite infer id bl c None [f] + | [ ( id , bl , c , Class true, _), _ ] -> Util.error "Definitional classes must have a single method" | [ ( id , bl , c , Class false, Constructors _), _ ] -> Util.error "Inductive classes not supported" - | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> + | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> Util.error "where clause not supported for (co)inductive records" - | _ -> let unpack = function + | _ -> let unpack = function | ( (_, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn | _ -> Util.error "Cannot handle mutually (co)inductive records." in let indl = List.map unpack indl in - Command.build_mutual indl (recursivity_flag_of_kind finite) + do_mutual_inductive indl (recursivity_flag_of_kind finite) -let vernac_fixpoint l b = +let vernac_fixpoint l b = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - build_recursive l b + do_fixpoint l b let vernac_cofixpoint l b = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - build_corecursive l b + do_cofixpoint l b -let vernac_scheme = build_scheme +let vernac_scheme = Indschemes.do_scheme -let vernac_combined_scheme = build_combined_scheme +let vernac_combined_scheme = Indschemes.do_combined_scheme (**********************) (* Modules *) let vernac_import export refl = - let import ref = + let import ref = Library.import_module export (qualid_of_reference ref) in List.iter import refl; Lib.add_frozen_state () -let vernac_declare_module export (loc, id) binders_ast mty_ast_o = +let vernac_declare_module export (loc, id) binders_ast mty_ast = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then @@ -461,21 +461,22 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast_o = "Remove the \"Export\" and \"Import\" keywords from every functor " ^ "argument.") else (idl,ty)) binders_ast in - let mp = Declaremods.declare_module + let mp = Declaremods.declare_module Modintern.interp_modtype Modintern.interp_modexpr - id binders_ast (Some mty_ast_o) None - in + Modintern.interp_modexpr_or_modtype + id binders_ast (Enforce mty_ast) [] + in Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Module "^ string_of_id id ^" is declared"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export -let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = +let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then error "Modules and Module Types are not allowed inside sections."; - match mexpr_ast_o with - | None -> + match mexpr_ast_l with + | [] -> check_no_pending_proofs (); let binders_ast,argsexport = List.fold_right @@ -483,17 +484,17 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast ([],[]) in let mp = Declaremods.start_module Modintern.interp_modtype export - id binders_ast mty_ast_o + id binders_ast mty_ast_o in Dumpglob.dump_moddef loc mp "mod"; - if_verbose message + if_verbose message ("Interactive Module "^ string_of_id id ^" started") ; List.iter (fun (export,id) -> Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export ) argsexport - | Some _ -> + | _::_ -> let binders_ast = List.map (fun (export,idl,ty) -> if export <> None then @@ -501,46 +502,48 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = " the definition is interactive. Remove the \"Export\" and " ^ "\"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in - let mp = Declaremods.declare_module + let mp = Declaremods.declare_module Modintern.interp_modtype Modintern.interp_modexpr - id binders_ast mty_ast_o mexpr_ast_o + Modintern.interp_modexpr_or_modtype + id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef loc mp "mod"; - if_verbose message + if_verbose message ("Module "^ string_of_id id ^" is defined"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export -let vernac_end_module export (loc,id) = - let mp = Declaremods.end_module id in - Dumpglob.dump_modref loc mp "mod"; - if_verbose message ("Module "^ string_of_id id ^" is defined") ; - Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export - +let vernac_end_module export (loc,id as lid) = + let mp = Declaremods.end_module () in + Dumpglob.dump_modref loc mp "mod"; + if_verbose message ("Module "^ string_of_id id ^" is defined") ; + Option.iter (fun export -> vernac_import export [Ident lid]) export -let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = +let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then error "Modules and Module Types are not allowed inside sections."; - - match mty_ast_o with - | None -> + + match mty_ast_l with + | [] -> check_no_pending_proofs (); - let binders_ast,argsexport = - List.fold_right + let binders_ast,argsexport = + List.fold_right (fun (export,idl,ty) (args,argsexport) -> - (idl,ty)::args, List.map (fun (_,i) -> export,i) idl) binders_ast + (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast ([],[]) in - let mp = Declaremods.start_modtype Modintern.interp_modtype id binders_ast in + + let mp = Declaremods.start_modtype + Modintern.interp_modtype id binders_ast mty_sign in Dumpglob.dump_moddef loc mp "modtype"; - if_verbose message + if_verbose message ("Interactive Module Type "^ string_of_id id ^" started"); List.iter (fun (export,id) -> Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export ) argsexport - - | Some base_mty -> + + | _ :: _ -> let binders_ast = List.map (fun (export,idl,ty) -> if export <> None then @@ -548,70 +551,66 @@ let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = " the definition is interactive. Remove the \"Export\" " ^ "and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in - let mp = Declaremods.declare_modtype Modintern.interp_modtype - id binders_ast base_mty in + let mp = Declaremods.declare_modtype Modintern.interp_modtype + Modintern.interp_modexpr_or_modtype + id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef loc mp "modtype"; - if_verbose message + if_verbose message ("Module Type "^ string_of_id id ^" is defined") - let vernac_end_modtype (loc,id) = - let mp = Declaremods.end_modtype id in - Dumpglob.dump_modref loc mp "modtype"; - if_verbose message - ("Module Type "^ string_of_id id ^" is defined") - -let vernac_include = function - | CIMTE mty_ast -> - Declaremods.declare_include Modintern.interp_modtype mty_ast false - | CIME mexpr_ast -> - Declaremods.declare_include Modintern.interp_modexpr mexpr_ast true - - - + let mp = Declaremods.end_modtype () in + Dumpglob.dump_modref loc mp "modtype"; + if_verbose message ("Module Type "^ string_of_id id ^" is defined") + +let vernac_include l = + Declaremods.declare_include Modintern.interp_modexpr_or_modtype l + (**********************) (* Gallina extensions *) - (* Sections *) +(* Sections *) let vernac_begin_section (_, id as lid) = check_no_pending_proofs (); Dumpglob.dump_definition lid true "sec"; Lib.open_section id -let vernac_end_section (loc, id) = - - Dumpglob.dump_reference loc - (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec"; - Lib.close_section id +let vernac_end_section (loc,_) = + Dumpglob.dump_reference loc + (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec"; + Lib.close_section () -let vernac_end_segment lid = +(* Dispatcher of the "End" command *) + +let vernac_end_segment (_,id as lid) = check_no_pending_proofs (); - let o = try Lib.what_is_opened () with - Not_found -> error "There is nothing to end." in - match o with - | _,Lib.OpenedModule (export,_,_) -> vernac_end_module export lid - | _,Lib.OpenedModtype _ -> vernac_end_modtype lid - | _,Lib.OpenedSection _ -> vernac_end_section lid - | _ -> anomaly "No more opened things" + match Lib.find_opening_node id with + | Lib.OpenedModule (export,_,_) -> vernac_end_module export lid + | Lib.OpenedModtype _ -> vernac_end_modtype lid + | Lib.OpenedSection _ -> vernac_end_section lid + | _ -> anomaly "No more opened things" + +(* Libraries *) let vernac_require import _ qidl = let qidl = List.map qualid_of_reference qidl in - if Dumpglob.dump () then begin - let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in - List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl) - end; - Library.require_library qidl import + let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in + if Dumpglob.dump () then + List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl); + Library.require_library_from_dirpath modrefl import + +(* Coercions and canonical structures *) let vernac_canonical r = - Recordops.declare_canonical_structure (global_with_alias r) + Recordops.declare_canonical_structure (smart_global r) let vernac_coercion stre ref qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - let ref' = global_with_alias ref in + let ref' = smart_global ref in Class.try_add_new_coercion_with_target ref' stre source target; - if_verbose message ((string_of_reference ref) ^ " is now a coercion") + if_verbose msgnl (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion stre id qids qidt = let target = cl_of_qualid qidt in @@ -619,18 +618,20 @@ let vernac_identity_coercion stre id qids qidt = Class.try_add_new_identity_coercion id stre source target (* Type classes *) - -let vernac_instance glob sup inst props pri = + +let vernac_instance abst glob sup inst props pri = Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance ~global:glob sup inst props pri) + ignore(Classes.new_instance ~abstract:abst ~global:glob sup inst props pri) let vernac_context l = List.iter (fun x -> Dumpglob.dump_local_binder x true "var") l; Classes.context l -let vernac_declare_instance id = - Dumpglob.dump_definition id false "inst"; - Classes.declare_instance false id +let vernac_declare_instance glob id = + Classes.declare_instance glob id + +let vernac_declare_class id = + Classes.declare_class id (***********) (* Solving *) @@ -639,12 +640,12 @@ let vernac_solve n tcom b = error "Unknown command of the non proof-editing mode."; Decl_mode.check_not_proof_mode "Unknown proof instruction"; begin - if b then + if b then solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ())) else solve_nth n (Tacinterp.hide_interp tcom None) end; - (* in case a strict subtree was completed, - go back to the top of the prooftree *) + (* in case a strict subtree was completed, + go back to the top of the prooftree *) if subtree_solved () then begin Flags.if_verbose msgnl (str "Subgoal proved"); make_focus 0; @@ -656,9 +657,9 @@ let vernac_solve n tcom b = (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof machine, and enables to instantiate existential variables when - there are no more goals to solve. It cannot be a tactic since + there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) - + let vernac_solve_existential = instantiate_nth_evar_com let vernac_set_end_tac tac = @@ -670,9 +671,9 @@ let vernac_set_end_tac tac = (***********************) (* Proof Language Mode *) -let vernac_decl_proof () = +let vernac_decl_proof () = check_not_proof_mode "Already in Proof Mode"; - if tree_solved () then + if tree_solved () then error "Nothing left to prove here." else begin @@ -680,17 +681,17 @@ let vernac_decl_proof () = print_subgoals () end -let vernac_return () = +let vernac_return () = match get_current_mode () with Mode_tactic -> Decl_proof_instr.return_from_tactic_mode (); print_subgoals () - | Mode_proof -> + | Mode_proof -> error "\"return\" is only used after \"escape\"." - | Mode_none -> - error "There is no proof to end." + | Mode_none -> + error "There is no proof to end." -let vernac_proof_instr instr = +let vernac_proof_instr instr = Decl_proof_instr.proof_instr instr; print_subgoals () @@ -718,8 +719,8 @@ let vernac_add_ml_path isrec path = (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (System.expand_path_macros path) -let vernac_declare_ml_module l = - Mltop.declare_ml_modules (List.map System.expand_path_macros l) +let vernac_declare_ml_module local l = + Mltop.declare_ml_modules local (List.map System.expand_path_macros l) let vernac_chdir = function | None -> message (Sys.getcwd()) @@ -759,71 +760,77 @@ let vernac_backto n = Lib.reset_label n (************) (* Commands *) -let vernac_declare_tactic_definition = Tacinterp.add_tacdef +let vernac_declare_tactic_definition (local,x,def) = + Tacinterp.add_tacdef local x def -let vernac_create_hintdb local id b = +let vernac_create_hintdb local id b = Auto.create_hint_db local id full_transparent_state b -let vernac_hints = Auto.add_hints +let vernac_hints local lb h = + Auto.add_hints local lb (Auto.interp_hints h) let vernac_syntactic_definition lid = Dumpglob.dump_definition lid false "syndef"; - Command.syntax_definition (snd lid) - + Metasyntax.add_syntactic_definition (snd lid) + let vernac_declare_implicits local r = function | Some imps -> - Impargs.declare_manual_implicits local (global_with_alias r) ~enriching:false - (List.map (fun (ex,b,f) -> ex, (b,f)) imps) - | None -> - Impargs.declare_implicits local (global_with_alias r) + Impargs.declare_manual_implicits local (smart_global r) ~enriching:false + (List.map (fun (ex,b,f) -> ex, (b,true,f)) imps) + | None -> + Impargs.declare_implicits local (smart_global r) -let vernac_reserve idl c = - let t = Constrintern.interp_type Evd.empty (Global.env()) c in - let t = Detyping.detype false [] [] t in - List.iter (fun id -> Reserve.declare_reserved_type id t) idl +let vernac_reserve bl = + let sb_decl = (fun (idl,c) -> + let t = Constrintern.interp_type Evd.empty (Global.env()) c in + let t = Detyping.detype false [] [] t in + List.iter (fun id -> Reserve.declare_reserved_type id t) idl) + in List.iter sb_decl bl + +let vernac_generalizable = Implicit_quantifiers.declare_generalizable let make_silent_if_not_pcoq b = - if !pcoq <> None then + if !pcoq <> None then error "Turning on/off silent flag is not supported in Pcoq mode." else make_silent b let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "silent"; - optkey = (PrimaryTable "Silent"); + optkey = ["Silent"]; optread = is_silent; optwrite = make_silent_if_not_pcoq } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit arguments"; - optkey = (SecondaryTable ("Implicit","Arguments")); + optkey = ["Implicit";"Arguments"]; optread = Impargs.is_implicit_args; optwrite = Impargs.make_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "strict implicit arguments"; - optkey = (SecondaryTable ("Strict","Implicit")); + optkey = ["Strict";"Implicit"]; optread = Impargs.is_strict_implicit_args; optwrite = Impargs.make_strict_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "strong strict implicit arguments"; - optkey = (TertiaryTable ("Strongly","Strict","Implicit")); + optkey = ["Strongly";"Strict";"Implicit"]; optread = Impargs.is_strongly_strict_implicit_args; optwrite = Impargs.make_strongly_strict_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "contextual implicit arguments"; - optkey = (SecondaryTable ("Contextual","Implicit")); + optkey = ["Contextual";"Implicit"]; optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } @@ -831,159 +838,167 @@ let _ = (* declare_bool_option *) (* { optsync = true; *) (* optname = "forceable implicit arguments"; *) -(* optkey = (SecondaryTable ("Forceable","Implicit")); *) +(* optkey = ["Forceable";"Implicit")); *) (* optread = Impargs.is_forceable_implicit_args; *) (* optwrite = Impargs.make_forceable_implicit_args } *) let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit status of reversible patterns"; - optkey = (TertiaryTable ("Reversible","Pattern","Implicit")); + optkey = ["Reversible";"Pattern";"Implicit"]; optread = Impargs.is_reversible_pattern_implicit_args; optwrite = Impargs.make_reversible_pattern_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "maximal insertion of implicit"; - optkey = (TertiaryTable ("Maximal","Implicit","Insertion")); + optkey = ["Maximal";"Implicit";"Insertion"]; optread = Impargs.is_maximal_implicit_args; optwrite = Impargs.make_maximal_implicit_args } let _ = - declare_bool_option + declare_bool_option + { optsync = true; + optname = "automatic introduction of variables"; + optkey = ["Automatic";"Introduction"]; + optread = Flags.is_auto_intros; + optwrite = make_auto_intros } + +let _ = + declare_bool_option { optsync = true; optname = "coercion printing"; - optkey = (SecondaryTable ("Printing","Coercions")); + optkey = ["Printing";"Coercions"]; optread = (fun () -> !Constrextern.print_coercions); optwrite = (fun b -> Constrextern.print_coercions := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "printing of existential variable instances"; - optkey = (TertiaryTable ("Printing","Existential","Instances")); + optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Constrextern.print_evar_arguments); optwrite = (:=) Constrextern.print_evar_arguments } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit arguments printing"; - optkey = (SecondaryTable ("Printing","Implicit")); + optkey = ["Printing";"Implicit"]; optread = (fun () -> !Constrextern.print_implicits); optwrite = (fun b -> Constrextern.print_implicits := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit arguments defensive printing"; - optkey = (TertiaryTable ("Printing","Implicit","Defensive")); + optkey = ["Printing";"Implicit";"Defensive"]; optread = (fun () -> !Constrextern.print_implicits_defensive); optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "projection printing using dot notation"; - optkey = (SecondaryTable ("Printing","Projections")); + optkey = ["Printing";"Projections"]; optread = (fun () -> !Constrextern.print_projections); optwrite = (fun b -> Constrextern.print_projections := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "notations printing"; - optkey = (SecondaryTable ("Printing","Notations")); + optkey = ["Printing";"Notations"]; optread = (fun () -> not !Constrextern.print_no_symbol); optwrite = (fun b -> Constrextern.print_no_symbol := not b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "raw printing"; - optkey = (SecondaryTable ("Printing","All")); + optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); optwrite = (fun b -> Flags.raw_print := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "use of virtual machine inside the kernel"; - optkey = (SecondaryTable ("Virtual","Machine")); + optkey = ["Virtual";"Machine"]; optread = (fun () -> Vconv.use_vm ()); optwrite = (fun b -> Vconv.set_use_vm b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "use of boxed definitions"; - optkey = (SecondaryTable ("Boxed","Definitions")); + optkey = ["Boxed";"Definitions"]; optread = Flags.boxed_definitions; - optwrite = (fun b -> Flags.set_boxed_definitions b) } + optwrite = (fun b -> Flags.set_boxed_definitions b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "use of boxed values"; - optkey = (SecondaryTable ("Boxed","Values")); + optkey = ["Boxed";"Values"]; optread = (fun _ -> not (Vm.transp_values ())); - optwrite = (fun b -> Vm.set_transp_values (not b)) } + optwrite = (fun b -> Vm.set_transp_values (not b)) } let _ = declare_int_option - { optsync=false; - optkey=PrimaryTable("Undo"); - optname="the undo limit"; - optread=Pfedit.get_undo; - optwrite=Pfedit.set_undo } + { optsync = false; + optname = "the undo limit"; + optkey = ["Undo"]; + optread = Pfedit.get_undo; + optwrite = Pfedit.set_undo } let _ = declare_int_option - { optsync=false; - optkey=SecondaryTable("Hyps","Limit"); - optname="the hypotheses limit"; - optread=Flags.print_hyps_limit; - optwrite=Flags.set_print_hyps_limit } + { optsync = false; + optname = "the hypotheses limit"; + optkey = ["Hyps";"Limit"]; + optread = Flags.print_hyps_limit; + optwrite = Flags.set_print_hyps_limit } let _ = declare_int_option - { optsync=true; - optkey=SecondaryTable("Printing","Depth"); - optname="the printing depth"; - optread=Pp_control.get_depth_boxes; - optwrite=Pp_control.set_depth_boxes } + { optsync = true; + optname = "the printing depth"; + optkey = ["Printing";"Depth"]; + optread = Pp_control.get_depth_boxes; + optwrite = Pp_control.set_depth_boxes } let _ = declare_int_option - { optsync=true; - optkey=SecondaryTable("Printing","Width"); - optname="the printing width"; - optread=Pp_control.get_margin; - optwrite=Pp_control.set_margin } + { optsync = true; + optname = "the printing width"; + optkey = ["Printing";"Width"]; + optread = Pp_control.get_margin; + optwrite = Pp_control.set_margin } let _ = declare_bool_option - { optsync=true; - optkey=SecondaryTable("Printing","Universes"); - optname="printing of universes"; - optread=(fun () -> !Constrextern.print_universes); - optwrite=(fun b -> Constrextern.print_universes:=b) } + { optsync = true; + optname = "printing of universes"; + optkey = ["Printing";"Universes"]; + optread = (fun () -> !Constrextern.print_universes); + optwrite = (fun b -> Constrextern.print_universes:=b) } let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) let _ = declare_bool_option - { optsync=false; - optkey=SecondaryTable("Ltac","Debug"); - optname="Ltac debug"; - optread=(fun () -> get_debug () <> Tactic_debug.DebugOff); - optwrite=vernac_debug } + { optsync = false; + optname = "Ltac debug"; + optkey = ["Ltac";"Debug"]; + optread = (fun () -> get_debug () <> Tactic_debug.DebugOff); + optwrite = vernac_debug } let vernac_set_opacity local str = let glob_ref r = - match global_with_alias r with + match smart_global r with | ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> error @@ -991,15 +1006,15 @@ let vernac_set_opacity local str = let str = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) str in Redexpr.set_strategy local str -let vernac_set_option key = function - | StringValue s -> set_string_option_value key s - | IntValue n -> set_int_option_value key (Some n) - | BoolValue b -> set_bool_option_value key b +let vernac_set_option locality key = function + | StringValue s -> set_string_option_value_gen locality key s + | IntValue n -> set_int_option_value_gen locality key (Some n) + | BoolValue b -> set_bool_option_value_gen locality key b -let vernac_unset_option key = - try set_bool_option_value key false +let vernac_unset_option locality key = + try set_bool_option_value_gen locality key false with _ -> - set_int_option_value key None + set_int_option_value_gen locality key None let vernac_add_option key lv = let f = function @@ -1048,6 +1063,9 @@ let vernac_check_may_eval redexp glopt rc = then (Option.get !pcoq).print_eval redfun env evmap rc j else msg (print_eval redfun env evmap rc j) +let vernac_declare_reduction locality s r = + declare_red_expr locality s (interp_redexp (Global.env()) Evd.empty r) + (* The same but avoiding the current goal context if any *) let vernac_global_check c = let evmap = Evd.empty in @@ -1069,14 +1087,13 @@ let vernac_print = function | PrintModuleType qid -> print_modtype qid | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () - | PrintName qid -> + | PrintName qid -> if !pcoq <> None then (Option.get !pcoq).print_name qid else msg (print_name qid) - | PrintOpaqueName qid -> msg (print_opaque_name qid) | PrintGraph -> ppnl (Prettyp.print_graph()) | PrintClasses -> ppnl (Prettyp.print_classes()) | PrintTypeClasses -> ppnl (Prettyp.print_typeclasses()) - | PrintInstances c -> ppnl (Prettyp.print_instances (global c)) + | PrintInstances c -> ppnl (Prettyp.print_instances (smart_global c)) | PrintLtac qid -> ppnl (Tacinterp.print_ltac (snd (qualid_of_reference qid))) | PrintCoercions -> ppnl (Prettyp.print_coercions()) | PrintCoercionPaths (cls,clt) -> @@ -1084,7 +1101,7 @@ let vernac_print = function | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ()) | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ())) | PrintUniverses (Some s) -> dump_universes s - | PrintHint r -> Auto.print_hint_ref (global_with_alias r) + | PrintHint r -> Auto.print_hint_ref (smart_global r) | PrintHintGoal -> Auto.print_applicable_hint () | PrintHintDbName s -> Auto.print_hint_db_by_name s | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s @@ -1099,7 +1116,7 @@ let vernac_print = function | PrintImplicit qid -> msg (print_impargs qid) (*spiwack: prints all the axioms and section variables used by a term *) | PrintAssumptions (o,r) -> - let cstr = constr_of_global (global_with_alias r) in + let cstr = constr_of_global (smart_global r) in let nassumptions = Environ.assumptions (Conv_oracle.get_transp_state ()) ~add_opaque:o cstr (Global.env ()) in msg (Printer.pr_assumptionset (Global.env ()) nassumptions) @@ -1107,7 +1124,7 @@ let vernac_print = function let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid - with Not_found -> + with Not_found -> user_err_loc (loc, "global_module", str "Module/section " ++ pr_qualid qid ++ str " not found.") @@ -1126,12 +1143,12 @@ let interp_search_about_item = function | SearchString (s,None) when is_ident s -> GlobSearchString s | SearchString (s,sc) -> - try + try let ref = Notation.interp_notation_as_global_reference dummy_loc (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) - with UserError _ -> + with UserError _ -> error ("Unable to interp \""^s^"\" either as a reference or as an identifier component") @@ -1140,24 +1157,27 @@ let vernac_search s r = if !pcoq <> None then (Option.get !pcoq).search s r else match s with | SearchPattern c -> - let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in - Search.search_pattern pat r + let (_,c) = interp_open_constr_patvar Evd.empty (Global.env()) c in + Search.search_pattern c r | SearchRewrite c -> - let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in + let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in Search.search_rewrite pat r - | SearchHead ref -> - Search.search_by_head (global_with_alias ref) r + | SearchHead c -> + let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in + Search.search_by_head pat r | SearchAbout sl -> Search.search_about (List.map (on_snd interp_search_about_item) sl) r let vernac_locate = function - | LocateTerm qid -> msgnl (print_located_qualid qid) + | LocateTerm (Genarg.AN qid) -> msgnl (print_located_qualid qid) + | LocateTerm (Genarg.ByNotation (_,ntn,sc)) -> + ppnl + (Notation.locate_notation + (Constrextern.without_symbols pr_lrawconstr) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> print_located_module qid + | LocateTactic qid -> print_located_tactic qid | LocateFile f -> locate_file f - | LocateNotation ntn -> - ppnl (Notation.locate_notation (Constrextern.without_symbols pr_lrawconstr) - (Metasyntax.standardize_locatable_notation ntn)) (********************) (* Proof management *) @@ -1169,7 +1189,7 @@ let vernac_goal = function let unnamed_kind = Lemma (* Arbitrary *) in start_proof_com (Global, Proof unnamed_kind) [None,c] (fun _ _ ->()); print_subgoals () - end else + end else error "repeated Goal not permitted in refining mode." let vernac_abort = function @@ -1214,14 +1234,14 @@ let vernac_backtrack snum pnum naborts = Pp.flush_all(); (* there may be no proof in progress, even if no abort *) (try print_subgoals () with UserError _ -> ()) - + let vernac_focus gln = check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; - match gln with + match gln with | None -> traverse_nth_goal 1; print_subgoals () | Some n -> traverse_nth_goal n; print_subgoals () - + (* Reset the focus to the top of the tree *) let vernac_unfocus () = check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; @@ -1238,7 +1258,7 @@ let apply_subproof f occ = let evc = evc_of_pftreestate pts in let rec aux pts = function | [] -> pts - | (n::l) -> aux (Tacmach.traverse n pts) occ in + | (n::l) -> aux (Tacmach.traverse n pts) occ in let pts = aux pts (occ@[-1]) in let pf = proof_of_pftreestate pts in f evc (Global.named_context()) pf @@ -1277,19 +1297,20 @@ let vernac_check_guard () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts in let (pfterm,_) = extract_open_pftreestate pts in - let message = - try + let message = + try Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf)) - pfterm; + pfterm; (str "The condition holds up to here") - with UserError(_,s) -> + with UserError(_,s) -> (str ("Condition violated: ") ++s) - in + in msgnl message let interp c = match c with (* Control (done in vernac) *) - | (VernacTime _ | VernacList _ | VernacLoad _) -> assert false + | (VernacTime _|VernacList _|VernacLoad _|VernacTimeout _|VernacFail _) -> + assert false (* Syntax *) | VernacTacticNotation (n,r,e) -> Metasyntax.add_tactic_notation (n,r,e) @@ -1307,21 +1328,21 @@ let interp c = match c with | VernacEndProof e -> vernac_end_proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption stre l nl - | VernacInductive (finite,l) -> vernac_inductive finite l + | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l | VernacFixpoint (l,b) -> vernac_fixpoint l b | VernacCoFixpoint (l,b) -> vernac_cofixpoint l b | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l (* Modules *) - | VernacDeclareModule (export,lid,bl,mtyo) -> + | VernacDeclareModule (export,lid,bl,mtyo) -> vernac_declare_module export lid bl mtyo - | VernacDefineModule (export,lid,bl,mtyo,mexpro) -> - vernac_define_module export lid bl mtyo mexpro - | VernacDeclareModuleType (lid,bl,mtyo) -> - vernac_declare_module_type lid bl mtyo - | VernacInclude (in_ast) -> - vernac_include in_ast + | VernacDefineModule (export,lid,bl,mtys,mexprl) -> + vernac_define_module export lid bl mtys mexprl + | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> + vernac_declare_module_type lid bl mtys mtyo + | VernacInclude in_asts -> + vernac_include in_asts (* Gallina extensions *) | VernacBeginSection lid -> vernac_begin_section lid @@ -1334,9 +1355,11 @@ let interp c = match c with | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t (* Type classes *) - | VernacInstance (glob, sup, inst, props, pri) -> vernac_instance glob sup inst props pri + | VernacInstance (abst, glob, sup, inst, props, pri) -> + vernac_instance abst glob sup inst props pri | VernacContext sup -> vernac_context sup - | VernacDeclareInstance id -> vernac_declare_instance id + | VernacDeclareInstance (glob, id) -> vernac_declare_instance glob id + | VernacDeclareClass id -> vernac_declare_class id (* Solving *) | VernacSolve (n,tac,b) -> vernac_solve n tac b @@ -1346,7 +1369,7 @@ let interp c = match c with | VernacDeclProof -> vernac_decl_proof () | VernacReturn -> vernac_return () - | VernacProofInstr stp -> vernac_proof_instr stp + | VernacProofInstr stp -> vernac_proof_instr stp (* /MMode *) @@ -1355,7 +1378,7 @@ let interp c = match c with | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias | VernacRemoveLoadPath s -> vernac_remove_loadpath s | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> vernac_declare_ml_module l + | VernacDeclareMLModule (local, l) -> vernac_declare_ml_module local l | VernacChdir s -> vernac_chdir s (* State management *) @@ -1370,20 +1393,22 @@ let interp c = match c with | VernacBackTo n -> vernac_backto n (* Commands *) - | VernacDeclareTacticDefinition (x,l) -> vernac_declare_tactic_definition x l + | VernacDeclareTacticDefinition def -> vernac_declare_tactic_definition def | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l - | VernacReserve (idl,c) -> vernac_reserve idl c + | VernacReserve bl -> vernac_reserve bl + | VernacGeneralizable (local,gen) -> vernac_generalizable local gen | VernacSetOpacity (local,qidl) -> vernac_set_opacity local qidl - | VernacSetOption (key,v) -> vernac_set_option key v - | VernacUnsetOption key -> vernac_unset_option key + | VernacSetOption (locality,key,v) -> vernac_set_option locality key v + | VernacUnsetOption (locality,key) -> vernac_unset_option locality key | VernacRemoveOption (key,v) -> vernac_remove_option key v | VernacAddOption (key,v) -> vernac_add_option key v | VernacMemOption (key,v) -> vernac_mem_option key v | VernacPrintOption key -> vernac_print_option key | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c + | VernacDeclareReduction (b,s,r) -> vernac_declare_reduction b s r | VernacGlobalCheck c -> vernac_global_check c | VernacPrint p -> vernac_print p | VernacSearch (s,r) -> vernac_search s r @@ -1392,7 +1417,7 @@ let interp c = match c with | VernacNop -> () (* Proof management *) - | VernacGoal t -> vernac_start_proof Theorem [None,([],t)] false (fun _ _->()) + | VernacGoal t -> vernac_start_proof Theorem [None,([],t,None)] false (fun _ _->()) | VernacAbort id -> vernac_abort id | VernacAbortAll -> vernac_abort_all () | VernacRestart -> vernac_restart () @@ -1412,3 +1437,6 @@ let interp c = match c with (* Extensions *) | VernacExtend (opn,args) -> Vernacinterp.call (opn,args) + +let interp c = interp c ; check_locality () + diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 8afb783b..44e8b7ab 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacentries.mli 10580 2008-02-22 13:39:13Z lmamane $ i*) +(*i $Id$ i*) (*i*) open Names @@ -38,7 +38,7 @@ type pcoq_hook = { solve : int -> unit; abort : string -> unit; search : searchable -> dir_path list * bool -> unit; - print_name : Libnames.reference -> unit; + print_name : Libnames.reference Genarg.or_by_notation -> unit; print_check : Environ.env -> Environ.unsafe_judgment -> unit; print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr -> Environ.unsafe_judgment -> unit; @@ -54,4 +54,4 @@ val abort_refine : ('a -> unit) -> 'a -> unit;; val interp : Vernacexpr.vernac_expr -> unit -val vernac_reset_name : identifier Util.located -> unit +val vernac_reset_name : identifier Util.located -> unit diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 4da16ea7..4a2a218b 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacexpr.ml 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) open Util open Names @@ -18,7 +18,6 @@ open Decl_kinds open Ppextend (* Toplevel control exceptions *) -exception ProtectedLoop exception Drop exception Quit @@ -27,11 +26,11 @@ open Nametab type lident = identifier located type lname = name located -type lstring = string +type lstring = string located type lreference = reference -type class_rawexpr = FunClass | SortClass | RefClass of reference - +type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation + type printable = | PrintTables | PrintFullContext @@ -44,18 +43,17 @@ type printable = | PrintModuleType of reference | PrintMLLoadPath | PrintMLModules - | PrintName of reference - | PrintOpaqueName of reference + | PrintName of reference or_by_notation | PrintGraph | PrintClasses | PrintTypeClasses - | PrintInstances of reference + | PrintInstances of reference or_by_notation | PrintLtac of reference | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr | PrintCanonicalConversions | PrintUniverses of string option - | PrintHint of reference + | PrintHint of reference or_by_notation | PrintHintGoal | PrintHintDbName of string | PrintRewriteHintDbName of string @@ -63,9 +61,9 @@ type printable = | PrintScopes | PrintScope of string | PrintVisibility of string option - | PrintAbout of reference - | PrintImplicit of reference - | PrintAssumptions of bool * reference + | PrintAbout of reference or_by_notation + | PrintImplicit of reference or_by_notation + | PrintAssumptions of bool * reference or_by_notation type search_about_item = | SearchSubPattern of constr_pattern_expr @@ -74,15 +72,15 @@ type search_about_item = type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr - | SearchHead of reference + | SearchHead of constr_pattern_expr | SearchAbout of (bool * search_about_item) list type locatable = - | LocateTerm of reference + | LocateTerm of reference or_by_notation | LocateLibrary of reference | LocateModule of reference + | LocateTactic of reference | LocateFile of string - | LocateNotation of notation type goable = | GoTo of int @@ -110,7 +108,7 @@ type comment = | CommentString of string | CommentInt of int -type hints = +type hints_expr = | HintsResolve of (int option * bool * constr_expr) list | HintsImmediate of constr_expr list | HintsUnfold of reference list @@ -124,15 +122,6 @@ type search_restriction = | SearchInside of reference list | SearchOutside of reference list -type option_value = - | StringValue of string - | IntValue of int - | BoolValue of bool - -type option_ref_value = - | StringRefValue of string - | QualidRefValue of reference - type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) type opacity_flag = bool (* true = Opaque; false = Transparent *) @@ -142,6 +131,17 @@ type export_flag = bool (* true = Export; false = Import *) type specif_flag = bool (* true = Specification; false = Implementation *) type inductive_flag = Decl_kinds.recursivity_kind type onlyparsing_flag = bool (* true = Parse only; false = Print also *) +type infer_flag = bool (* true = try to Infer record; false = nothing *) +type full_locality_flag = bool option (* true = Local; false = Global *) + +type option_value = + | StringValue of string + | IntValue of int + | BoolValue of bool + +type option_ref_value = + | StringRefValue of string + | QualidRefValue of reference type sort_expr = Rawterm.rawsort @@ -150,69 +150,89 @@ type definition_expr = | DefineBody of local_binder list * raw_red_expr option * constr_expr * constr_expr option +type fixpoint_expr = + identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option + +type cofixpoint_expr = + identifier located * local_binder list * constr_expr * constr_expr option + type local_decl_expr = | AssumExpr of lname * constr_expr | DefExpr of lname * constr_expr * constr_expr option type inductive_kind = Inductive_kw | CoInductive | Record | Structure | Class of bool (* true = definitional, false = inductive *) -type decl_notation = (string * constr_expr * scope_name option) option +type decl_notation = lstring * constr_expr * scope_name option type simple_binder = lident list * constr_expr type class_binder = lident * constr_expr list type 'a with_coercion = coercion_flag * 'a -type 'a with_notation = 'a * decl_notation +type 'a with_notation = 'a * decl_notation list type constructor_expr = (lident * constr_expr) with_coercion type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_coercion with_notation list type inductive_expr = - lident with_coercion * local_binder list * constr_expr option * inductive_kind * + lident with_coercion * local_binder list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr -type module_binder = bool option * lident list * module_type_ast +type one_inductive_expr = + lident * local_binder list * constr_expr option * constructor_expr list + +type module_binder = bool option * lident list * module_ast_inl -type grammar_production = - | VTerm of string - | VNonTerm of loc * string * Names.identifier option +type grammar_tactic_prod_item_expr = + | TacTerm of string + | TacNonTerm of loc * string * (Names.identifier * string) option + +type syntax_modifier = + | SetItemLevel of string list * production_level + | SetLevel of int + | SetAssoc of Gramext.g_assoc + | SetEntryType of string * simple_constr_prod_entry_key + | SetOnlyParsing + | SetFormat of string located type proof_end = | Admitted | Proved of opacity_flag * (lident * theorem_kind option) option type scheme = - | InductionScheme of bool * lreference * sort_expr - | EqualityScheme of lreference + | InductionScheme of bool * reference or_by_notation * sort_expr + | EqualityScheme of reference or_by_notation type vernac_expr = (* Control *) | VernacList of located_vernac_expr list - | VernacLoad of verbose_flag * lstring + | VernacLoad of verbose_flag * string | VernacTime of vernac_expr + | VernacTimeout of int * vernac_expr + | VernacFail of vernac_expr - (* Syntax *) - | VernacTacticNotation of int * grammar_production list * raw_tactic_expr + (* Syntax *) + | VernacTacticNotation of int * grammar_tactic_prod_item_expr list * raw_tactic_expr | VernacSyntaxExtension of locality_flag * (lstring * syntax_modifier list) | VernacOpenCloseScope of (locality_flag * bool * scope_name) - | VernacDelimiters of scope_name * lstring + | VernacDelimiters of scope_name * string | VernacBindScope of scope_name * class_rawexpr list - | VernacArgumentsScope of locality_flag * lreference * scope_name option list + | VernacArgumentsScope of locality_flag * reference or_by_notation * + scope_name option list | VernacInfix of locality_flag * (lstring * syntax_modifier list) * - lreference * scope_name option + constr_expr * scope_name option | VernacNotation of locality_flag * constr_expr * (lstring * syntax_modifier list) * scope_name option (* Gallina *) - | VernacDefinition of definition_kind * lident * definition_expr * + | VernacDefinition of definition_kind * lident * definition_expr * declaration_hook - | VernacStartTheoremProof of theorem_kind * - (lident option * (local_binder list * constr_expr)) list * + | VernacStartTheoremProof of theorem_kind * + (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list * bool * declaration_hook | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of assumption_kind * bool * simple_binder with_coercion list - | VernacInductive of inductive_flag * (inductive_expr * decl_notation) list - | VernacFixpoint of (fixpoint_expr * decl_notation) list * bool - | VernacCoFixpoint of (cofixpoint_expr * decl_notation) list * bool + | VernacInductive of inductive_flag * infer_flag * (inductive_expr * decl_notation list) list + | VernacFixpoint of (fixpoint_expr * decl_notation list) list * bool + | VernacCoFixpoint of (cofixpoint_expr * decl_notation list) list * bool | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list @@ -222,20 +242,15 @@ type vernac_expr = | VernacRequire of export_flag option * specif_flag option * lreference list | VernacImport of export_flag * lreference list - | VernacCanonical of lreference - | VernacCoercion of locality * lreference * class_rawexpr * class_rawexpr - | VernacIdentityCoercion of locality * lident * + | VernacCanonical of reference or_by_notation + | VernacCoercion of locality * reference or_by_notation * + class_rawexpr * class_rawexpr + | VernacIdentityCoercion of locality * lident * class_rawexpr * class_rawexpr (* Type classes *) -(* | VernacClass of *) -(* lident * (\* name *\) *) -(* local_binder list * (\* params *\) *) -(* sort_expr located option * (\* arity *\) *) -(* local_binder list * (\* constraints *\) *) -(* (lident * bool * constr_expr) list (\* props, with substructure hints *\) *) - | VernacInstance of + bool * (* abstract instance *) bool * (* global *) local_binder list * (* super *) typeclass_constraint * (* instance name, class name, params *) @@ -243,18 +258,20 @@ type vernac_expr = int option (* Priority *) | VernacContext of local_binder list - + | VernacDeclareInstance of - lident (* instance name *) + bool (* global *) * reference (* instance name *) + + | VernacDeclareClass of reference (* inductive or definition name *) (* Modules and Module Types *) - | VernacDeclareModule of bool option * lident * - module_binder list * (module_type_ast * bool) - | VernacDefineModule of bool option * lident * - module_binder list * (module_type_ast * bool) option * module_ast option - | VernacDeclareModuleType of lident * - module_binder list * module_type_ast option - | VernacInclude of include_ast + | VernacDeclareModule of bool option * lident * + module_binder list * module_ast_inl + | VernacDefineModule of bool option * lident * + module_binder list * module_ast_inl module_signature * module_ast_inl list + | VernacDeclareModuleType of lident * + module_binder list * module_ast_inl list * module_ast_inl list + | VernacInclude of module_ast_inl list (* Solving *) @@ -269,16 +286,16 @@ type vernac_expr = (* Auxiliary file and library management *) - | VernacRequireFrom of export_flag option * specif_flag option * lstring - | VernacAddLoadPath of rec_flag * lstring * dir_path option - | VernacRemoveLoadPath of lstring - | VernacAddMLPath of rec_flag * lstring - | VernacDeclareMLModule of lstring list - | VernacChdir of lstring option + | VernacRequireFrom of export_flag option * specif_flag option * string + | VernacAddLoadPath of rec_flag * string * dir_path option + | VernacRemoveLoadPath of string + | VernacAddMLPath of rec_flag * string + | VernacDeclareMLModule of locality_flag * string list + | VernacChdir of string option (* State management *) - | VernacWriteState of lstring - | VernacRestoreState of lstring + | VernacWriteState of string + | VernacRestoreState of string (* Resetting *) | VernacRemoveName of lident @@ -289,24 +306,26 @@ type vernac_expr = (* Commands *) | VernacDeclareTacticDefinition of - rec_flag * (reference * bool * raw_tactic_expr) list - | VernacCreateHintDb of locality_flag * lstring * bool - | VernacHints of locality_flag * lstring list * hints + (locality_flag * rec_flag * (reference * bool * raw_tactic_expr) list) + | VernacCreateHintDb of locality_flag * string * bool + | VernacHints of locality_flag * string list * hints_expr | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) * locality_flag * onlyparsing_flag - | VernacDeclareImplicits of locality_flag * lreference * + | VernacDeclareImplicits of locality_flag * reference or_by_notation * (explicitation * bool * bool) list option - | VernacReserve of lident list * constr_expr + | VernacReserve of simple_binder list + | VernacGeneralizable of locality_flag * (lident list) option | VernacSetOpacity of - locality_flag * (Conv_oracle.level * lreference list) list - | VernacUnsetOption of Goptions.option_name - | VernacSetOption of Goptions.option_name * option_value + locality_flag * (Conv_oracle.level * reference or_by_notation list) list + | VernacUnsetOption of full_locality_flag * Goptions.option_name + | VernacSetOption of full_locality_flag * Goptions.option_name * option_value | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list | VernacPrintOption of Goptions.option_name | VernacCheckMayEval of raw_red_expr option * int option * constr_expr | VernacGlobalCheck of constr_expr + | VernacDeclareReduction of locality_flag * string * raw_red_expr | VernacPrint of printable | VernacSearch of searchable * search_restriction | VernacLocate of locatable @@ -340,68 +359,118 @@ and located_vernac_expr = loc * vernac_expr (* Locating errors raised just after the dot is parsed but before the interpretation phase *) -exception DuringSyntaxChecking of exn +exception DuringSyntaxChecking of exn located -let syntax_checking_error s = - raise (DuringSyntaxChecking (UserError ("",Pp.str s))) +let syntax_checking_error loc s = + raise (DuringSyntaxChecking (loc,UserError ("",Pp.str s))) +(**********************************************************************) (* Managing locality *) let locality_flag = ref None let local_of_bool = function true -> Local | false -> Global +let is_true = function Some (_,b) -> b | _ -> false +let is_false = function Some (_,b) -> not b | _ -> false + let check_locality () = - if !locality_flag = Some true then - syntax_checking_error "This command does not support the \"Local\" prefix."; - if !locality_flag = Some false then - syntax_checking_error "This command does not support the \"Global\" prefix." + match !locality_flag with + | Some (loc,true) -> + syntax_checking_error loc + "This command does not support the \"Local\" prefix."; + | Some (loc,false) -> + syntax_checking_error loc + "This command does not support the \"Global\" prefix." + | None -> () + +(** Extracting the locality flag *) -let use_locality () = - let local = match !locality_flag with Some true -> true | _ -> false in +(* Commands which supported an inlined Local flag *) + +let enforce_locality_full local = + let local = + match !locality_flag with + | Some (_,false) when local -> + error "Cannot be simultaneously Local and Global." + | Some (_,true) when local -> + error "Use only prefix \"Local\"." + | None -> + if local then begin + Flags.if_verbose + Pp.msg_warning (Pp.str"Obsolete syntax: use \"Local\" as a prefix."); + Some true + end else + None + | Some (_,b) -> Some b in locality_flag := None; local -let use_locality_exp () = local_of_bool (use_locality ()) +(* Commands which did not supported an inlined Local flag (synonym of + [enforce_locality_full false]) *) -let use_section_locality () = - let local = - match !locality_flag with Some b -> b | None -> Lib.sections_are_opened () - in +let use_locality_full () = + let r = Option.map snd !locality_flag in locality_flag := None; - local + r + +(** Positioning locality for commands supporting discharging and export + outside of modules *) + +(* For commands whose default is to discharge and export: + Global is the default and is neutral; + Local in a section deactivates discharge, + Local not in a section deactivates export *) + +let make_locality = function Some true -> true | _ -> false + +let use_locality () = make_locality (use_locality_full ()) + +let use_locality_exp () = local_of_bool (use_locality ()) + +let enforce_locality local = make_locality (enforce_locality_full local) + +let enforce_locality_exp local = local_of_bool (enforce_locality local) + +(* For commands whose default is not to discharge and not to export: + Global forces discharge and export; + Local is the default and is neutral *) let use_non_locality () = - let local = match !locality_flag with Some false -> false | _ -> true in - locality_flag := None; - local + match use_locality_full () with Some false -> false | _ -> true -let enforce_locality () = - let local = - match !locality_flag with - | Some false -> - error "Cannot be simultaneously Local and Global." - | _ -> - Flags.if_verbose - Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; - true in - locality_flag := None; - local +(* For commands whose default is to not discharge but to export: + Global in sections forces discharge, Global not in section is the default; + Local in sections is the default, Local not in section forces non-export *) -let enforce_locality_exp () = local_of_bool (enforce_locality ()) +let make_section_locality = + function Some b -> b | None -> Lib.sections_are_opened () + +let use_section_locality () = + make_section_locality (use_locality_full ()) + +let enforce_section_locality local = + make_section_locality (enforce_locality_full local) + +(** Positioning locality for commands supporting export but not discharge *) + +(* For commands whose default is to export (if not in section): + Global in sections is forbidden, Global not in section is neutral; + Local in sections is the default, Local not in section forces non-export *) + +let make_module_locality = function + | Some false -> + if Lib.sections_are_opened () then + error "This command does not support the Global option in sections."; + false + | Some true -> true + | None -> false + +let use_module_locality () = + make_module_locality (use_locality_full ()) + +let enforce_module_locality local = + make_module_locality (enforce_locality_full local) + +(**********************************************************************) -let enforce_locality_of local = - let local = - match !locality_flag with - | Some false when local -> - error "Cannot be simultaneously Local and Global." - | Some true when local -> - error "Use only prefix \"Local\"." - | None -> - if local then - Flags.if_verbose - Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; - local - | Some b -> b in - locality_flag := None; - local diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index 41669c47..0924e519 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: vernacinterp.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -27,24 +27,24 @@ let vernac_tab = (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t) let vinterp_add s f = - try + try Hashtbl.add vernac_tab s f with Failure _ -> errorlabstrm "vinterp_add" (str"Cannot add the vernac command " ++ str s ++ str" twice.") let overwriting_vinterp_add s f = - begin - try - let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s + begin + try + let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s with Not_found -> () end; Hashtbl.add vernac_tab s f let vinterp_map s = - try + try Hashtbl.find vernac_tab s - with Not_found -> + with Not_found -> errorlabstrm "Vernac Interpreter" (str"Cannot find vernac command " ++ str s ++ str".") @@ -62,7 +62,6 @@ let call (opn,converted_args) = hunk() with | Drop -> raise Drop - | ProtectedLoop -> raise ProtectedLoop | e -> if !Flags.debug then msgnl (str"Vernac Interpreter " ++ str !loc); diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli index e0c34dc9..7adc7493 100644 --- a/toplevel/vernacinterp.mli +++ b/toplevel/vernacinterp.mli @@ -6,18 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacinterp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Tacexpr (*i*) (* Interpretation of extended vernac phrases. *) - + val disable_drop : exn -> exn val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit -val overwriting_vinterp_add : +val overwriting_vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit val vinterp_init : unit -> unit diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 62aaa303..98a79a9c 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: whelp.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Flags open Pp @@ -30,7 +30,7 @@ open Refiner open Tacmach open Syntax_def -(* Coq interface to the Whelp query engine developed at +(* Coq interface to the Whelp query engine developed at the University of Bologna *) let whelp_server_name = ref "http://mowgli.cs.unibo.it:58080" @@ -39,18 +39,18 @@ let getter_server_name = ref "http://mowgli.cs.unibo.it:58081" open Goptions let _ = - declare_string_option + declare_string_option { optsync = false; optname = "Whelp server"; - optkey = (SecondaryTable ("Whelp","Server")); + optkey = ["Whelp";"Server"]; optread = (fun () -> !whelp_server_name); optwrite = (fun s -> whelp_server_name := s) } let _ = - declare_string_option + declare_string_option { optsync = false; optname = "Whelp getter"; - optkey = (SecondaryTable ("Whelp","Getter")); + optkey = ["Whelp";"Getter"]; optread = (fun () -> !getter_server_name); optwrite = (fun s -> getter_server_name := s) } @@ -61,7 +61,7 @@ let make_whelp_request req c = let b = Buffer.create 16 let url_char c = - if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or + if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or '0' <= c & c <= '9' or c ='.' then Buffer.add_char b c else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c)) @@ -71,7 +71,7 @@ let url_string s = String.iter url_char s let rec url_list_with_sep sep f = function | [] -> () | [a] -> f a - | a::l -> f a; url_string sep; url_list_with_sep sep f l + | a::l -> f a; url_string sep; url_list_with_sep sep f l let url_id id = url_string (string_of_id id) @@ -81,10 +81,10 @@ let uri_of_dirpath dir = let error_whelp_unknown_reference ref = let qid = Nametab.shortest_qualid_of_global Idset.empty ref in errorlabstrm "" - (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ + (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ strbrk ", are not supported in Whelp.") -let uri_of_repr_kn ref (mp,dir,l) = +let uri_of_repr_kn ref (mp,dir,l) = match mp with | MPfile sl -> uri_of_dirpath (id_of_label l :: repr_dirpath dir @ repr_dirpath sl) @@ -109,10 +109,10 @@ let uri_of_global ref = | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id)^".") | ConstRef cst -> uri_of_repr_kn ref (repr_con cst); url_string ".con" - | IndRef (kn,i) -> - uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1] + | IndRef (kn,i) -> + uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1] | ConstructRef ((kn,i),j) -> - uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1;j] + uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j] let whelm_special = id_of_string "WHELM_ANON_VAR" @@ -124,16 +124,16 @@ let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c let uri_params f = function | [] -> () - | l -> url_string "\\subst"; + | l -> url_string "\\subst"; url_bracket (url_list_with_sep ";" (uri_of_binding f)) l let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) let section_parameters = function | RRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) -> - get_discharged_hyp_names (sp_of_global (IndRef(induri,0))) + get_discharged_hyp_names (path_of_global (IndRef(induri,0))) | RRef (_,(ConstRef cst as ref)) -> - get_discharged_hyp_names (sp_of_global ref) + get_discharged_hyp_names (path_of_global ref) | _ -> [] let merge vl al = @@ -151,7 +151,7 @@ let rec uri_of_constr c = | _ -> url_paren (fun () -> match c with | RApp (_,f,args) -> let inst,rest = merge (section_parameters f) args in - uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; + uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; url_list_with_sep " " uri_of_constr rest | RLambda (_,na,k,ty,c) -> url_string "\\lambda "; url_of_name na; url_string ":"; @@ -170,7 +170,7 @@ let rec uri_of_constr c = error "Whelp does not support pattern-matching and (co-)fixpoint." | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ | RCast (_,_, CastCoerce) -> anomaly "Written w/o parenthesis" - | RPatVar _ | RDynamic _ -> + | RPatVar _ | RDynamic _ -> anomaly "Found constructors not supported in constr") () let make_string f x = Buffer.reset b; f x; Buffer.contents b @@ -185,14 +185,14 @@ let whelp_constr req c = send_whelp req (make_string uri_of_constr c) let whelp_constr_expr req c = - let (sigma,env)= get_current_context () in + let (sigma,env)= Lemmas.get_current_context () in let _,c = interp_open_constr sigma env c in whelp_constr req c let whelp_locate s = send_whelp "locate" s -let whelp_elim ind = +let whelp_elim ind = send_whelp "elim" (make_string uri_of_global (IndRef ind)) let on_goal f = @@ -215,13 +215,13 @@ VERNAC ARGUMENT EXTEND whelp_constr_request END VERNAC COMMAND EXTEND Whelp -| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] -| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] -| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (inductive_of_reference_with_alias r) ] +| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] +| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] +| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ] | [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c] END VERNAC COMMAND EXTEND WhelpHint -| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] -| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] +| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] +| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] END diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli index f3f7408a..2f1621a7 100644 --- a/toplevel/whelp.mli +++ b/toplevel/whelp.mli @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: whelp.mli 7837 2006-01-11 09:47:32Z herbelin $ i*) +(*i $Id$ i*) -(* Coq interface to the Whelp query engine developed at +(* Coq interface to the Whelp query engine developed at the University of Bologna *) open Names |