From 6b649aba925b6f7462da07599fe67ebb12a3460e Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Wed, 28 Jul 2004 21:54:47 +0000 Subject: Imported Upstream version 8.0pl1 --- pretyping/cases.ml | 1773 ++++++++++++++++++++++++++++++++++++++++++ pretyping/cases.mli | 56 ++ pretyping/cbv.ml | 352 +++++++++ pretyping/cbv.mli | 55 ++ pretyping/classops.ml | 397 ++++++++++ pretyping/classops.mli | 116 +++ pretyping/coercion.ml | 211 +++++ pretyping/coercion.mli | 46 ++ pretyping/detyping.ml | 492 ++++++++++++ pretyping/detyping.mli | 42 + pretyping/doc.tex | 14 + pretyping/evarconv.ml | 397 ++++++++++ pretyping/evarconv.mli | 28 + pretyping/evarutil.ml | 579 ++++++++++++++ pretyping/evarutil.mli | 97 +++ pretyping/evd.ml | 74 ++ pretyping/evd.mli | 57 ++ pretyping/indrec.ml | 553 +++++++++++++ pretyping/indrec.mli | 56 ++ pretyping/inductiveops.ml | 352 +++++++++ pretyping/inductiveops.mli | 93 +++ pretyping/instantiate.ml | 68 ++ pretyping/instantiate.mli | 25 + pretyping/matching.ml | 254 ++++++ pretyping/matching.mli | 52 ++ pretyping/pattern.ml | 287 +++++++ pretyping/pattern.mli | 91 +++ pretyping/pretype_errors.ml | 164 ++++ pretyping/pretype_errors.mli | 100 +++ pretyping/pretyping.ml | 1024 ++++++++++++++++++++++++ pretyping/pretyping.mli | 86 ++ pretyping/rawterm.ml | 365 +++++++++ pretyping/rawterm.mli | 139 ++++ pretyping/recordops.ml | 176 +++++ pretyping/recordops.mli | 58 ++ pretyping/reductionops.ml | 717 +++++++++++++++++ pretyping/reductionops.mli | 190 +++++ pretyping/retyping.ml | 131 ++++ pretyping/retyping.mli | 36 + pretyping/tacred.ml | 953 +++++++++++++++++++++++ pretyping/tacred.mli | 85 ++ pretyping/termops.ml | 938 ++++++++++++++++++++++ pretyping/termops.mli | 186 +++++ pretyping/typing.ml | 174 +++++ pretyping/typing.mli | 27 + 45 files changed, 12166 insertions(+) create mode 100644 pretyping/cases.ml create mode 100644 pretyping/cases.mli create mode 100644 pretyping/cbv.ml create mode 100644 pretyping/cbv.mli create mode 100755 pretyping/classops.ml create mode 100644 pretyping/classops.mli create mode 100644 pretyping/coercion.ml create mode 100644 pretyping/coercion.mli create mode 100644 pretyping/detyping.ml create mode 100644 pretyping/detyping.mli create mode 100644 pretyping/doc.tex create mode 100644 pretyping/evarconv.ml create mode 100644 pretyping/evarconv.mli create mode 100644 pretyping/evarutil.ml create mode 100644 pretyping/evarutil.mli create mode 100644 pretyping/evd.ml create mode 100644 pretyping/evd.mli create mode 100644 pretyping/indrec.ml create mode 100644 pretyping/indrec.mli create mode 100644 pretyping/inductiveops.ml create mode 100644 pretyping/inductiveops.mli create mode 100644 pretyping/instantiate.ml create mode 100644 pretyping/instantiate.mli create mode 100644 pretyping/matching.ml create mode 100644 pretyping/matching.mli create mode 100644 pretyping/pattern.ml create mode 100644 pretyping/pattern.mli create mode 100644 pretyping/pretype_errors.ml create mode 100644 pretyping/pretype_errors.mli create mode 100644 pretyping/pretyping.ml create mode 100644 pretyping/pretyping.mli create mode 100644 pretyping/rawterm.ml create mode 100644 pretyping/rawterm.mli create mode 100755 pretyping/recordops.ml create mode 100755 pretyping/recordops.mli create mode 100644 pretyping/reductionops.ml create mode 100644 pretyping/reductionops.mli create mode 100644 pretyping/retyping.ml create mode 100644 pretyping/retyping.mli create mode 100644 pretyping/tacred.ml create mode 100644 pretyping/tacred.mli create mode 100644 pretyping/termops.ml create mode 100644 pretyping/termops.mli create mode 100644 pretyping/typing.ml create mode 100644 pretyping/typing.mli (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml new file mode 100644 index 00000000..2126f015 --- /dev/null +++ b/pretyping/cases.ml @@ -0,0 +1,1773 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mkProd_or_LetIn d (crec (push_rel d env) rea) + | [] -> mkExistential isevars env (dummy_loc, InternalHole) in + crec env (List.rev cstr.cs_args) + +let rec_branch_scheme env isevars (sp,j) recargs cstr = + let rec crec env (args,recargs) = + match args, recargs with + | (name,None,c as d)::rea,(ra::reca) -> + let d = + match dest_recarg ra with + | Mrec k when k=j -> + let t = mkExistential isevars env (dummy_loc, InternalHole) + in + mkArrow t + (crec (push_rel (Anonymous,None,t) env) + (List.rev (lift_rel_context 1 (List.rev rea)),reca)) + | _ -> crec (push_rel d env) (rea,reca) in + mkProd (name, c, d) + + | (name,Some b,c as d)::rea, reca -> + mkLetIn (name,b, c,crec (push_rel d env) (rea,reca)) + | [],[] -> mkExistential isevars env (dummy_loc, InternalHole) + | _ -> anomaly "rec_branch_scheme" + in + crec env (List.rev cstr.cs_args,recargs) + +let branch_scheme env isevars isrec indf = + let (ind,params) = dest_ind_family indf in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let cstrs = get_constructors env indf in + if isrec then + array_map2 + (rec_branch_scheme env isevars ind) + (dest_subterms mip.mind_recargs) cstrs + else + Array.map (norec_branch_scheme env isevars) cstrs + +(******************************************************) +(* B) Building ML like case expressions without types *) + +let concl_n env sigma = + let rec decrec m c = if m = 0 then (nf_evar sigma c) else + match kind_of_term (whd_betadeltaiota env sigma c) with + | Prod (n,_,c_0) -> decrec (m-1) c_0 + | _ -> failwith "Typing.concl_n" + in + decrec + +let count_rec_arg j = + let rec crec i = function + | [] -> i + | ra::l -> + (match dest_recarg ra with + Mrec k -> crec (if k=j then (i+1) else i) l + | _ -> crec i l) + in + crec 0 + +(* if arity of mispec is (p_bar:P_bar)(a_bar:A_bar)s where p_bar are the + * K parameters. Then then build_notdep builds the predicate + * [a_bar:A'_bar](lift k pred) + * where A'_bar = A_bar[p_bar <- globargs] *) + +let build_dep_pred env sigma indf pred = + let arsign,_ = get_arity env indf in + let psign = (Anonymous,None,build_dependent_inductive env indf)::arsign in + let nar = List.length psign in + it_mkLambda_or_LetIn_name env (lift nar pred) psign + +type ml_case_error = + | MlCaseAbsurd + | MlCaseDependent + +exception NotInferable of ml_case_error + + +let pred_case_ml env sigma isrec (IndType (indf,realargs)) (i,ft) = + let pred = + let (ind,params) = dest_ind_family indf in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let recargs = dest_subterms mip.mind_recargs in + if Array.length recargs = 0 then raise (NotInferable MlCaseAbsurd); + let recargi = recargs.(i) in + let j = snd ind in (* index of inductive *) + let nbrec = if isrec then count_rec_arg j recargi else 0 in + let nb_arg = List.length (recargs.(i)) + nbrec in + let pred = Evarutil.refresh_universes (concl_n env sigma nb_arg ft) in + if noccur_between 1 nb_arg pred then + lift (-nb_arg) pred + else + raise (NotInferable MlCaseDependent) + in + build_dep_pred env sigma indf pred + +(************************************************************************) +(* Pattern-matching compilation (Cases) *) +(************************************************************************) + +(************************************************************************) +(* Configuration, errors and warnings *) + +open Pp + +let mssg_may_need_inversion () = + str "This pattern-matching is not exhaustive." + +let mssg_this_case_cannot_occur () = + "This pattern-matching is not exhaustive." + +(* Utils *) +let make_anonymous_patvars = + list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) + +(* Environment management *) +let push_rels vars env = List.fold_right push_rel vars env + +let push_rel_defs = + List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e) + +(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize + over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) + +let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j + +let rec regeneralize_index i k t = match kind_of_term t with + | Rel j when j = i+k -> mkRel (k+1) + | Rel j when j < i+k -> t + | Rel j when j > i+k -> t + | _ -> map_constr_with_binders succ (regeneralize_index i) k t + +type alias_constr = + | DepAlias + | NonDepAlias + +let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = + { uj_val = + (match d with + | DepAlias -> mkLetIn (na,deppat,t,j.uj_val) + | NonDepAlias -> + if (not (dependent (mkRel 1) j.uj_type)) + or (* A leaf: *) isRel deppat + then + (* The body of pat is not needed to type j - see *) + (* insert_aliases - and both deppat and nondeppat have the *) + (* same type, then one can freely substitute one by the other *) + subst1 nondeppat j.uj_val + else + (* The body of pat is not needed to type j but its value *) + (* is dependent in the type of j; our choice is to *) + (* enforce this dependency *) + mkLetIn (na,deppat,t,j.uj_val)); + uj_type = subst1 deppat j.uj_type } + +(**********************************************************************) +(* Structures used in compiling pattern-matching *) +type 'a lifted = int * 'a + +let insert_lifted a = (0,a);; + +(* The pattern variables for [it] are in [user_ids] and the variables + to avoid are in [other_ids]. +*) + +type rhs = + { rhs_env : env; + other_ids : identifier list; + user_ids : identifier list; + rhs_lift : int; + it : rawconstr } + +type equation = + { dependencies : constr lifted list; + patterns : cases_pattern list; + rhs : rhs; + alias_stack : name list; + eqn_loc : loc; + used : bool ref; + tag : pattern_source } + +type matrix = equation list + +(* 1st argument of IsInd is the original ind before extracting the summary *) +type tomatch_type = + | IsInd of types * inductive_type + | NotInd of constr option * types + +type tomatch_status = + | Pushed of ((constr * tomatch_type) * int list) + | Alias of (constr * constr * alias_constr * constr) + | Abstract of rel_declaration + +type tomatch_stack = tomatch_status list + +(* The type [predicate_signature] types the terms to match and the rhs: + + - [PrLetIn (n,dep,pred)] types a pushed term ([Pushed]), if dep is true, + the term is dependent, if n<>0 then the type of the pushed term is + necessarily inductive with n real arguments. Otherwise, it may be + non inductive, or inductive without real arguments, or inductive + originating from a subterm in which case real args are not dependent; + it accounts for n+1 binders if dep or n binders if not dep + - [PrProd] types abstracted term ([Abstract]); it accounts for one binder + - [PrCcl] types the right-hand-side + - Aliases [Alias] have no trace in [predicate_signature] +*) + +type predicate_signature = + | PrLetIn of (int * bool) * predicate_signature + | PrProd of predicate_signature + | PrCcl of constr + +(* We keep a constr for aliases and a cases_pattern for error message *) + +type alias_builder = + | AliasLeaf + | AliasConstructor of constructor + +type pattern_history = + | Top + | MakeAlias of alias_builder * pattern_continuation + +and pattern_continuation = + | Continuation of int * cases_pattern list * pattern_history + | Result of cases_pattern list + +let start_history n = Continuation (n, [], Top) + +let initial_history = function Continuation (_,[],Top) -> true | _ -> false + +let feed_history arg = function + | Continuation (n, l, h) when n>=1 -> + Continuation (n-1, arg :: l, h) + | Continuation (n, _, _) -> + anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) + | Result _ -> + anomaly "Exhausted pattern history" + +(* This is for non exhaustive error message *) + +let rec rawpattern_of_partial_history args2 = function + | Continuation (n, args1, h) -> + let args3 = make_anonymous_patvars (n - (List.length args2)) in + build_rawpattern (List.rev_append args1 (args2@args3)) h + | Result pl -> pl + +and build_rawpattern args = function + | Top -> args + | MakeAlias (AliasLeaf, rh) -> + assert (args = []); + rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh + | MakeAlias (AliasConstructor pci, rh) -> + rawpattern_of_partial_history + [PatCstr (dummy_loc, pci, args, Anonymous)] rh + +let complete_history = rawpattern_of_partial_history [] + +(* This is to build glued pattern-matching history and alias bodies *) + +let rec simplify_history = function + | Continuation (0, l, Top) -> Result (List.rev l) + | Continuation (0, l, MakeAlias (f, rh)) -> + let pargs = List.rev l in + let pat = match f with + | AliasConstructor pci -> + PatCstr (dummy_loc,pci,pargs,Anonymous) + | AliasLeaf -> + assert (l = []); + PatVar (dummy_loc, Anonymous) in + feed_history pat rh + | h -> h + +(* Builds a continuation expecting [n] arguments and building [ci] applied + to this [n] arguments *) + +let push_history_pattern n current cont = + Continuation (n, [], MakeAlias (current, cont)) + +(* A pattern-matching problem has the following form: + + env, isevars |- Cases tomatch of mat end + + where tomatch is some sequence of "instructions" (t1 ... tn) + + and mat is some matrix + (p11 ... p1n -> rhs1) + ( ... ) + (pm1 ... pmn -> rhsm) + + Terms to match: there are 3 kinds of instructions + + - "Pushed" terms to match are typed in [env]; these are usually just + Rel(n) except for the initial terms given by user and typed in [env] + - "Abstract" instructions means an abstraction has to be inserted in the + current branch to build (this means a pattern has been detected dependent + in another one and generalisation is necessary to ensure well-typing) + - "Alias" instructions means an alias has to be inserted (this alias + is usually removed at the end, except when its type is not the + same as the type of the matched term from which it comes - + typically because the inductive types are "real" parameters) + + Right-hand-sides: + + They consist of a raw term to type in an environment specific to the + clause they belong to: the names of declarations are those of the + variables present in the patterns. Therefore, they come with their + own [rhs_env] (actually it is the same as [env] except for the names + of variables). + +*) +type pattern_matching_problem = + { env : env; + isevars : evar_defs; + pred : predicate_signature option; + tomatch : tomatch_stack; + history : pattern_continuation; + mat : matrix; + caseloc : loc; + typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment } + +(*--------------------------------------------------------------------------* + * A few functions to infer the inductive type from the patterns instead of * + * checking that the patterns correspond to the ind. type of the * + * destructurated object. Allows type inference of examples like * + * [n]Cases n of O => true | _ => false end * + *--------------------------------------------------------------------------*) + +(* Computing the inductive type from the matrix of patterns *) + +let rec find_row_ind = function + [] -> None + | PatVar _ :: l -> find_row_ind l + | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) + +exception NotCoercible + +let inh_coerce_to_ind isevars env tmloc ty tyi = + let (mib,mip) = Inductive.lookup_mind_specif env tyi in + let (ntys,_) = splay_prod env (evars_of isevars) mip.mind_nf_arity in + let hole_source = match tmloc with + | Some loc -> fun i -> (loc, TomatchTypeParameter (tyi,i)) + | None -> fun _ -> (dummy_loc, InternalHole) in + let (_,evarl,_) = + List.fold_right + (fun (na,ty) (env,evl,n) -> + (push_rel (na,None,ty) env, + (new_isevar isevars env (hole_source n) ty)::evl,n+1)) + ntys (env,[],1) in + let expected_typ = applist (mkInd tyi,evarl) in + (* devrait être indifférent d'exiger leq ou pas puisque pour + un inductif cela doit être égal *) + if the_conv_x_leq env isevars expected_typ ty then ty + else raise NotCoercible + +(* We do the unification for all the rows that contain + * constructor patterns. This is what we do at the higher level of patterns. + * For nested patterns, we do this unif when we ``expand'' the matrix, and we + * use the function above. + *) + +let unify_tomatch_with_patterns isevars env tmloc typ = function + | Some (cloc,(cstr,_ as c)) -> + (let tyi = inductive_of_constructor c in + try + let indtyp = inh_coerce_to_ind isevars env tmloc typ tyi in + IsInd (typ,find_rectype env (evars_of isevars) typ) + with NotCoercible -> + (* 2 cases : Not the right inductive or not an inductive at all *) + try + IsInd (typ,find_rectype env (evars_of isevars) typ) + (* will try to coerce later in check_and_adjust_constructor.. *) + with Not_found -> + NotInd (None,typ)) + (* error will be detected in check_all_variables *) + | None -> + try IsInd (typ,find_rectype env (evars_of isevars) typ) + with Not_found -> NotInd (None,typ) + +let coerce_row typing_fun isevars env cstropt tomatch = + let j = typing_fun empty_tycon env tomatch in + let typ = body_of_type j.uj_type in + let loc = loc_of_rawconstr tomatch in + let t = unify_tomatch_with_patterns isevars env (Some loc) typ cstropt in + (j.uj_val,t) + +let coerce_to_indtype typing_fun isevars env matx tomatchl = + let pats = List.map (fun r -> r.patterns) matx in + let matx' = match matrix_transpose pats with + | [] -> List.map (fun _ -> None) tomatchl (* no patterns at all *) + | m -> List.map find_row_ind m in + List.map2 (coerce_row typing_fun isevars env) matx' tomatchl + +(************************************************************************) +(* Utils *) + + (* extract some ind from [t], possibly coercing from constructors in [tm] *) +let to_mutind env isevars tm c t = + match c with + | Some body -> NotInd (c,t) + | None -> unify_tomatch_with_patterns isevars env None t (find_row_ind tm) + +let type_of_tomatch = function + | IsInd (t,_) -> t + | NotInd (_,t) -> t + +let mkDeclTomatch na = function + | IsInd (t,_) -> (na,None,t) + | NotInd (c,t) -> (na,c,t) + +let map_tomatch_type f = function + | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind) + | NotInd (c,t) -> NotInd (option_app f c, f t) + +let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) +let lift_tomatch_type n = liftn_tomatch_type n 1 + +let lift_tomatch n ((current,typ),info) = + ((lift n current,lift_tomatch_type n typ),info) + +(**********************************************************************) +(* Utilities on patterns *) + +let current_pattern eqn = + match eqn.patterns with + | pat::_ -> pat + | [] -> anomaly "Empty list of patterns" + +let alias_of_pat = function + | PatVar (_,name) -> name + | PatCstr(_,_,_,name) -> name + +let unalias_pat = function + | PatVar (c,name) as p -> + if name = Anonymous then p else PatVar (c,Anonymous) + | PatCstr(a,b,c,name) as p -> + if name = Anonymous then p else PatCstr (a,b,c,Anonymous) + +let remove_current_pattern eqn = + match eqn.patterns with + | pat::pats -> + { eqn with + patterns = pats; + alias_stack = alias_of_pat pat :: eqn.alias_stack } + | [] -> anomaly "Empty list of patterns" + +let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } + +(**********************************************************************) +(* Dealing with regular and default patterns *) +let is_regular eqn = eqn.tag = RegularPat + +let lower_pattern_status = function + | RegularPat -> DefaultPat 0 + | DefaultPat n -> DefaultPat (n+1) + +let pattern_status pats = + if array_exists ((=) RegularPat) pats then RegularPat + else + let min = + Array.fold_right + (fun pat n -> match pat with + | DefaultPat i when i i + | _ -> n) + pats 0 in + DefaultPat min + +(**********************************************************************) +(* Well-formedness tests *) +(* Partial check on patterns *) + +exception NotAdjustable + +let rec adjust_local_defs loc = function + | (pat :: pats, (_,None,_) :: decls) -> + pat :: adjust_local_defs loc (pats,decls) + | (pats, (_,Some _,_) :: decls) -> + PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) + | [], [] -> [] + | _ -> raise NotAdjustable + +let check_and_adjust_constructor ind cstrs = function + | PatVar _ as pat -> pat + | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> + (* Check it is constructor of the right type *) + let ind' = inductive_of_constructor cstr in + if ind' = ind then + (* Check the constructor has the right number of args *) + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + if List.length args = nb_args_constr then pat + else + try + let args' = adjust_local_defs loc (args, List.rev ci.cs_args) + in PatCstr (loc, cstr, args', alias) + with NotAdjustable -> + error_wrong_numarg_constructor_loc loc cstr nb_args_constr + else + (* Try to insert a coercion *) + try + Coercion.inh_pattern_coerce_to loc pat ind' ind + with Not_found -> + error_bad_constructor_loc loc cstr ind + +let check_all_variables typ mat = + List.iter + (fun eqn -> match current_pattern eqn with + | PatVar (_,id) -> () + | PatCstr (loc,cstr_sp,_,_) -> + error_bad_pattern_loc loc cstr_sp typ) + mat + +let check_unused_pattern env eqn = + if not !(eqn.used) then + raise_pattern_matching_error + (eqn.eqn_loc, env, UnusedClause eqn.patterns) + +let set_used_pattern eqn = eqn.used := true + +let extract_rhs pb = + match pb.mat with + | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) + | eqn::_ -> + set_used_pattern eqn; + eqn.tag, eqn.rhs + +(**********************************************************************) +(* Functions to deal with matrix factorization *) + +let occur_in_rhs na rhs = + match na with + | Anonymous -> false + | Name id -> occur_rawconstr id rhs.it + +let is_dep_patt eqn = function + | PatVar (_,name) -> occur_in_rhs name eqn.rhs + | PatCstr _ -> true + +let dependencies_in_rhs nargs eqns = + if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *) + else + let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in + let columns = matrix_transpose deps in + List.map (List.exists ((=) true)) columns + +let dependent_decl a = function + | (na,None,t) -> dependent a t + | (na,Some c,t) -> dependent a t || dependent a c + +(* Computing the matrix of dependencies *) + +(* We are in context d1...dn |- and [find_dependencies k 1 nextlist] + computes for declaration [k+1] in which of declarations in + [nextlist] (which corresponds to d(k+2)...dn) it depends; + declarations are expressed by index, e.g. in dependency list + [n-2;1], [1] points to [dn] and [n-2] to [d3] *) + +let rec find_dependency_list k n = function + | [] -> [] + | (used,tdeps,d)::rest -> + let deps = find_dependency_list k (n+1) rest in + if used && dependent_decl (mkRel n) d + then list_add_set (List.length rest + 1) (list_union deps tdeps) + else deps + +let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) = + let deps = find_dependency_list k 1 nextlist in + if is_dep_or_cstr_in_rhs || deps <> [] + then (k-1,(true ,deps,d)::nextlist) + else (k-1,(false,[] ,d)::nextlist) + +let find_dependencies_signature deps_in_rhs typs = + let k = List.length deps_in_rhs in + let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in + List.map (fun (_,deps,_) -> deps) l + +(******) + +(* A Pushed term to match has just been substituted by some + constructor t = (ci x1...xn) and the terms x1 ... xn have been added to + match + + - all terms to match and to push (dependent on t by definition) + must have (Rel depth) substituted by t and Rel's>depth lifted by n + - all pushed terms to match (non dependent on t by definition) must + be lifted by n + + We start with depth=1 +*) + +let regeneralize_index_tomatch n = + let rec genrec depth = function + | [] -> [] + | Pushed ((c,tm),l)::rest -> + let c = regeneralize_index n depth c in + let tm = map_tomatch_type (regeneralize_index n depth) tm in + let l = List.map (regeneralize_rel n depth) l in + Pushed ((c,tm),l)::(genrec depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (regeneralize_index n depth) d) + ::(genrec (depth+1) rest) in + genrec 0 + +let rec replace_term n c k t = + if t = mkRel (n+k) then lift k c + else map_constr_with_binders succ (replace_term n c) k t + +let replace_tomatch n c = + let rec replrec depth = function + | [] -> [] + | Pushed ((b,tm),l)::rest -> + let b = replace_term n c depth b in + let tm = map_tomatch_type (replace_term n c depth) tm in + List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l; + Pushed ((b,tm),l)::(replrec depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (replace_term n c depth) d) + ::(replrec (depth+1) rest) in + replrec 0 + +let liftn_rel_declaration n k = map_rel_declaration (liftn n k) +let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k) + +let rec liftn_tomatch_stack n depth = function + | [] -> [] + | Pushed ((c,tm),l)::rest -> + let c = liftn n depth c in + let tm = liftn_tomatch_type n depth tm in + let l = List.map (fun i -> if i + Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t) + ::(liftn_tomatch_stack n depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (liftn n depth) d) + ::(liftn_tomatch_stack n (depth+1) rest) + + +let lift_tomatch_stack n = liftn_tomatch_stack n 1 + +(* if [current] has type [I(p1...pn u1...um)] and we consider the case + of constructor [ci] of type [I(p1...pn u'1...u'm)], then the + default variable [name] is expected to have which type? + Rem: [current] is [(Rel i)] except perhaps for initial terms to match *) + +(************************************************************************) +(* Some heuristics to get names for variables pushed in pb environment *) +(* Typical requirement: + + [Cases y of (S (S x)) => x | x => x end] should be compiled into + [Cases y of O => y | (S n) => Cases n of O => y | (S x) => x end end] + + and [Cases y of (S (S n)) => n | n => n end] into + [Cases y of O => y | (S n0) => Cases n0 of O => y | (S n) => n end end] + + i.e. user names should be preserved and created names should not + interfere with user names *) + +let merge_name get_name obj = function + | Anonymous -> get_name obj + | na -> na + +let merge_names get_name = List.map2 (merge_name get_name) + +let get_names env sign eqns = + let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in + (* If any, we prefer names used in pats, from top to bottom *) + let names2 = + List.fold_right + (fun (pats,eqn) names -> merge_names alias_of_pat pats names) + eqns names1 in + (* Otherwise, we take names from the parameters of the constructor but + avoiding conflicts with user ids *) + let allvars = + List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.other_ids) [] eqns in + let names4,_ = + List.fold_left2 + (fun (l,avoid) d na -> + let na = + merge_name + (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) + d na + in + (na::l,(out_name na)::avoid)) + ([],allvars) (List.rev sign) names2 in + names4 + +(************************************************************************) +(* Recovering names for variables pushed to the rhs' environment *) + +let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) + +let push_rels_eqn sign eqn = + {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env} } + +let push_rels_eqn_with_names sign eqn = + let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in + let sign = recover_alias_names alias_of_pat pats sign in + push_rels_eqn sign eqn + +let build_aliases_context env sigma names allpats pats = + (* pats is the list of bodies to push as an alias *) + (* They all are defined in env and we turn them into a sign *) + (* cuts in sign need to be done in allpats *) + let rec insert env sign1 sign2 n newallpats oldallpats = function + | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) -> + (* Anonymous leaves must be considered named and treated in the *) + (* next clause because they may occur in implicit arguments *) + insert env sign1 sign2 + n newallpats (List.map List.tl oldallpats) (pats,names) + | (deppat,nondeppat,d,t)::pats, na::names -> + let nondeppat = lift n nondeppat in + let deppat = lift n deppat in + let newallpats = + List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in + let oldallpats = List.map List.tl oldallpats in + let u = Retyping.get_type_of env sigma deppat in + let decl = (na,Some deppat,t) in + let a = (deppat,nondeppat,d,t) in + insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) + newallpats oldallpats (pats,names) + | [], [] -> newallpats, sign1, sign2, env + | _ -> anomaly "Inconsistent alias and name lists" in + let allpats = List.map (fun x -> [x]) allpats + in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names) + +let insert_aliases_eqn sign eqnnames alias_rest eqn = + let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in + { eqn with + alias_stack = alias_rest; + rhs = {eqn.rhs with rhs_env = push_rels thissign eqn.rhs.rhs_env } } + +let insert_aliases env sigma alias eqns = + (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *) + (* défaut présent mais inutile, ce qui est le cas général, l'alias *) + (* est introduit même s'il n'est pas utilisé dans les cas réguliers *) + let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in + let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in + (* names2 takes the meet of all needed aliases *) + let names2 = + List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in + (* Only needed aliases are kept by build_aliases_context *) + let eqnsnames, sign1, sign2, env = + build_aliases_context env sigma [names2] eqnsnames [alias] in + let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in + sign2, env, eqns + +(**********************************************************************) +(* Functions to deal with elimination predicate *) + +exception Occur +let noccur_between_without_evar n m term = + let rec occur_rec n c = match kind_of_term c with + | Rel p -> if n<=p && p () + | _ -> iter_constr_with_binders succ occur_rec n c + in + try occur_rec n term; true with Occur -> false + +(* Infering the predicate *) +let prepare_unif_pb typ cs = + let n = List.length (assums_of_rel_context cs.cs_args) in + + (* We may need to invert ci if its parameters occur in typ *) + let typ' = + if noccur_between_without_evar 1 n typ then lift (-n) typ + else (* TODO4-1 *) + error "Inference of annotation not yet implemented in this case" in + let args = extended_rel_list (-n) cs.cs_args in + let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in + + (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *) + (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ') + + +(* Infering the predicate *) +(* +The problem to solve is the following: + +We match Gamma |- t : I(u01..u0q) against the following constructors: + + Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q) + ... + Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq) + +Assume the types in the branches are the following + + Gamma, x11...x1p1 |- branch1 : T1 + ... + Gamma, xn1...xnpn |- branchn : Tn + +Assume the type of the global case expression is Gamma |- T + +The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy +the following n+1 equations: + + Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1 + ... + Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn + Gamma |- (phi u01..u0q t) = T + +Some hints: + +- Clearly, if xij occurs in Ti, then, a "Cases z of (Ci xi1..xipi) => ..." + should be inserted somewhere in Ti. + +- If T is undefined, an easy solution is to insert a "Cases z of (Ci + xi1..xipi) => ..." in front of each Ti + +- Otherwise, T1..Tn and T must be step by step unified, if some of them + diverge, then try to replace the diverging subterm by one of y1..yq or z. + +- The main problem is what to do when an existential variables is encountered + +let prepare_unif_pb typ cs = + let n = cs.cs_nargs in + let _,p = decompose_prod_n n typ in + let ci = build_dependent_constructor cs in + (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *) + (n, cs.cs_concl_realargs, ci, p) + +let eq_operator_lift k (n,n') = function + | OpRel p, OpRel p' when p > k & p' > k -> + if p < k+n or p' < k+n' then false else p - n = p' - n' + | op, op' -> op = op' + +let rec transpose_args n = + if n=0 then [] + else + (Array.map (fun l -> List.hd l) lv):: + (transpose_args (m-1) (Array.init (fun l -> List.tl l))) + +let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k + +let reloc_operator (k,n) = function OpRel p when p > k -> +let rec unify_clauses k pv = + let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (evars_of isevars)) p) pv in + let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in + if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv' + then + let argvl = transpose_args (List.length args1) pv' in + let k' = shift_operator k op1 in + let argl = List.map (unify_clauses k') argvl in + gather_constr (reloc_operator (k,n1) op1) argl +*) + +let abstract_conclusion typ cs = + let n = List.length (assums_of_rel_context cs.cs_args) in + let (sign,p) = decompose_prod_n n typ in + lam_it p sign + +let infer_predicate loc env isevars typs cstrs indf = + let (mis,_) = dest_ind_family indf in + (* Il faudra substituer les isevars a un certain moment *) + if Array.length cstrs = 0 then (* "TODO4-3" *) + error "Inference of annotation for empty inductive types not implemented" + else + (* Empiric normalization: p may depend in a irrelevant way on args of the*) + (* cstr as in [c:{_:Alpha & Beta}] Cases c of (existS a b)=>(a,b) end *) + let typs = + Array.map (local_strong (whd_betaevar empty_env (evars_of isevars))) typs + in + let eqns = array_map2 prepare_unif_pb typs cstrs in + (* First strategy: no dependencies at all *) +(* let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in*) + let (sign,_) = get_arity env indf in + let mtyp = + if array_exists is_Type typs then + (* Heuristic to avoid comparison between non-variables algebric univs*) + new_Type () + else + mkExistential isevars env (loc, CasesType) + in + if array_for_all (fun (_,_,typ) -> the_conv_x_leq env isevars typ mtyp) eqns + then + (* Non dependent case -> turn it into a (dummy) dependent one *) + let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in + let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in + (true,pred) (* true = dependent -- par défaut *) + else +(* + let s = get_sort_of env (evars_of isevars) typs.(0) in + let predpred = it_mkLambda_or_LetIn (mkSort s) sign in + let caseinfo = make_default_case_info mis in + let brs = array_map2 abstract_conclusion typs cstrs in + let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in + let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in +*) + (* "TODO4-2" *) + (* We skip parameters *) + let cis = + Array.map + (fun cs -> + applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) + cstrs in + let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in + raise_pattern_matching_error (loc,env, CannotInferPredicate ct) +(* + (true,pred) +*) + +(* Propagation of user-provided predicate through compilation steps *) + +let rec map_predicate f k = function + | PrCcl ccl -> PrCcl (f k ccl) + | PrProd pred -> + PrProd (map_predicate f (k+1) pred) + | PrLetIn ((nargs,dep as tm),pred) -> + let k' = nargs + (if dep then 1 else 0) in + PrLetIn (tm, map_predicate f (k+k') pred) + +let liftn_predicate n = map_predicate (liftn n) + +let lift_predicate n = liftn_predicate n 1 + +let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0 + +let substnl_predicate sigma = map_predicate (substnl sigma) + +(* This is parallel bindings *) +let subst_predicate (args,copt) pred = + let sigma = match copt with + | None -> List.rev args + | Some c -> c::(List.rev args) in + substnl_predicate sigma 0 pred + +let specialize_predicate_var (cur,typ) = function + | PrProd _ | PrCcl _ -> + anomaly "specialize_predicate_var: a pattern-variable must be pushed" + | PrLetIn ((0,dep),pred) -> + subst_predicate ([],if dep then Some cur else None) pred + | PrLetIn ((_,dep),pred) -> + (match typ with + | IsInd (_,IndType (_,realargs)) -> + subst_predicate (realargs,if dep then Some cur else None) pred + | _ -> anomaly "specialize_predicate_var") + +let ungeneralize_predicate = function + | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product" + | PrProd pred -> pred + +(*****************************************************************************) +(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *) +(* and we want to abstract P over y:t(x) typed in the same context to get *) +(* *) +(* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *) +(* *) +(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) +(* then we have to replace x by x' in t(x) and y by y' in P *) +(*****************************************************************************) +let generalize_predicate c ny d = function + | PrLetIn ((nargs,dep as tm),pred) -> + if not dep then anomaly "Undetected dependency"; + let p = nargs + 1 in + let pred = lift_predicate 1 pred in + let pred = regeneralize_index_predicate (ny+p+1) pred in + PrLetIn (tm, PrProd pred) + | PrProd _ | PrCcl _ -> + anomaly "generalize_predicate: expects a non trivial pattern" + +let rec extract_predicate l = function + | pred, Alias (deppat,nondeppat,_,_)::tms -> + let tms' = match kind_of_term nondeppat with + | Rel i -> replace_tomatch i deppat tms + | _ -> (* initial terms are not dependent *) tms in + extract_predicate l (pred,tms') + | PrProd pred, Abstract d'::tms -> + let d' = map_rel_declaration (lift (List.length l)) d' in + substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms))) + | PrLetIn ((0,dep),pred), Pushed ((cur,_),_)::tms -> + extract_predicate (if dep then cur::l else l) (pred,tms) + | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms -> + let l = List.rev realargs@l in + extract_predicate (if dep then cur::l else l) (pred,tms) + | PrCcl ccl, [] -> + substl l ccl + | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match" + +let abstract_predicate env sigma indf cur tms = function + | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn" + | PrLetIn ((nrealargs,dep),pred) -> + let sign = make_arity_signature env true indf in + (* n is the number of real args + 1 *) + let n = List.length sign in + let tms = lift_tomatch_stack n tms in + let tms = + match kind_of_term cur with + | Rel i -> regeneralize_index_tomatch (i+n) tms + | _ -> (* Initial case *) tms in + (* Depending on whether the predicate is dependent or not, and has real + args or not, we lift it to make room for [sign] *) + (* Even if not intrinsically dep, we move the predicate into a dep one *) + let k = + if nrealargs = 0 & n <> 1 then + (* Real args were not considered *) if dep then n-1 else n + else + (* Real args are OK *) if dep then 0 else 1 in + let pred = lift_predicate k pred in + let pred = extract_predicate [] (pred,tms) in + (true, it_mkLambda_or_LetIn_name env pred sign) + +let rec known_dependent = function + | None -> false + | Some (PrLetIn ((_,dep),_)) -> dep + | Some (PrCcl _) -> false + | Some (PrProd _) -> + anomaly "known_dependent: can only be used when patterns remain" + +(* [expand_arg] is used by [specialize_predicate] + it replaces gamma, x1...xn, x1...xk |- pred + by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or + by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *) + +let expand_arg n alreadydep (na,t) deps (k,pred) = + (* current can occur in pred even if the original problem is not dependent *) + let dep = deps <> [] || alreadydep in + let pred = if dep then pred else lift_predicate (-1) pred in + (* There is no dependency in realargs for subpattern *) + (k-1, PrLetIn ((0,dep), pred)) + + +(*****************************************************************************) +(* pred = [X:=realargs;x:=c]P types the following problem: *) +(* *) +(* Gamma |- Cases Pushed(c:I(realargs)) rest of...end: pred *) +(* *) +(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) +(* is considered. Assume each Ti is some Ii(argsi). *) +(* We let e=Ci(x1,...,xn) and replace pred by *) +(* *) +(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *) +(* *) +(* s.t Gamma,x1'..xn' |- Cases Pushed(x1')..Pushed(xn') rest of...end: pred' *) +(* *) +(*****************************************************************************) +let specialize_predicate tomatchs deps cs = function + | (PrProd _ | PrCcl _) -> + anomaly "specialize_predicate: a matched pattern must be pushed" + | PrLetIn ((nrealargs,isdep),pred) -> + (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *) + let k = nrealargs + (if isdep then 1 else 0) in + (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *) + let n = cs.cs_nargs in + let pred' = liftn_predicate n (k+1) pred in + let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in + let copti = if isdep then Some (build_dependent_constructor cs) else None in + (* The substituends argsi, copti are all defined in gamma, x1...xn *) + (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *) + let pred'' = subst_predicate (argsi, copti) pred' in + (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *) + let pred''' = liftn_predicate n (n+1) pred'' in + (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*) + snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred''')) + +let find_predicate loc env isevars p typs cstrs current + (IndType (indf,realargs)) tms = + let (dep,pred) = + match p with + | Some p -> abstract_predicate env (evars_of isevars) indf current tms p + | None -> infer_predicate loc env isevars typs cstrs indf in + let typ = whd_beta (applist (pred, realargs)) in + if dep then + (pred, whd_beta (applist (typ, [current])), new_Type ()) + else + (pred, typ, new_Type ()) + +(************************************************************************) +(* Sorting equations by constructor *) + +type inversion_problem = + (* the discriminating arg in some Ind and its order in Ind *) + | Incompatible of int * (int * int) + | Constraints of (int * constr) list + +let solve_constraints constr_info indt = + (* TODO *) + Constraints [] + +let rec irrefutable env = function + | PatVar (_,name) -> true + | PatCstr (_,cstr,args,_) -> + let ind = inductive_of_constructor cstr in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let one_constr = Array.length mip.mind_user_lc = 1 in + one_constr & List.for_all (irrefutable env) args + +let first_clause_irrefutable env = function + | eqn::mat -> List.for_all (irrefutable env) eqn.patterns + | _ -> false + +let group_equations pb mind current cstrs mat = + let mat = + if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in + let brs = Array.create (Array.length cstrs) [] in + let only_default = ref true in + let _ = + List.fold_right (* To be sure it's from bottom to top *) + (fun eqn () -> + let rest = remove_current_pattern eqn in + let pat = current_pattern eqn in + match check_and_adjust_constructor mind cstrs pat with + | PatVar (_,name) -> + (* This is a default clause that we expand *) + for i=1 to Array.length cstrs do + let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in + let rest = {rest with tag = lower_pattern_status rest.tag} in + brs.(i-1) <- (args, rest) :: brs.(i-1) + done + | PatCstr (loc,((_,i) as cstr),args,_) as pat -> + (* This is a regular clause *) + only_default := false; + brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in + (brs,!only_default) + +(************************************************************************) +(* Here starts the pattern-matching compilation algorithm *) + +(* Abstracting over dependent subterms to match *) +let rec generalize_problem pb current = function + | [] -> pb + | i::l -> + let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in + let pb' = generalize_problem pb current l in + let tomatch = lift_tomatch_stack 1 pb'.tomatch in + let tomatch = regeneralize_index_tomatch (i+1) tomatch in + { pb with + tomatch = Abstract d :: tomatch; + pred = option_app (generalize_predicate current i d) pb'.pred } + +(* No more patterns: typing the right-hand-side of equations *) +let build_leaf pb = + let tag, rhs = extract_rhs pb in + let tycon = match pb.pred with + | None -> empty_tycon + | Some (PrCcl typ) -> mk_tycon typ + | Some _ -> anomaly "not all parameters of pred have been consumed" in + tag, pb.typing_function tycon rhs.rhs_env rhs.it + +(* Building the sub-problem when all patterns are variables *) +let shift_problem (current,t) pb = + {pb with + tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch; + pred = option_app (specialize_predicate_var (current,t)) pb.pred; + history = push_history_pattern 0 AliasLeaf pb.history; + mat = List.map remove_current_pattern pb.mat } + +(* Building the sub-pattern-matching problem for a given branch *) +let build_branch current deps pb eqns const_info = + (* We remember that we descend through a constructor *) + let alias_type = + if Array.length const_info.cs_concl_realargs = 0 + & not (known_dependent pb.pred) & deps = [] + then + NonDepAlias + else + DepAlias + in + let partialci = + applist (mkConstruct const_info.cs_cstr, const_info.cs_params) in + let history = + push_history_pattern const_info.cs_nargs + (AliasConstructor const_info.cs_cstr) + pb.history in + + (* We find matching clauses *) + let cs_args = (*assums_of_rel_context*) const_info.cs_args in + let names = get_names pb.env cs_args eqns in + let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in + if submat = [] then + raise_pattern_matching_error + (dummy_loc, pb.env, NonExhaustive (complete_history history)); + let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in + let _,typs',_ = + List.fold_right + (fun (na,c,t as d) (env,typs,tms) -> + let tm1 = List.map List.hd tms in + let tms = List.map List.tl tms in + (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms)) + typs (pb.env,[],List.map fst eqns) in + + let dep_sign = + find_dependencies_signature + (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in + + (* The dependent term to subst in the types of the remaining UnPushed + terms is relative to the current context enriched by topushs *) + let ci = build_dependent_constructor const_info in + + (* We replace [(mkRel 1)] by its expansion [ci] *) + (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *) + (* This is done in two steps : first from "Gamma |- tms" *) + (* into "Gamma; typs; curalias |- tms" *) + let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in + + let currents = + list_map2_i + (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps)) + 1 typs' (List.rev dep_sign) in + + let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in + + let ind = + appvect ( + applist (mkInd (inductive_of_constructor const_info.cs_cstr), + List.map (lift const_info.cs_nargs) const_info.cs_params), + const_info.cs_concl_realargs) in + + let cur_alias = lift (List.length sign) current in + let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in + + sign, + { pb with + env = push_rels sign pb.env; + tomatch = List.rev_append currents tomatch; + pred = option_app (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred; + history = history; + mat = List.map (push_rels_eqn_with_names sign) submat } + +(********************************************************************** + INVARIANT: + + pb = { env, subst, tomatch, mat, ...} + tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T) + + "Pushed" terms and types are relative to env + "Abstract" types are relative to env enriched by the previous terms to match + + Concretely, each term "c" or type "T" comes with a delayed lift + index, but it works as if the lifting were effective. + +*) + +(**********************************************************************) +(* Main compiling descent *) +let rec compile pb = + match pb.tomatch with + | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur + | (Alias x)::rest -> compile_alias pb x rest + | (Abstract d)::rest -> compile_generalization pb d rest + | [] -> build_leaf pb + +and match_current pb ((current,typ as ct),deps) = + let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in + let (_,c,t) = mkDeclTomatch Anonymous typ in + let typ = to_mutind pb.env pb.isevars tm1 c t in + match typ with + | NotInd (_,typ) -> + check_all_variables typ pb.mat; + compile (shift_problem ct pb) + | IsInd (_,(IndType(indf,realargs) as indt)) -> + let mind,_ = dest_ind_family indf in + let cstrs = get_constructors pb.env indf in + let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + if (cstrs <> [||] or not (initial_history pb.history)) & onlydflt then + compile (shift_problem ct pb) + else + let constraints = Array.map (solve_constraints indt) cstrs in + + (* We generalize over terms depending on current term to match *) + let pb = generalize_problem pb current deps in + + (* We compile branches *) + let brs = array_map2 (compile_branch current deps pb) eqns cstrs in + + (* We build the (elementary) case analysis *) + let tags = Array.map (fun (t,_,_) -> t) brs in + let brvals = Array.map (fun (_,v,_) -> v) brs in + let brtyps = Array.map (fun (_,_,t) -> t) brs in + let (pred,typ,s) = + find_predicate pb.caseloc pb.env pb.isevars + pb.pred brtyps cstrs current indt pb.tomatch in + let ci = make_case_info pb.env mind RegularStyle tags in + let case = mkCase (ci,nf_betaiota pred,current,brvals) in + let inst = List.map mkRel deps in + pattern_status tags, + { uj_val = applist (case, inst); + uj_type = substl inst typ } + +and compile_branch current deps pb eqn cstr = + let sign, pb = build_branch current deps pb eqn cstr in + let tag, j = compile pb in + (tag, it_mkLambda_or_LetIn j.uj_val sign, j.uj_type) + +and compile_generalization pb d rest = + let pb = + { pb with + env = push_rel d pb.env; + tomatch = rest; + pred = option_app ungeneralize_predicate pb.pred; + mat = List.map (push_rels_eqn [d]) pb.mat } in + let patstat,j = compile pb in + patstat, + { uj_val = mkLambda_or_LetIn d j.uj_val; + uj_type = mkProd_or_LetIn d j.uj_type } + +and compile_alias pb (deppat,nondeppat,d,t) rest = + let history = simplify_history pb.history in + let sign, newenv, mat = + insert_aliases pb.env (evars_of pb.isevars) (deppat,nondeppat,d,t) pb.mat in + let n = List.length sign in + + (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *) + (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *) + let tomatch = lift_tomatch_stack n rest in + let tomatch = match kind_of_term nondeppat with + | Rel i -> + if n = 1 then regeneralize_index_tomatch (i+n) tomatch + else replace_tomatch i deppat tomatch + | _ -> (* initial terms are not dependent *) tomatch in + + let pb = + {pb with + env = newenv; + tomatch = tomatch; + pred = option_app (lift_predicate n) pb.pred; + history = history; + mat = mat } in + let patstat,j = compile pb in + patstat, + List.fold_left mkSpecialLetInJudge j sign + +(* pour les alias des initiaux, enrichir les env de ce qu'il faut et +substituer après par les initiaux *) + +(**************************************************************************) +(* Preparation of the pattern-matching problem *) + +(* Qu'est-ce qui faut pas faire pour traiter les alias ... *) + +(* On ne veut pas ajouter de primitive à Environ et le problème, c'est + donc de faire un renommage en se contraignant à parcourir l'env + dans le sens croissant. Ici, subst renomme des variables repérées + par leur numéro et seen_ids collecte celles dont on sait que les + variables de subst annule le scope *) +let rename_env subst env = + let n = ref (rel_context_length (rel_context env)) in + let seen_ids = ref [] in + process_rel_context + (fun (na,c,t as d) env -> + let d = + try + let id = List.assoc !n subst in + seen_ids := id :: !seen_ids; + (Name id,c,t) + with Not_found -> + match na with + | Name id when List.mem id !seen_ids -> (Anonymous,c,t) + | _ -> d in + decr n; + push_rel d env) env + +let is_dependent_indtype = function + | NotInd _ -> false + | IsInd (_, IndType(_,realargs)) -> List.length realargs <> 0 + +let prepare_initial_alias_eqn isdep tomatchl eqn = + let (subst, pats) = + List.fold_right2 + (fun pat (tm,tmtyp) (subst, stripped_pats) -> + match alias_of_pat pat with + | Anonymous -> (subst, pat::stripped_pats) + | Name idpat as na -> + match kind_of_term tm with + | Rel n when not (is_dependent_indtype tmtyp) & not isdep + -> (n, idpat)::subst, (unalias_pat pat::stripped_pats) + | _ -> (subst, pat::stripped_pats)) + eqn.patterns tomatchl ([], []) in + let env = rename_env subst eqn.rhs.rhs_env in + { eqn with patterns = pats; rhs = { eqn.rhs with rhs_env = env } } + +let prepare_initial_aliases isdep tomatchl mat = mat +(* List.map (prepare_initial_alias_eqn isdep tomatchl) mat*) + +(* +let prepare_initial_alias lpat tomatchl rhs = + List.fold_right2 + (fun pat tm (stripped_pats, rhs) -> + match alias_of_pat pat with + | Anonymous -> (pat::stripped_pats, rhs) + | Name _ as na -> + match tm with + | RVar _ -> + (unalias_pat pat::stripped_pats, + RLetIn (dummy_loc, na, tm, rhs)) + | _ -> (pat::stripped_pats, rhs)) + lpat tomatchl ([], rhs) +*) +(* builds the matrix of equations testing that each eqn has n patterns + * and linearizing the _ patterns. + * Syntactic correctness has already been done in astterm *) +let matx_of_eqns env tomatchl eqns = + let build_eqn (loc,ids,lpat,rhs) = +(* let initial_lpat,initial_rhs = prepare_initial_alias lpat tomatchl rhs in*) + let initial_lpat,initial_rhs = lpat,rhs in + let initial_rhs = rhs in + let rhs = + { rhs_env = env; + other_ids = ids@(ids_of_named_context (named_context env)); + user_ids = ids; + rhs_lift = 0; + it = initial_rhs } in + { dependencies = []; + patterns = initial_lpat; + tag = RegularPat; + alias_stack = []; + eqn_loc = loc; + used = ref false; + rhs = rhs } + in List.map build_eqn eqns + +(************************************************************************) +(* preparing the elimination predicate if any *) + +let build_expected_arity env isevars isdep tomatchl = + let cook n = function + | _,IsInd (_,IndType(indf,_)) -> + let indf' = lift_inductive_family n indf in + Some (build_dependent_inductive env indf', fst (get_arity env indf')) + | _,NotInd _ -> None + in + let rec buildrec n env = function + | [] -> new_Type () + | tm::ltm -> + match cook n tm with + | None -> buildrec n env ltm + | Some (ty1,aritysign) -> + let rec follow n env = function + | d::sign -> + mkProd_or_LetIn_name env + (follow (n+1) (push_rel d env) sign) d + | [] -> + if isdep then + mkProd (Anonymous, ty1, + buildrec (n+1) + (push_rel_assum (Anonymous, ty1) env) + ltm) + else buildrec n env ltm + in follow n env (List.rev aritysign) + in buildrec 0 env tomatchl + +let extract_predicate_conclusion isdep tomatchl pred = + let cook = function + | _,IsInd (_,IndType(_,args)) -> Some (List.length args) + | _,NotInd _ -> None in + let decomp_lam_force p = + match kind_of_term p with + | Lambda (_,_,c) -> c + | _ -> (* eta-expansion *) applist (lift 1 p, [mkRel 1]) in + let rec buildrec p = function + | [] -> p + | tm::ltm -> + match cook tm with + | None -> + let p = + (* adjust to a sign containing the NotInd's *) + if isdep then lift 1 p else p in + buildrec p ltm + | Some n -> + let n = if isdep then n+1 else n in + let p = iterate decomp_lam_force n p in + buildrec p ltm + in buildrec pred tomatchl + +let set_arity_signature dep n arsign tomatchl pred x = + (* avoid is not exhaustive ! *) + let rec decomp_lam_force n avoid l p = + if n = 0 then (List.rev l,p,avoid) else + match p with + | RLambda (_,(Name id as na),_,c) -> + decomp_lam_force (n-1) (id::avoid) (na::l) c + | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c + | _ -> + let x = next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (let a = RVar (dummy_loc,x) in + match p with + | RApp (loc,p,l) -> RApp (loc,p,l@[a]) + | _ -> (RApp (dummy_loc,p,[a]))) in + let rec decomp_block avoid p = function + | ([], _) -> x := Some p + | ((_,IsInd (_,IndType(indf,realargs)))::l),(y::l') -> + let (ind,params) = dest_ind_family indf in + let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p + in + let na,p,avoid' = + if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid' + in + y := + (List.hd na, + if List.for_all ((=) Anonymous) nal then + None + else + Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal)); + decomp_block avoid' p (l,l') + | (_::l),(y::l') -> + y := (Anonymous,None); + decomp_block avoid p (l,l') + | _ -> anomaly "set_arity_signature" + in + decomp_block [] pred (tomatchl,arsign) + +let prepare_predicate_from_tycon loc dep env isevars tomatchs c = + let cook (n, l, env) = function + | c,IsInd (_,IndType(indf,realargs)) -> + let indf' = lift_inductive_family n indf in + let sign = make_arity_signature env dep indf' in + let p = List.length realargs in + if dep then + (n + p + 1, c::(List.rev realargs)@l, push_rels sign env) + else + (n + p, (List.rev realargs)@l, push_rels sign env) + | c,NotInd _ -> + (n, l, env) in + let n, allargs, env = List.fold_left cook (0, [], env) tomatchs in + let allargs = + List.map (fun c -> lift n (nf_betadeltaiota env (evars_of isevars) c)) allargs in + let rec build_skeleton env c = + (* Don't put into normal form, it has effects on the synthesis of evars *) + (* let c = whd_betadeltaiota env (evars_of isevars) c in *) + (* We turn all subterms possibly dependent into an evar with maximum ctxt*) + if isEvar c or List.exists (eq_constr c) allargs then + mkExistential isevars env (loc, CasesType) + else + map_constr_with_full_binders push_rel build_skeleton env c in + build_skeleton env (lift n c) + +(* Here, [pred] is assumed to be in the context built from all *) +(* realargs and terms to match *) +let build_initial_predicate isdep pred tomatchl = + let nar = List.fold_left (fun n (_,t) -> + let p = match t with IsInd (_,IndType(_,a)) -> List.length a | _ -> 0 in + if isdep then n+p+1 else n+p) 0 tomatchl in + let cook = function + | _,IsInd (_,IndType(_,realargs)) -> List.length realargs + | _,NotInd _ -> 0 in + let rec buildrec n pred = function + | [] -> PrCcl pred + | tm::ltm -> + let nrealargs = cook tm in + let pred, p, user_p = + if isdep then + if dependent (mkRel (nar-n)) pred then pred, 1, 1 + else liftn (-1) (nar-n) pred, 0, 1 + else pred, 0, 0 in + PrLetIn ((nrealargs,p=1), buildrec (n+nrealargs+user_p) pred ltm) + in buildrec 0 pred tomatchl + +let extract_arity_signature env0 tomatchl tmsign = + let get_one_sign n tm {contents = (na,t)} = + match tm with + | NotInd (bo,typ) -> + (match t with + | None -> [na,option_app (lift n) bo,lift n typ] + | Some (loc,_,_) -> + user_err_loc (loc,"", + str "Unexpected type annotation for a term of non inductive type")) + | IsInd (_,IndType(indf,realargs)) -> + let indf' = lift_inductive_family n indf in + let (ind,params) = dest_ind_family indf' in + let nrealargs = List.length realargs in + let realnal = + match t with + | Some (loc,ind',nal) -> + let nparams = List.length params in + if ind <> ind' then + user_err_loc (loc,"",str "Wrong inductive type"); + if List.length nal <> nparams + nrealargs then + user_err_loc (loc,"", + str "Wrong number of arguments for inductive type"); + let parnal,realnal = list_chop nparams nal in + if List.exists ((<>) Anonymous) parnal then + user_err_loc (loc,"", + str "The parameters of inductive type must be implicit"); + List.rev realnal + | None -> list_tabulate (fun _ -> Anonymous) nrealargs in + let arsign = fst (get_arity env0 indf') in + (na,None,build_dependent_inductive env0 indf') + ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in + let rec buildrec n = function + | [],[] -> [] + | (_,tm)::ltm, x::tmsign -> + let l = get_one_sign n tm x in + (buildrec (n + List.length l) (ltm,tmsign)) @ l + | _ -> assert false + in buildrec 0 (tomatchl,tmsign) + +(* Builds the predicate. If the predicate is dependent, its context is + * made of 1+nrealargs assumptions for each matched term in an inductive + * type and 1 assumption for each term not _syntactically_ in an + * inductive type. + + * V7 case: determines whether the multiple case is dependent or not + * - if its arity is made of nrealargs assumptions for each matched + * term in an inductive type and nothing for terms not _syntactically_ + * in an inductive type, then it is non dependent + * - if its arity is made of 1+nrealargs assumptions for each matched + * term in an inductive type and nothing for terms not _syntactically_ + * in an inductive type, then it is dependent and needs an adjustement + * to fulfill the criterion above that terms not in an inductive type + * counts for 1 in the dependent case + + * V8 case: each matched terms are independently considered dependent + * or not + + * A type constraint but no annotation case: it is assumed non dependent + *) + +let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function + (* No type annotation at all *) + | (None,{contents = None}) -> + (match tycon with + | None -> None + | Some t -> + let pred = prepare_predicate_from_tycon loc false env isevars tomatchs t in + Some (build_initial_predicate false pred tomatchs)) + + (* v8 style type annotation *) + | (None,{contents = Some rtntyp}) -> + + (* We extract the signature of the arity *) + let arsign = extract_arity_signature env tomatchs sign in + let env = push_rels arsign env in + let predccl = (typing_fun (mk_tycon (new_Type ())) env rtntyp).uj_val in + Some (build_initial_predicate true predccl tomatchs) + + (* v7 style type annotation; set the v8 annotation by side effect *) + | (Some pred,x) -> + let loc = loc_of_rawconstr pred in + let dep, n, predj = + let isevars_copy = evars_of isevars in + (* We first assume the predicate is non dependent *) + let ndep_arity = build_expected_arity env isevars false tomatchs in + try + false, nb_prod ndep_arity, typing_fun (mk_tycon ndep_arity) env pred + with PretypeError _ | TypeError _ | + Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) -> + evars_reset_evd isevars_copy isevars; + (* We then assume the predicate is dependent *) + let dep_arity = build_expected_arity env isevars true tomatchs in + try + true, nb_prod dep_arity, typing_fun (mk_tycon dep_arity) env pred + with PretypeError _ | TypeError _ | + Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) -> + evars_reset_evd isevars_copy isevars; + (* Otherwise we attempt to type it without constraints, possibly *) + (* failing with an error message; it may also be well-typed *) + (* but fails to satisfy arity constraints in case_dependent *) + let predj = typing_fun empty_tycon env pred in + error_wrong_predicate_arity_loc + loc env predj.uj_val ndep_arity dep_arity + in + let predccl = extract_predicate_conclusion dep tomatchs predj.uj_val in +(* + let etapred,cdep = case_dependent env (evars_of isevars) loc predj tomatchs in +*) + set_arity_signature dep n sign tomatchs pred x; + Some (build_initial_predicate dep predccl tomatchs) + + +(**************************************************************************) +(* Main entry of the matching compilation *) + +let compile_cases loc (typing_fun,isevars) tycon env (predopt, tomatchl, eqns)= + + (* We build the matrix of patterns and right-hand-side *) + let matx = matx_of_eqns env tomatchl eqns in + + (* We build the vector of terms to match consistently with the *) + (* constructors found in patterns *) + let rawtms, tmsign = List.split tomatchl in + let tomatchs = coerce_to_indtype typing_fun isevars env matx rawtms in + + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let pred = prepare_predicate loc typing_fun isevars env tomatchs tmsign tycon predopt in + + (* We deal with initial aliases *) + let matx = prepare_initial_aliases (known_dependent pred) tomatchs matx in + + (* We push the initial terms to match and push their alias to rhs' envs *) + (* names of aliases will be recovered from patterns (hence Anonymous here) *) + let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in + + let pb = + { env = env; + isevars = isevars; + pred = pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + typing_function = typing_fun } in + + let _, j = compile pb in + + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + + match tycon with + | Some p -> Coercion.inh_conv_coerce_to loc env isevars j p + | None -> j diff --git a/pretyping/cases.mli b/pretyping/cases.mli new file mode 100644 index 00000000..1d2f9025 --- /dev/null +++ b/pretyping/cases.mli @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_defs -> bool -> inductive_family -> constr array + +type ml_case_error = + | MlCaseAbsurd + | MlCaseDependent + +exception NotInferable of ml_case_error + +val pred_case_ml : (* raises [NotInferable] if not inferable *) + env -> evar_map -> bool -> inductive_type -> int * types -> constr + +(*s Compilation of pattern-matching. *) + +val compile_cases : + loc -> (type_constraint -> env -> rawconstr -> unsafe_judgment) + * evar_defs -> type_constraint -> env -> + (rawconstr option * rawconstr option ref) * + (rawconstr * (name * (loc * inductive * name list) option) ref) list * + (loc * identifier list * cases_pattern list * rawconstr) list -> + unsafe_judgment diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml new file mode 100644 index 00000000..88f59ded --- /dev/null +++ b/pretyping/cbv.ml @@ -0,0 +1,352 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [S.c]b + * This corresponds to the usual strategy of weak reduction + * FIXP(op,bd,S,args) is the fixpoint (Fix or Cofix) of bodies bd under + * the bindings S, and then applied to args. Here again, + * weak reduction. + * CONSTR(c,args) is the constructor [c] applied to [args]. + * + * Note that any term has not an equivalent in cbv_value: for example, + * a product (x:A)B must be in normal form because only VAL may + * represent it, and the argument of VAL is always in normal + * form. This remark precludes coding a head reduction with these + * functions. Anyway, does it make sense to head reduce with a + * call-by-value strategy ? + *) +type cbv_value = + | VAL of int * constr + | LAM of name * constr * constr * cbv_value subs + | FIXP of fixpoint * cbv_value subs * cbv_value list + | COFIXP of cofixpoint * cbv_value subs * cbv_value list + | CONSTR of constructor * cbv_value list + +(* les vars pourraient etre des constr, + cela permet de retarder les lift: utile ?? *) + +(* relocation of a value; used when a value stored in a context is expanded + * in a larger context. e.g. [%k (S.t)](k+1) --> [^k]t (t is shifted of k) + *) +let rec shift_value n = function + | VAL (k,v) -> VAL ((k+n),v) + | LAM (x,a,b,s) -> LAM (x,a,b,subs_shft (n,s)) + | FIXP (fix,s,args) -> + FIXP (fix,subs_shft (n,s), List.map (shift_value n) args) + | COFIXP (cofix,s,args) -> + COFIXP (cofix,subs_shft (n,s), List.map (shift_value n) args) + | CONSTR (c,args) -> + CONSTR (c, List.map (shift_value n) args) + + +(* Contracts a fixpoint: given a fixpoint and a bindings, + * returns the corresponding fixpoint body, and the bindings in which + * it should be evaluated: its first variables are the fixpoint bodies + * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1})) + * -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti) + *) +let contract_fixp env ((reci,i),(_,_,bds as bodies)) = + let make_body j = FIXP(((reci,j),bodies), env, []) in + let n = Array.length bds in + let rec subst_bodies_from_i i subs = + if i=n then subs + else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs)) + in + subst_bodies_from_i 0 env, bds.(i) + +let contract_cofixp env (i,(_,_,bds as bodies)) = + let make_body j = COFIXP((j,bodies), env, []) in + let n = Array.length bds in + let rec subst_bodies_from_i i subs = + if i=n then subs + else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs)) + in + subst_bodies_from_i 0 env, bds.(i) + +let make_constr_ref n = function + | FarRelKey p -> mkRel (n+p) + | VarKey id -> mkVar id + | ConstKey cst -> mkConst cst + + +(* type of terms with a hole. This hole can appear only under App or Case. + * TOP means the term is considered without context + * APP(l,stk) means the term is applied to l, and then we have the context st + * this corresponds to the application stack of the KAM. + * The members of l are values: we evaluate arguments before the function. + * CASE(t,br,pat,S,stk) means the term is in a case (which is himself in stk + * t is the type of the case and br are the branches, all of them under + * the subs S, pat is information on the patterns of the Case + * (Weak reduction: we propagate the sub only when the selected branch + * is determined) + * + * Important remark: the APPs should be collapsed: + * (APP (l,(APP ...))) forbidden + *) + +type cbv_stack = + | TOP + | APP of cbv_value list * cbv_stack + | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + +(* Adds an application list. Collapse APPs! *) +let stack_app appl stack = + match (appl, stack) with + | ([], _) -> stack + | (_, APP(args,stk)) -> APP(appl@args,stk) + | _ -> APP(appl, stack) + + +open RedFlags + +let red_set_ref flags = function + | FarRelKey _ -> red_set flags fDELTA + | VarKey id -> red_set flags (fVAR id) + | ConstKey sp -> red_set flags (fCONST sp) + +(* Transfer application lists from a value to the stack + * useful because fixpoints may be totally applied in several times + *) +let strip_appl head stack = + match head with + | FIXP (fix,env,app) -> (FIXP(fix,env,[]), stack_app app stack) + | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[]), stack_app app stack) + | CONSTR (c,app) -> (CONSTR(c,[]), stack_app app stack) + | _ -> (head, stack) + + +(* Tests if fixpoint reduction is possible. A reduction function is given as + argument *) +let rec check_app_constr = function + | ([], _) -> false + | ((CONSTR _)::_, 0) -> true + | (_::l, n) -> check_app_constr (l,(pred n)) + +let fixp_reducible flgs ((reci,i),_) stk = + if red_set flgs fIOTA then + match stk with (* !!! for Acc_rec: reci.(i) = -2 *) + | APP(appl,_) -> reci.(i) >=0 & check_app_constr (appl, reci.(i)) + | _ -> false + else + false + +let cofixp_reducible flgs _ stk = + if red_set flgs fIOTA then + match stk with + | (CASE _ | APP(_,CASE _)) -> true + | _ -> false + else + false + +(* The main recursive functions + * + * Go under applications and cases (pushed in the stack), expand head + * constants or substitued de Bruijn, and try to make appear a + * constructor, a lambda or a fixp in the head. If not, it is a value + * and is completely computed here. The head redexes are NOT reduced: + * the function returns the pair of a cbv_value and its stack. * + * Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last + * argument is []. Because we must put all the applied terms in the + * stack. *) + +let rec norm_head info env t stack = + (* no reduction under binders *) + match kind_of_term t with + (* stack grows (remove casts) *) + | App (head,args) -> (* Applied terms are normalized immediately; + they could be computed when getting out of the stack *) + let nargs = Array.map (cbv_stack_term info TOP env) args in + norm_head info env head (stack_app (Array.to_list nargs) stack) + | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) + | Cast (ct,_) -> norm_head info env ct stack + + (* constants, axioms + * the first pattern is CRUCIAL, n=0 happens very often: + * when reducing closed terms, n is always 0 *) + | Rel i -> + (match expand_rel i env with + | Inl (0,v) -> strip_appl v stack + | Inl (n,v) -> strip_appl (shift_value n v) stack + | Inr (n,None) -> (VAL(0, mkRel n), stack) + | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (FarRelKey p)) + + | Var id -> norm_head_ref 0 info env stack (VarKey id) + + | Const sp -> norm_head_ref 0 info env stack (ConstKey sp) + + | LetIn (x, b, t, c) -> + (* zeta means letin are contracted; delta without zeta means we *) + (* allow bindings but leave let's in place *) + let zeta = red_set (info_flags info) fZETA in + let env' = + if zeta + (* New rule: for Cbv, Delta does not apply to locally bound variables + or red_set (info_flags info) fDELTA + *) + then + subs_cons (cbv_stack_term info TOP env b,env) + else + subs_lift env in + if zeta then + norm_head info env' c stack + else + let normt = + mkLetIn (x, cbv_norm_term info env b, + cbv_norm_term info env t, + cbv_norm_term info env' c) in + (VAL(0,normt), stack) (* Considérer une coupure commutative ? *) + + (* non-neutral cases *) + | Lambda (x,a,b) -> (LAM(x,a,b,env), stack) + | Fix fix -> (FIXP(fix,env,[]), stack) + | CoFix cofix -> (COFIXP(cofix,env,[]), stack) + | Construct c -> (CONSTR(c, []), stack) + + (* neutral cases *) + | (Sort _ | Meta _ | Ind _|Evar _) -> (VAL(0, t), stack) + | Prod (x,t,c) -> + (VAL(0, mkProd (x, cbv_norm_term info env t, + cbv_norm_term info (subs_lift env) c)), + stack) + +and norm_head_ref k info env stack normt = + if red_set_ref (info_flags info) normt then + match ref_value_cache info normt with + | Some body -> strip_appl (shift_value k body) stack + | None -> (VAL(0,make_constr_ref k normt), stack) + else (VAL(0,make_constr_ref k normt), stack) + +(* cbv_stack_term performs weak reduction on constr t under the subs + * env, with context stack, i.e. ([env]t stack). First computes weak + * head normal form of t and checks if a redex appears with the stack. + * If so, recursive call to reach the real head normal form. If not, + * we build a value. + *) +and cbv_stack_term info stack env t = + match norm_head info env t stack with + (* a lambda meets an application -> BETA *) + | (LAM (x,a,b,env), APP (arg::args, stk)) + when red_set (info_flags info) fBETA -> + let subs = subs_cons (arg,env) in + cbv_stack_term info (stack_app args stk) subs b + + (* a Fix applied enough -> IOTA *) + | (FIXP(fix,env,_), stk) + when fixp_reducible (info_flags info) fix stk -> + let (envf,redfix) = contract_fixp env fix in + cbv_stack_term info stk envf redfix + + (* constructor guard satisfied or Cofix in a Case -> IOTA *) + | (COFIXP(cofix,env,_), stk) + when cofixp_reducible (info_flags info) cofix stk-> + let (envf,redfix) = contract_cofixp env cofix in + cbv_stack_term info stk envf redfix + + (* constructor in a Case -> IOTA *) + | (CONSTR((sp,n),_), APP(args,CASE(_,br,ci,env,stk))) + when red_set (info_flags info) fIOTA -> + let real_args = list_skipn ci.ci_npar args in + cbv_stack_term info (stack_app real_args stk) env br.(n-1) + + (* constructor of arity 0 in a Case -> IOTA *) + | (CONSTR((_,n),_), CASE(_,br,_,env,stk)) + when red_set (info_flags info) fIOTA -> + cbv_stack_term info stk env br.(n-1) + + (* may be reduced later by application *) + | (head, TOP) -> head + | (FIXP(fix,env,_), APP(appl,TOP)) -> FIXP(fix,env,appl) + | (COFIXP(cofix,env,_), APP(appl,TOP)) -> COFIXP(cofix,env,appl) + | (CONSTR(c,_), APP(appl,TOP)) -> CONSTR(c,appl) + + (* definitely a value *) + | (head,stk) -> VAL(0,apply_stack info (cbv_norm_value info head) stk) + + +(* When we are sure t will never produce a redex with its stack, we + * normalize (even under binders) the applied terms and we build the + * final term + *) +and apply_stack info t = function + | TOP -> t + | APP (args,st) -> + apply_stack info (applistc t (List.map (cbv_norm_value info) args)) st + | CASE (ty,br,ci,env,st) -> + apply_stack info + (mkCase (ci, cbv_norm_term info env ty, t, + Array.map (cbv_norm_term info env) br)) + st + + +(* performs the reduction on a constr, and returns a constr *) +and cbv_norm_term info env t = + (* reduction under binders *) + cbv_norm_value info (cbv_stack_term info TOP env t) + +(* reduction of a cbv_value to a constr *) +and cbv_norm_value info = function (* reduction under binders *) + | VAL (n,v) -> lift n v + | LAM (x,a,b,env) -> + mkLambda (x, cbv_norm_term info env a, + cbv_norm_term info (subs_lift env) b) + | FIXP ((lij,(names,lty,bds)),env,args) -> + applistc + (mkFix (lij, + (names, + Array.map (cbv_norm_term info env) lty, + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds))) + (List.map (cbv_norm_value info) args) + | COFIXP ((j,(names,lty,bds)),env,args) -> + applistc + (mkCoFix (j, + (names,Array.map (cbv_norm_term info env) lty, + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds))) + (List.map (cbv_norm_value info) args) + | CONSTR (c,args) -> + applistc + (mkConstruct c) + (List.map (cbv_norm_value info) args) + +(* with profiling *) +let cbv_norm infos constr = + with_stats (lazy (cbv_norm_term infos (ESID 0) constr)) + + +type cbv_infos = cbv_value infos + +(* constant bodies are normalized at the first expansion *) +let create_cbv_infos flgs env = + create + (fun old_info c -> cbv_stack_term old_info TOP (ESID 0) c) + flgs + env diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli new file mode 100644 index 00000000..bf8e03b3 --- /dev/null +++ b/pretyping/cbv.mli @@ -0,0 +1,55 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> cbv_infos +val cbv_norm : cbv_infos -> constr -> constr + +(************************************************************************) +(*i This is for cbv debug *) +type cbv_value = + | VAL of int * constr + | LAM of name * constr * constr * cbv_value subs + | FIXP of fixpoint * cbv_value subs * cbv_value list + | COFIXP of cofixpoint * cbv_value subs * cbv_value list + | CONSTR of constructor * cbv_value list + +val shift_value : int -> cbv_value -> cbv_value + +type cbv_stack = + | TOP + | APP of cbv_value list * cbv_stack + | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + +val stack_app : cbv_value list -> cbv_stack -> cbv_stack +val strip_appl : cbv_value -> cbv_stack -> cbv_value * cbv_stack + +(* recursive functions... *) +val cbv_stack_term : cbv_infos -> + cbv_stack -> cbv_value subs -> constr -> cbv_value +val cbv_norm_term : cbv_infos -> cbv_value subs -> constr -> constr +val norm_head : cbv_infos -> + cbv_value subs -> constr -> cbv_stack -> cbv_value * cbv_stack +val apply_stack : cbv_infos -> constr -> cbv_stack -> constr +val cbv_norm_value : cbv_infos -> cbv_value -> constr +(* End of cbv debug section i*) diff --git a/pretyping/classops.ml b/pretyping/classops.ml new file mode 100755 index 00000000..2d8fb951 --- /dev/null +++ b/pretyping/classops.ml @@ -0,0 +1,397 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Global then + class_tab := Bijint.replace n cl s !class_tab + with Not_found -> + class_tab := Bijint.add cl s !class_tab + +let add_new_coercion coe s = + coercion_tab := Gmap.add coe s !coercion_tab + +let add_new_path x y = + inheritance_graph := Gmap.add x y !inheritance_graph + +let init () = + class_tab:= Bijint.empty; + add_new_class CL_FUN { cl_param = 0; cl_strength = Global }; + add_new_class CL_SORT { cl_param = 0; cl_strength = Global }; + coercion_tab:= Gmap.empty; + inheritance_graph:= Gmap.empty + +let _ = init() + +(* class_info : cl_typ -> int * cl_info_typ *) + +let class_info cl = Bijint.revmap cl !class_tab + +let class_exists cl = Bijint.mem cl !class_tab + +(* class_info_from_index : int -> cl_typ * cl_info_typ *) + +let class_info_from_index i = Bijint.map i !class_tab + +(* coercion_info : coe_typ -> coe_info_typ *) + +let coercion_info coe = Gmap.find coe !coercion_tab + +let coercion_exists coe = Gmap.mem coe !coercion_tab + +let coercion_params coe_info = coe_info.coe_param + +let lookup_path_between (s,t) = + Gmap.find (s,t) !inheritance_graph + +let lookup_path_to_fun_from s = + lookup_path_between (s,fst(class_info CL_FUN)) + +let lookup_path_to_sort_from s = + lookup_path_between (s,fst(class_info CL_SORT)) + +let lookup_pattern_path_between (s,t) = + let l = Gmap.find (s,t) !inheritance_graph in + List.map + (fun coe -> + let c, _ = + Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty + coe.coe_value.uj_val + in + match kind_of_term c with + | Construct sp -> (sp, coe.coe_param) + | _ -> raise Not_found) l + + +let subst_cl_typ subst ct = match ct with + CL_SORT + | CL_FUN + | CL_SECVAR _ -> ct + | CL_CONST kn -> + let kn' = subst_kn subst kn in + if kn' == kn then ct else + CL_CONST kn' + | CL_IND (kn,i) -> + let kn' = subst_kn subst kn in + if kn' == kn then ct else + CL_IND (kn',i) + +let subst_coe_typ = subst_global + +let subst_coe_info subst info = + let jud = info.coe_value in + let val' = subst_mps subst (j_val jud) in + let type' = subst_mps subst (j_type jud) in + if val' == j_val jud && type' == j_type jud then info else + {info with coe_value = make_judge val' type'} + +(* library, summary *) + +(*val inClass : (cl_typ * cl_info_typ) -> Libobject.object = + val outClass : Libobject.object -> (cl_typ * cl_info_typ) = *) + +let cache_class (_,(x,y)) = add_new_class x y + +let subst_class (_,subst,(ct,ci as obj)) = + let ct' = subst_cl_typ subst ct in + if ct' == ct then obj else + (ct',ci) + +let (inClass,outClass) = + declare_object {(default_object "CLASS") with + load_function = (fun _ o -> cache_class o); + cache_function = cache_class; + subst_function = subst_class; + classify_function = (fun (_,x) -> Substitute x); + export_function = (function x -> Some x) } + +let declare_class (cl,stre,p) = + Lib.add_anonymous_leaf (inClass ((cl,{ cl_strength = stre; cl_param = p }))) + +let _ = + Summary.declare_summary "inh_graph" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; + Summary.survive_module = false; + Summary.survive_section = false } + +(* classe d'un terme *) + +(* find_class_type : constr -> cl_typ * int *) + +let find_class_type t = + let t', args = decompose_app (Reductionops.whd_betaiotazeta t) in + match kind_of_term t' with + | Var id -> CL_SECVAR id, args + | Const sp -> CL_CONST sp, args + | Ind ind_sp -> CL_IND ind_sp, args + | Prod (_,_,_) -> CL_FUN, [] + | Sort _ -> CL_SORT, [] + | _ -> raise Not_found + +(* class_of : Term.constr -> int *) + +let class_of env sigma t = + let (t, n1, i, args) = + try + let (cl,args) = find_class_type t in + let (i, { cl_param = n1 } ) = class_info cl in + (t, n1, i, args) + with Not_found -> + let t = Tacred.hnf_constr env sigma t in + let (cl, args) = find_class_type t in + let (i, { cl_param = n1 } ) = class_info cl in + (t, n1, i, args) + in + if List.length args = n1 then t, i else raise Not_found + +let inductive_class_of ind = fst (class_info (CL_IND ind)) + +let class_args_of c = snd (decompose_app c) + +let string_of_class = function + | CL_FUN -> if !Options.v7 then "FUNCLASS" else "Funclass" + | CL_SORT -> if !Options.v7 then "SORTCLASS" else "Sortclass" + | CL_CONST sp -> + string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp)) + | CL_IND sp -> + string_of_qualid (shortest_qualid_of_global Idset.empty (IndRef sp)) + | CL_SECVAR sp -> + string_of_qualid (shortest_qualid_of_global Idset.empty (VarRef sp)) + +let pr_class x = str (string_of_class x) + +(* coercion_value : coe_index -> unsafe_judgment * bool *) + +let coercion_value { coe_value = j; coe_is_identity = b } = (j,b) + +(* pretty-print functions are now in Pretty *) +(* rajouter une coercion dans le graphe *) + +let path_printer = ref (fun _ -> str "" + : (int * int) * inheritance_path -> std_ppcmds) + +let install_path_printer f = path_printer := f + +let print_path x = !path_printer x + +let message_ambig l = + (str"Ambiguous paths:" ++ spc () ++ + prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l) + +(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit + coercion,source,target *) + +let different_class_params i j = + (snd (class_info_from_index i)).cl_param > 0 + +let add_coercion_in_graph (ic,source,target) = + let old_inheritance_graph = !inheritance_graph in + let ambig_paths = + (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in + let try_add_new_path (i,j as ij) p = + try + if i=j then begin + if different_class_params i j then begin + let _ = lookup_path_between ij in + ambig_paths := (ij,p)::!ambig_paths + end + end else begin + let _ = lookup_path_between (i,j) in + ambig_paths := (ij,p)::!ambig_paths + end; + false + with Not_found -> begin + add_new_path ij p; + true + end + in + let try_add_new_path1 ij p = + let _ = try_add_new_path ij p in () + in + if try_add_new_path (source,target) [ic] then begin + Gmap.iter + (fun (s,t) p -> + if s<>t then begin + if t = source then begin + try_add_new_path1 (s,target) (p@[ic]); + Gmap.iter + (fun (u,v) q -> + if u<>v & (u = target) & (p <> q) then + try_add_new_path1 (s,v) (p@[ic]@q)) + old_inheritance_graph + end; + if s = target then try_add_new_path1 (source,t) (ic::p) + end) + old_inheritance_graph + end; + if (!ambig_paths <> []) && is_verbose () then + ppnl (message_ambig !ambig_paths) + +type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ + +let cache_coercion (_,(coe,xf,cls,clt)) = + let is,_ = class_info cls in + let it,_ = class_info clt in + add_new_coercion coe xf; + add_coercion_in_graph (xf,is,it) + +let subst_coercion (_,subst,(coe,xf,cls,clt as obj)) = + let coe' = subst_coe_typ subst coe in + let xf' = subst_coe_info subst xf in + let cls' = subst_cl_typ subst cls in + let clt' = subst_cl_typ subst clt in + if coe' == coe && xf' == xf && cls' == cls & clt' == clt then obj else + (coe',xf',cls',clt') + + +(* val inCoercion : coercion -> Libobject.object + val outCoercion : Libobject.object -> coercion *) + +let (inCoercion,outCoercion) = + declare_object {(default_object "COERCION") with + load_function = (fun _ o -> cache_coercion o); + cache_function = cache_coercion; + subst_function = subst_coercion; + classify_function = (fun (_,x) -> Substitute x); + export_function = (function x -> Some x) } + +let declare_coercion coef v stre ~isid ~src:cls ~target:clt ~params:ps = + Lib.add_anonymous_leaf + (inCoercion + (coef, + { coe_value = v; + coe_strength = stre; + coe_is_identity = isid; + coe_param = ps }, + cls, clt)) + +let coercion_strength v = v.coe_strength +let coercion_identity v = v.coe_is_identity + +(* For printing purpose *) +let get_coercion_value v = v.coe_value.uj_val + +let classes () = Bijint.dom !class_tab +let coercions () = Gmap.rng !coercion_tab +let inheritance_graph () = Gmap.to_list !inheritance_graph + +let coercion_of_qualid qid = + let ref = Nametab.global qid in + if not (coercion_exists ref) then + errorlabstrm "try_add_coercion" + (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion"); + ref + +module CoercionPrinting = + struct + type t = coe_typ + let encode = coercion_of_qualid + let subst = subst_coe_typ + let printer x = pr_global_env Idset.empty x + let key = Goptions.SecondaryTable ("Printing","Coercion") + let title = "Explicitly printed coercions: " + let member_message x b = + str "Explicit printing of coercion " ++ printer x ++ + str (if b then " is set" else " is unset") + let synchronous = true + end + +module PrintingCoercion = Goptions.MakeRefTable(CoercionPrinting) + +let hide_coercion coe = + if not (PrintingCoercion.active coe) then + let coe_info = coercion_info coe in + Some coe_info.coe_param + else None diff --git a/pretyping/classops.mli b/pretyping/classops.mli new file mode 100644 index 00000000..f846a9e5 --- /dev/null +++ b/pretyping/classops.mli @@ -0,0 +1,116 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* cl_typ -> cl_typ + +(* This is the type of infos for declared classes *) +type cl_info_typ = { + cl_strength : strength; + cl_param : int } + +(* This is the type of coercion kinds *) +type coe_typ = Libnames.global_reference + +(* This is the type of infos for declared coercions *) +type coe_info_typ + +(* [cl_index] is the type of class keys *) +type cl_index + +(* [coe_index] is the type of coercion keys *) +type coe_index + +(* This is the type of paths from a class to another *) +type inheritance_path = coe_index list + +(*s [declare_class] adds a class to the set of declared classes *) +val declare_class : cl_typ * strength * int -> unit + +(*s Access to classes infos *) +val class_info : cl_typ -> (cl_index * cl_info_typ) +val class_exists : cl_typ -> bool +val class_info_from_index : cl_index -> cl_typ * cl_info_typ + +(* [find_class_type c] returns the head reference of c and its + arguments *) +val find_class_type : constr -> cl_typ * constr list + +(* raises [Not_found] if not convertible to a class *) +val class_of : env -> evar_map -> constr -> constr * cl_index + +(* raises [Not_found] if not mapped to a class *) +val inductive_class_of : inductive -> cl_index + +val class_args_of : constr -> constr list + +(*s [declare_coercion] adds a coercion in the graph of coercion paths *) +val declare_coercion : + coe_typ -> unsafe_judgment -> strength -> isid:bool -> + src:cl_typ -> target:cl_typ -> params:int -> unit + +(*s Access to coercions infos *) +val coercion_exists : coe_typ -> bool + +val coercion_value : coe_index -> (unsafe_judgment * bool) + +(*s Lookup functions for coercion paths *) +val lookup_path_between : cl_index * cl_index -> inheritance_path +val lookup_path_to_fun_from : cl_index -> inheritance_path +val lookup_path_to_sort_from : cl_index -> inheritance_path +val lookup_pattern_path_between : + cl_index * cl_index -> (constructor * int) list + +(*i Pour le discharge *) +type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ + +open Libobject +val inClass : (cl_typ * cl_info_typ) -> Libobject.obj +val outClass : Libobject.obj -> (cl_typ * cl_info_typ) +val inCoercion : coercion -> Libobject.obj +val outCoercion : Libobject.obj -> coercion +val coercion_strength : coe_info_typ -> strength +val coercion_identity : coe_info_typ -> bool +val coercion_params : coe_info_typ -> int +(*i*) + +(*i Crade *) +open Pp +val install_path_printer : + ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit +(*i*) + +(*s This is for printing purpose *) +val string_of_class : cl_typ -> string +val pr_class : cl_typ -> std_ppcmds +val get_coercion_value : coe_index -> constr +val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list +val classes : unit -> cl_typ list +val coercions : unit -> coe_index list + +(* [hide_coercion] returns the number of params to skip if the coercion must + be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) +val hide_coercion : coe_typ -> int option diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml new file mode 100644 index 00000000..f214388f --- /dev/null +++ b/pretyping/coercion.ml @@ -0,0 +1,211 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* { uj_val = applist (j_val funj,argl); + uj_type = typ } + | h::restl -> + (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) + match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + | Prod (_,c1,c2) -> + (* Typage garanti par l'appel à app_coercion*) + apply_rec (h::acc) (subst1 h c2) restl + | _ -> anomaly "apply_coercion_args" + in + apply_rec [] funj.uj_type argl + +exception NoCoercion + +(* appliquer le chemin de coercions de patterns p *) + +let apply_pattern_coercion loc pat p = + List.fold_left + (fun pat (co,n) -> + let f i = if i + let fv,isid = coercion_value i in + let argl = (class_args_of typ_cl)@[ja.uj_val] in + let jres = apply_coercion_args env argl fv in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else + jres), + jres.uj_type) + (hj,typ_cl) p) + with _ -> anomaly "apply_coercion" + +let inh_app_fun env isevars j = + let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in + match kind_of_term t with + | Prod (_,_,_) -> j + | Evar ev when not (is_defined_evar isevars ev) -> + let t = define_evar_as_arrow isevars ev in + { uj_val = j.uj_val; uj_type = t } + | _ -> + (try + let t,i1 = class_of1 env (evars_of isevars) j.uj_type in + let p = lookup_path_to_fun_from i1 in + apply_coercion env p j t + with Not_found -> j) + +let inh_tosort_force env isevars j = + try + let t,i1 = class_of1 env (evars_of isevars) j.uj_type in + let p = lookup_path_to_sort_from i1 in + apply_coercion env p j t + with Not_found -> + j + +let inh_coerce_to_sort env isevars j = + let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in + match kind_of_term typ with + | Sort s -> { utj_val = j.uj_val; utj_type = s } + | Evar ev when not (is_defined_evar isevars ev) -> + let s = define_evar_as_sort isevars ev in + { utj_val = j.uj_val; utj_type = s } + | _ -> + let j1 = inh_tosort_force env isevars j in + type_judgment env (j_nf_evar (evars_of isevars) j1) + +let inh_coerce_to_fail env isevars c1 hj = + let hj' = + try + let t1,i1 = class_of1 env (evars_of isevars) c1 in + let t2,i2 = class_of1 env (evars_of isevars) hj.uj_type in + let p = lookup_path_between (i2,i1) in + apply_coercion env p hj t2 + with Not_found -> raise NoCoercion + in + if the_conv_x_leq env isevars hj'.uj_type c1 then + hj' + else + raise NoCoercion + +let rec inh_conv_coerce_to_fail env isevars hj c1 = + let {uj_val = v; uj_type = t} = hj in + if the_conv_x_leq env isevars t c1 then hj + else + try + inh_coerce_to_fail env isevars c1 hj + with NoCoercion -> (* try ... with _ -> ... is BAD *) + (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t), + kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with + | Prod (_,t1,t2), Prod (name,u1,u2) -> + let v' = whd_betadeltaiota env (evars_of isevars) v in + if (match kind_of_term v' with + | Lambda (_,v1,v2) -> + the_conv_x env isevars v1 u1 (* leq v1 u1? *) + | _ -> false) + then + let (x,v1,v2) = destLambda v' in + let env1 = push_rel (x,None,v1) env in + let h2 = inh_conv_coerce_to_fail env1 isevars + {uj_val = v2; uj_type = t2 } u2 in + { uj_val = mkLambda (x, v1, h2.uj_val); + uj_type = mkProd (x, v1, h2.uj_type) } + else + (* Mismatch on t1 and u1 or not a lambda: we eta-expand *) + (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *) + (* has type (name:u1)u2 (with v' recursively obtained) *) + let name = (match name with + | Anonymous -> Name (id_of_string "x") + | _ -> name) in + let env1 = push_rel (name,None,u1) env in + let h1 = + inh_conv_coerce_to_fail env1 isevars + {uj_val = mkRel 1; uj_type = (lift 1 u1) } + (lift 1 t1) in + let h2 = inh_conv_coerce_to_fail env1 isevars + { uj_val = mkApp (lift 1 v, [|h1.uj_val|]); + uj_type = subst1 h1.uj_val t2 } + u2 + in + { uj_val = mkLambda (name, u1, h2.uj_val); + uj_type = mkProd (name, u1, h2.uj_type) } + | _ -> raise NoCoercion) + +(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) +let inh_conv_coerce_to loc env isevars cj t = + let cj' = + try + inh_conv_coerce_to_fail env isevars cj t + with NoCoercion -> + let sigma = evars_of isevars in + error_actual_type_loc loc env sigma cj t + in + { uj_val = cj'.uj_val; uj_type = t } + +(* [inh_apply_rel_list loc env isevars args f tycon] tries to type [(f + args)] of type [tycon] (if any) by inserting coercions in front of + each arg$_i$, if necessary *) + +let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon = + let rec apply_rec env n resj = function + | [] -> resj + | (loc,hj)::restjl -> + let sigma = evars_of isevars in + let resj = inh_app_fun env isevars resj in + let ntyp = whd_betadeltaiota env sigma resj.uj_type in + match kind_of_term ntyp with + | Prod (na,c1,c2) -> + let hj' = + try + inh_conv_coerce_to_fail env isevars hj c1 + with NoCoercion -> + error_cant_apply_bad_type_loc apploc env sigma + (1,c1,hj.uj_type) resj (List.map snd restjl) in + let newresj = + { uj_val = applist (j_val resj, [j_val hj']); + uj_type = subst1 hj'.uj_val c2 } in + apply_rec (push_rel (na,None,c1) env) (n+1) newresj restjl + | _ -> + error_cant_apply_not_functional_loc + (join_loc funloc loc) env sigma resj + (List.map snd restjl) + in + apply_rec env 1 funj argjl + diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli new file mode 100644 index 00000000..658844eb --- /dev/null +++ b/pretyping/coercion.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_defs -> unsafe_judgment -> unsafe_judgment + +(* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it + inserts a coercion into [j], if needed, in such a way it gets as + type a sort; it fails if no coercion is applicable *) +val inh_coerce_to_sort : + env -> evar_defs -> unsafe_judgment -> unsafe_type_judgment + +(* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type + [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and + [j.uj_type] are convertible; it fails if no coercion is applicable *) +val inh_conv_coerce_to : loc -> + env -> evar_defs -> unsafe_judgment -> constr -> unsafe_judgment + +(* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases + pattern [pat] typed in [ind1] into a pattern typed in [ind2]; + raises [Not_found] if no coercion found *) +val inh_pattern_coerce_to : + loc -> cases_pattern -> inductive -> inductive -> cases_pattern diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml new file mode 100644 index 00000000..41f63ace --- /dev/null +++ b/pretyping/detyping.ml @@ -0,0 +1,492 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* inductive * int array + val member_message : std_ppcmds -> bool -> std_ppcmds + val field : string + val title : string + end) -> + struct + type t = inductive * int array + let encode = Test.encode + let subst subst ((kn,i), ints as obj) = + let kn' = subst_kn subst kn in + if kn' == kn then obj else + (kn',i), ints + let printer (ind,_) = pr_global_env Idset.empty (IndRef ind) + let key = Goptions.SecondaryTable ("Printing",Test.field) + let title = Test.title + let member_message x = Test.member_message (printer x) + let synchronous = true + end + +module PrintingCasesIf = + PrintingCasesMake (struct + let encode = encode_bool + let field = "If" + let title = "Types leading to pretty-printing of Cases using a `if' form: " + let member_message s b = + str "Cases on elements of " ++ s ++ + str + (if b then " are printed using a `if' form" + else " are not printed using a `if' form") + end) + +module PrintingCasesLet = + PrintingCasesMake (struct + let encode = encode_tuple + let field = "Let" + let title = + "Types leading to a pretty-printing of Cases using a `let' form:" + let member_message s b = + str "Cases on elements of " ++ s ++ + str + (if b then " are printed using a `let' form" + else " are not printed using a `let' form") + end) + +module PrintingIf = Goptions.MakeRefTable(PrintingCasesIf) +module PrintingLet = Goptions.MakeRefTable(PrintingCasesLet) + +let force_let ci = + let indsp = ci.ci_ind in + let lc = mis_constr_nargs indsp in PrintingLet.active (indsp,lc) +let force_if ci = + let indsp = ci.ci_ind in + let lc = mis_constr_nargs indsp in PrintingIf.active (indsp,lc) + +(* Options for printing or not wildcard and synthetisable types *) + +open Goptions + +let wildcard_value = ref true +let force_wildcard () = !wildcard_value + +let _ = declare_bool_option + { optsync = true; + optname = "forced wildcard"; + optkey = SecondaryTable ("Printing","Wildcard"); + optread = force_wildcard; + optwrite = (:=) wildcard_value } + +let synth_type_value = ref true +let synthetize_type () = !synth_type_value + +let _ = declare_bool_option + { optsync = true; + optname = "synthesizability"; + optkey = SecondaryTable ("Printing","Synth"); + optread = synthetize_type; + optwrite = (:=) synth_type_value } + +(* Auxiliary function for MutCase printing *) +(* [computable] tries to tell if the predicate typing the result is inferable*) + +let computable p k = + (* We first remove as many lambda as the arity, then we look + if it remains a lambda for a dependent elimination. This function + works for normal eta-expanded term. For non eta-expanded or + non-normal terms, it may affirm the pred is synthetisable + because of an undetected ultimate dependent variable in the second + clause, or else, it may affirms the pred non synthetisable + because of a non normal term in the fourth clause. + A solution could be to store, in the MutCase, the eta-expanded + normal form of pred to decide if it depends on its variables + + Lorsque le prédicat est dépendant de manière certaine, on + ne déclare pas le prédicat synthétisable (même si la + variable dépendante ne l'est pas effectivement) parce que + sinon on perd la réciprocité de la synthèse (qui, lui, + engendrera un prédicat non dépendant) *) + + (nb_lam p = k+1) + && + let _,ccl = decompose_lam p in + noccur_between 1 (k+1) ccl + + +let lookup_name_as_renamed env t s = + let rec lookup avoid env_names n c = match kind_of_term c with + | Prod (name,_,c') -> + (match concrete_name true avoid env_names name c' with + | (Name id,avoid') -> + if id=s then (Some n) + else lookup avoid' (add_name (Name id) env_names) (n+1) c' + | (Anonymous,avoid') -> lookup avoid' env_names (n+1) (pop c')) + | LetIn (name,_,_,c') -> + (match concrete_name true avoid env_names name c' with + | (Name id,avoid') -> + if id=s then (Some n) + else lookup avoid' (add_name (Name id) env_names) (n+1) c' + | (Anonymous,avoid') -> lookup avoid' env_names (n+1) (pop c')) + | Cast (c,_) -> lookup avoid env_names n c + | _ -> None + in lookup (ids_of_named_context (named_context env)) empty_names_context 1 t + +let lookup_index_as_renamed env t n = + let rec lookup n d c = match kind_of_term c with + | Prod (name,_,c') -> + (match concrete_name true [] empty_names_context name c' with + (Name _,_) -> lookup n (d+1) c' + | (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c') + | LetIn (name,_,_,c') -> + (match concrete_name true [] empty_names_context name c' with + | (Name _,_) -> lookup n (d+1) c' + | (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c') + | Cast (c,_) -> lookup n d c + | _ -> None + in lookup n 1 t + +let is_nondep_branch c n = + try + let _,ccl = decompose_lam_n_assum n c in + noccur_between 1 n ccl + with _ -> (* Not eta-expanded or not reduced *) + false + +let extract_nondep_branches test c b n = + let rec strip n r = if n=0 then r else + match r with + | RLambda (_,_,_,t) -> strip (n-1) t + | RLetIn (_,_,_,t) -> strip (n-1) t + | _ -> assert false in + if test c n then Some (strip n b) else None + +let detype_case computable detype detype_eqn testdep + tenv avoid indsp st p k c bl = + let synth_type = synthetize_type () in + let tomatch = detype c in + + (* Find constructors arity *) + let (mib,mip) = Inductive.lookup_mind_specif tenv indsp in + let get_consnarg j = + let typi = mis_nf_constructor_type (indsp,mib,mip) (j+1) in + let _,t = decompose_prod_n_assum (List.length mip.mind_params_ctxt) typi in + List.rev (fst (decompose_prod_assum t)) in + let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in + let consnargsl = Array.map List.length consnargs in + let alias, aliastyp, newpred, pred = + if (not !Options.raw_print) & synth_type & computable & bl <> [||] then + Anonymous, None, None, None + else + let p = option_app detype p in + match p with + | None -> Anonymous, None, None, None + | Some p -> + let decompose_lam k c = + let rec lamdec_rec l avoid k c = + if k = 0 then List.rev l,c else match c with + | RLambda (_,x,t,c) -> + lamdec_rec (x::l) (name_cons x avoid) (k-1) c + | c -> + let x = next_ident_away (id_of_string "x") avoid in + lamdec_rec ((Name x)::l) (x::avoid) (k-1) + (let a = RVar (dummy_loc,x) in + match c with + | RApp (loc,p,l) -> RApp (loc,p,l@[a]) + | _ -> (RApp (dummy_loc,c,[a]))) + in + lamdec_rec [] [] k c in + let nl,typ = decompose_lam k p in + let n,typ = match typ with + | RLambda (_,x,t,c) -> x, c + | _ -> Anonymous, typ in + let aliastyp = + if List.for_all ((=) Anonymous) nl then None + else + let pars = list_tabulate (fun _ -> Anonymous) mip.mind_nparams + in Some (dummy_loc,indsp,pars@nl) in + n, aliastyp, Some typ, Some p + in + let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in + let eqnv = array_map3 detype_eqn constructs consnargsl bl in + let eqnl = Array.to_list eqnv in + let tag = + try + if !Options.raw_print then + RegularStyle + else if PrintingLet.active (indsp,consnargsl) then + LetStyle + else if PrintingIf.active (indsp,consnargsl) then + IfStyle + else + st + with Not_found -> st + in + if tag = RegularStyle then + RCases (dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl) + else + let bl' = Array.map detype bl in + if not !Options.v7 && tag = LetStyle && aliastyp = None then + let rec decomp_lam_force n avoid l p = + if n = 0 then (List.rev l,p) else + match p with + | RLambda (_,na,_,c) -> + decomp_lam_force (n-1) (name_cons na avoid) (na::l) c + | RLetIn (_,na,_,c) -> + decomp_lam_force (n-1) (name_cons na avoid) (na::l) c + | _ -> + let x = Nameops.next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (let a = RVar (dummy_loc,x) in + match p with + | RApp (loc,p,l) -> RApp (loc,p,l@[a]) + | _ -> (RApp (dummy_loc,p,[a]))) in + let (nal,d) = decomp_lam_force consnargsl.(0) avoid [] bl'.(0) in + RLetTuple (dummy_loc,nal,(alias,newpred),tomatch,d) + else + let nondepbrs = + array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in + if not !Options.v7 && tag = IfStyle && aliastyp = None + && array_for_all ((<>) None) nondepbrs then + RIf (dummy_loc,tomatch,(alias,newpred), + out_some nondepbrs.(0),out_some nondepbrs.(1)) + else if !Options.v7 then + let rec remove_type avoid args c = + match c,args with + | RLambda (loc,na,t,c), _::args -> + let h = RHole (dummy_loc,BinderType na) in + RLambda (loc,na,h,remove_type avoid args c) + | RLetIn (loc,na,b,c), _::args -> + RLetIn (loc,na,b,remove_type avoid args c) + | c, (na,None,t)::args -> + let id = next_name_away_with_default "x" na avoid in + let h = RHole (dummy_loc,BinderType na) in + let c = remove_type (id::avoid) args + (RApp (dummy_loc,c,[RVar (dummy_loc,id)])) in + RLambda (dummy_loc,Name id,h,c) + | c, (na,Some b,t)::args -> + let h = RHole (dummy_loc,BinderType na) in + let avoid = name_fold (fun x l -> x::l) na avoid in + RLetIn (dummy_loc,na,h,remove_type avoid args c) + | c, [] -> c in + let bl' = array_map2 (remove_type avoid) consnargs bl' in + ROrderedCase (dummy_loc,tag,pred,tomatch,bl',ref None) + else + RCases(dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl) + + +let rec detype tenv avoid env t = + match kind_of_term (collapse_appl t) with + | Rel n -> + (try match lookup_name_of_rel n env with + | Name id -> RVar (dummy_loc, id) + | Anonymous -> anomaly "detype: index to an anonymous variable" + with Not_found -> + let s = "_UNBOUND_REL_"^(string_of_int n) + in RVar (dummy_loc, id_of_string s)) + | Meta n -> + (* Meta in constr are not user-parsable and are mapped to Evar *) + REvar (dummy_loc, n, None) + | Var id -> + (try + let _ = Global.lookup_named id in RRef (dummy_loc, VarRef id) + with _ -> + RVar (dummy_loc, id)) + | Sort (Prop c) -> RSort (dummy_loc,RProp c) + | Sort (Type u) -> RSort (dummy_loc,RType (Some u)) + | Cast (c1,c2) -> + RCast(dummy_loc,detype tenv avoid env c1, + detype tenv avoid env c2) + | Prod (na,ty,c) -> detype_binder tenv BProd avoid env na ty c + | Lambda (na,ty,c) -> detype_binder tenv BLambda avoid env na ty c + | LetIn (na,b,_,c) -> detype_binder tenv BLetIn avoid env na b c + | App (f,args) -> + RApp (dummy_loc,detype tenv avoid env f, + array_map_to_list (detype tenv avoid env) args) + | Const sp -> RRef (dummy_loc, ConstRef sp) + | Evar (ev,cl) -> + REvar (dummy_loc, ev, + Some (List.map (detype tenv avoid env) (Array.to_list cl))) + | Ind ind_sp -> + RRef (dummy_loc, IndRef ind_sp) + | Construct cstr_sp -> + RRef (dummy_loc, ConstructRef cstr_sp) + | Case (annot,p,c,bl) -> + let comp = computable p (annot.ci_pp_info.ind_nargs) in + let ind = annot.ci_ind in + let st = annot.ci_pp_info.style in + detype_case comp (detype tenv avoid env) (detype_eqn tenv avoid env) + is_nondep_branch + (snd tenv) avoid ind st (Some p) annot.ci_pp_info.ind_nargs c bl + | Fix (nvn,recdef) -> detype_fix tenv avoid env nvn recdef + | CoFix (n,recdef) -> detype_cofix tenv avoid env n recdef + +and detype_fix tenv avoid env (vn,_ as nvn) (names,tys,bodies) = + let def_avoid, def_env, lfi = + Array.fold_left + (fun (avoid, env, l) na -> + let id = next_name_away na avoid in + (id::avoid, add_name (Name id) env, id::l)) + (avoid, env, []) names in + let n = Array.length tys in + let v = array_map3 + (fun c t i -> share_names tenv (i+1) [] def_avoid def_env c (lift n t)) + bodies tys vn in + RRec(dummy_loc,RFix nvn,Array.of_list (List.rev lfi), + Array.map (fun (bl,_,_) -> bl) v, + Array.map (fun (_,_,ty) -> ty) v, + Array.map (fun (_,bd,_) -> bd) v) + +and detype_cofix tenv avoid env n (names,tys,bodies) = + let def_avoid, def_env, lfi = + Array.fold_left + (fun (avoid, env, l) na -> + let id = next_name_away na avoid in + (id::avoid, add_name (Name id) env, id::l)) + (avoid, env, []) names in + let ntys = Array.length tys in + let v = array_map2 + (fun c t -> share_names tenv 0 [] def_avoid def_env c (lift ntys t)) + bodies tys in + RRec(dummy_loc,RCoFix n,Array.of_list (List.rev lfi), + Array.map (fun (bl,_,_) -> bl) v, + Array.map (fun (_,_,ty) -> ty) v, + Array.map (fun (_,bd,_) -> bd) v) + +and share_names tenv n l avoid env c t = + if !Options.v7 && n=0 then + let c = detype tenv avoid env c in + let t = detype tenv avoid env t in + (List.rev l,c,t) + else + match kind_of_term c, kind_of_term t with + (* factorize even when not necessary to have better presentation *) + | Lambda (na,t,c), Prod (na',t',c') -> + let na = match (na,na') with + Name _, _ -> na + | _, Name _ -> na' + | _ -> na in + let t = detype tenv avoid env t in + let id = next_name_away na avoid in + let avoid = id::avoid and env = add_name (Name id) env in + share_names tenv (n-1) ((Name id,None,t)::l) avoid env c c' + (* May occur for fix built interactively *) + | LetIn (na,b,t',c), _ when n > 0 -> + let t' = detype tenv avoid env t' in + let b = detype tenv avoid env b in + let id = next_name_away na avoid in + let avoid = id::avoid and env = add_name (Name id) env in + share_names tenv n ((Name id,Some b,t')::l) avoid env c t + (* Only if built with the f/n notation or w/o let-expansion in types *) + | _, LetIn (_,b,_,t) when n > 0 -> + share_names tenv n l avoid env c (subst1 b t) + (* If it is an open proof: we cheat and eta-expand *) + | _, Prod (na',t',c') when n > 0 -> + let t' = detype tenv avoid env t' in + let id = next_name_away na' avoid in + let avoid = id::avoid and env = add_name (Name id) env in + let appc = mkApp (lift 1 c,[|mkRel 1|]) in + share_names tenv (n-1) ((Name id,None,t')::l) avoid env appc c' + (* If built with the f/n notation: we renounce to share names *) + | _ -> + if n>0 then warning "Detyping.detype: cannot factorize fix enough"; + let c = detype tenv avoid env c in + let t = detype tenv avoid env t in + (List.rev l,c,t) + +and detype_eqn tenv avoid env constr construct_nargs branch = + let make_pat x avoid env b ids = + if force_wildcard () & noccurn 1 b then + PatVar (dummy_loc,Anonymous),avoid,(add_name Anonymous env),ids + else + let id = next_name_away_with_default "x" x avoid in + PatVar (dummy_loc,Name id),id::avoid,(add_name (Name id) env),id::ids + in + let rec buildrec ids patlist avoid env n b = + if n=0 then + (dummy_loc, ids, + [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)], + detype tenv avoid env b) + else + match kind_of_term b with + | Lambda (x,_,b) -> + let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in + buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b + + | LetIn (x,_,_,b) -> + let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in + buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b + + | Cast (c,_) -> (* Oui, il y a parfois des cast *) + buildrec ids patlist avoid env n c + + | _ -> (* eta-expansion : n'arrivera plus lorsque tous les + termes seront construits à partir de la syntaxe Cases *) + (* nommage de la nouvelle variable *) + let new_b = applist (lift 1 b, [mkRel 1]) in + let pat,new_avoid,new_env,new_ids = + make_pat Anonymous avoid env new_b ids in + buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b + + in + buildrec [] [] avoid env construct_nargs branch + +and detype_binder tenv bk avoid env na ty c = + let na',avoid' = + if bk = BLetIn then + concrete_let_name (fst tenv) avoid env na c + else + concrete_name (fst tenv) avoid env na c in + let r = detype tenv avoid' (add_name na' env) c in + match bk with + | BProd -> RProd (dummy_loc, na',detype tenv [] env ty, r) + | BLambda -> RLambda (dummy_loc, na',detype tenv [] env ty, r) + | BLetIn -> RLetIn (dummy_loc, na',detype tenv [] env ty, r) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli new file mode 100644 index 00000000..c2a70928 --- /dev/null +++ b/pretyping/detyping.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* identifier list -> names_context -> constr -> + rawconstr + +val detype_case : + bool -> ('a -> rawconstr) -> + (constructor -> int -> 'a -> loc * identifier list * cases_pattern list * + rawconstr) -> ('a -> int -> bool) -> + env -> identifier list -> inductive -> case_style -> + 'a option -> int -> 'a -> 'a array -> rawconstr + +(* look for the index of a named var or a nondep var as it is renamed *) +val lookup_name_as_renamed : env -> constr -> identifier -> int option +val lookup_index_as_renamed : env -> constr -> int -> int option + + +val force_wildcard : unit -> bool +val synthetize_type : unit -> bool +val force_if : case_info -> bool +val force_let : case_info -> bool diff --git a/pretyping/doc.tex b/pretyping/doc.tex new file mode 100644 index 00000000..d92a027e --- /dev/null +++ b/pretyping/doc.tex @@ -0,0 +1,14 @@ + +\newpage +\section*{Pre-typing} + +\ocwsection \label{pretyping} + +\bigskip +\begin{center}\epsfig{file=pretyping.dep.ps,width=\linewidth}\end{center} + + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: t +%%% End: diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml new file mode 100644 index 00000000..6f396b43 --- /dev/null +++ b/pretyping/evarconv.ml @@ -0,0 +1,397 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* MaybeFlexible c + | Rel n -> MaybeFlexible c + | Var id -> MaybeFlexible c + | Lambda _ when l<>[] -> MaybeFlexible c + | LetIn _ -> MaybeFlexible c + | Evar ev -> Flexible ev + | _ -> Rigid c + +let eval_flexible_term env c = + match kind_of_term c with + | Const c -> constant_opt_value env c + | Rel n -> let (_,v,_) = lookup_rel n env in option_app (lift n) v + | Var id -> let (_,v,_) = lookup_named id env in v + | LetIn (_,b,_,c) -> Some (subst1 b c) + | Lambda _ -> Some c + | _ -> assert false +(* +let rec apprec_nobeta env sigma s = + let (t,stack as s) = whd_state s in + match kind_of_term (fst s) with + | Case (ci,p,d,lf) -> + let (cr,crargs) = whd_betadeltaiota_stack env sigma d in + let rslt = mkCase (ci, p, applist (cr,crargs), lf) in + if reducible_mind_case cr then + apprec_nobeta env sigma (rslt, stack) + else + s + | Fix fix -> + (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with + | Reduced s -> apprec_nobeta env sigma s + | NotReducible -> s) + | _ -> s + +let evar_apprec_nobeta env isevars stack c = + let rec aux s = + let (t,stack as s') = apprec_nobeta env (evars_of isevars) s in + match kind_of_term t with + | Evar (n,_ as ev) when Evd.is_defined (evars_of isevars) n -> + aux (existential_value (evars_of isevars) ev, stack) + | _ -> (t, list_of_stack stack) + in aux (c, append_stack (Array.of_list stack) empty_stack) +*) + +let evar_apprec env isevars stack c = + let sigma = evars_of isevars in + let rec aux s = + let (t,stack as s') = Reductionops.apprec env sigma s in + match kind_of_term t with + | Evar (n,_ as ev) when Evd.is_defined sigma n -> + aux (existential_value sigma ev, stack) + | _ -> (t, list_of_stack stack) + in aux (c, append_stack (Array.of_list stack) empty_stack) + +let apprec_nohdbeta env isevars c = + let (t,stack as s) = Reductionops.whd_stack c in + match kind_of_term t with + | (Case _ | Fix _) -> evar_apprec env isevars [] c + | _ -> s + +(* [check_conv_record (t1,l1) (t2,l2)] tries to decompose the problem + (t1 l1) = (t2 l2) into a problem + + l1 = params1@c1::extra_args1 + l2 = us2@extra_args2 + (t1 params1 c1) = (proji params (c xs)) + (t2 us2) = (cstr us) + extra_args1 = extra_args2 + + by finding a record R and an object c := [xs:bs](Build_R a1..am v1..vn) + with vi = (cstr us), for which we know that the i-th projection proji + satisfies + + (proji params c) = (cstr us) + + Rem: such objects, usable for conversion, are defined in the objdef + table; practically, it amounts to "canonically" equip t2 into a + object c in structure R (since, if c1 were not an evar, the + projection would have been reduced) *) + +let check_conv_record (t1,l1) (t2,l2) = + try + let proji = reference_of_constr t1 in + let cstr = reference_of_constr t2 in + let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } = + objdef_info (proji, cstr) in + let params1, c1, extra_args1 = + match list_chop (List.length params) l1 with + | params1, c1::extra_args1 -> params1, c1, extra_args1 + | _ -> assert false in + let us2,extra_args2 = list_chop (List.length us) l2 in + c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1 + with _ -> + raise Not_found + + +(* Precondition: one of the terms of the pb is an uninstanciated evar, + * possibly applied to arguments. *) + +let rec evar_conv_x env isevars pbty term1 term2 = + let sigma = evars_of isevars in + let term1 = whd_castappevar sigma term1 in + let term2 = whd_castappevar sigma term2 in +(* + if eq_constr term1 term2 then + true + else +*) + (* Maybe convertible but since reducing can erase evars which [evar_apprec]*) + (* could have found, we do it only if the terms are free of evar *) + (not (has_undefined_isevars isevars term1) & + not (has_undefined_isevars isevars term2) & + is_fconv pbty env (evars_of isevars) term1 term2) + or + if ise_undefined isevars term1 then + solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term1,term2) + else if ise_undefined isevars term2 then + solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term2,term1) + else + let (t1,l1) = apprec_nohdbeta env isevars term1 in + let (t2,l2) = apprec_nohdbeta env isevars term2 in + if (head_is_embedded_evar isevars t1 & not(is_eliminator t2)) + or (head_is_embedded_evar isevars t2 & not(is_eliminator t1)) + then + (add_conv_pb isevars (pbty,applist(t1,l1),applist(t2,l2)); true) + else + evar_eqappr_x env isevars pbty (t1,l1) (t2,l2) + +and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = + (* Evar must be undefined since we have whd_ised *) + match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with + | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> + let f1 () = + if List.length l1 > List.length l2 then + let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in + solve_simple_eqn evar_conv_x env isevars + (pbty,ev2,applist(term1,deb1)) + & list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 + else + let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in + solve_simple_eqn evar_conv_x env isevars + (pbty,ev1,applist(term2,deb2)) + & list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 + and f2 () = + (sp1 = sp2) + & (array_for_all2 (evar_conv_x env isevars CONV) al1 al2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + in + ise_try isevars [f1; f2] + + | Flexible ev1, MaybeFlexible flex2 -> + let f1 () = + (List.length l1 <= List.length l2) & + let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in + (* First compare extra args for better failure message *) + list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 & + evar_conv_x env isevars pbty term1 (applist(term2,deb2)) + and f4 () = + match eval_flexible_term env flex2 with + | Some v2 -> + evar_eqappr_x env isevars pbty + appr1 (evar_apprec env isevars l2 v2) + | None -> false + in + ise_try isevars [f1; f4] + + | MaybeFlexible flex1, Flexible ev2 -> + let f1 () = + (List.length l2 <= List.length l1) & + let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in + (* First compare extra args for better failure message *) + list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 & + evar_conv_x env isevars pbty (applist(term1,deb1)) term2 + and f4 () = + match eval_flexible_term env flex1 with + | Some v1 -> + evar_eqappr_x env isevars pbty + (evar_apprec env isevars l1 v1) appr2 + | None -> false + in + ise_try isevars [f1; f4] + + | MaybeFlexible flex1, MaybeFlexible flex2 -> + let f2 () = + (flex1 = flex2) + & (List.length l1 = List.length l2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + and f3 () = + (try conv_record env isevars + (try check_conv_record appr1 appr2 + with Not_found -> check_conv_record appr2 appr1) + with _ -> false) + and f4 () = + (* heuristic: unfold second argument first, exception made + if the first argument is a beta-redex (expand a constant + only if necessary) *) + let val2 = + match kind_of_term flex1 with + Lambda _ -> None + | _ -> eval_flexible_term env flex2 in + match val2 with + | Some v2 -> + evar_eqappr_x env isevars pbty + appr1 (evar_apprec env isevars l2 v2) + | None -> + match eval_flexible_term env flex1 with + | Some v1 -> + evar_eqappr_x env isevars pbty + (evar_apprec env isevars l1 v1) appr2 + | None -> false + in + ise_try isevars [f2; f3; f4] + + | Flexible ev1, Rigid _ -> + (List.length l1 <= List.length l2) & + let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in + (* First compare extra args for better failure message *) + list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 & + solve_simple_eqn evar_conv_x env isevars + (pbty,ev1,applist(term2,deb2)) + + | Rigid _, Flexible ev2 -> + (List.length l2 <= List.length l1) & + let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in + (* First compare extra args for better failure message *) + list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 & + solve_simple_eqn evar_conv_x env isevars + (pbty,ev2,applist(term1,deb1)) + + + | MaybeFlexible flex1, Rigid _ -> + let f3 () = + (try conv_record env isevars (check_conv_record appr1 appr2) + with _ -> false) + and f4 () = + match eval_flexible_term env flex1 with + | Some v1 -> + evar_eqappr_x env isevars pbty + (evar_apprec env isevars l1 v1) appr2 + | None -> false + in + ise_try isevars [f3; f4] + + | Rigid _ , MaybeFlexible flex2 -> + let f3 () = + (try (conv_record env isevars (check_conv_record appr2 appr1)) + with _ -> false) + and f4 () = + match eval_flexible_term env flex2 with + | Some v2 -> + evar_eqappr_x env isevars pbty + appr1 (evar_apprec env isevars l2 v2) + | None -> false + in + ise_try isevars [f3; f4] + + | Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with + + | Cast (c1,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2 + + | _, Cast (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2) + + | Sort s1, Sort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2 + + | Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> + evar_conv_x env isevars CONV c1 c2 + & + (let c = nf_evar (evars_of isevars) c1 in + evar_conv_x (push_rel (na,None,c) env) isevars CONV c'1 c'2) + + | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> + let f1 () = + evar_conv_x env isevars CONV b1 b2 + & + (let b = nf_evar (evars_of isevars) b1 in + let t = nf_evar (evars_of isevars) t1 in + evar_conv_x (push_rel (na,Some b,t) env) isevars pbty c'1 c'2) + & (List.length l1 = List.length l2) + & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2) + and f2 () = + let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1) + and appr2 = evar_apprec env isevars l2 (subst1 b2 c'2) + in evar_eqappr_x env isevars pbty appr1 appr2 + in + ise_try isevars [f1; f2] + + | LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *) + let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1) + in evar_eqappr_x env isevars pbty appr1 appr2 + + | _, LetIn (_,b2,_,c'2) -> + let appr2 = evar_apprec env isevars l2 (subst1 b2 c'2) + in evar_eqappr_x env isevars pbty appr1 appr2 + + | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> + evar_conv_x env isevars CONV c1 c2 + & + (let c = nf_evar (evars_of isevars) c1 in + evar_conv_x (push_rel (n,None,c) env) isevars pbty c'1 c'2) + + | Ind sp1, Ind sp2 -> + sp1=sp2 + & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 + + | Construct sp1, Construct sp2 -> + sp1=sp2 + & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 + + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> + evar_conv_x env isevars CONV p1 p2 + & evar_conv_x env isevars CONV c1 c2 + & (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + + | Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) -> + li1=li2 + & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2) + & (array_for_all2 + (evar_conv_x (push_rec_types recdef1 env) isevars CONV) + bds1 bds2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + + | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> + i1=i2 + & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2) + & (array_for_all2 + (evar_conv_x (push_rec_types recdef1 env) isevars CONV) + bds1 bds2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + + | (Meta _ | Lambda _), _ -> false + | _, (Meta _ | Lambda _) -> false + + | (Ind _ | Construct _ | Sort _ | Prod _), _ -> false + | _, (Ind _ | Construct _ | Sort _ | Prod _) -> false + + | (App _ | Case _ | Fix _ | CoFix _), + (App _ | Case _ | Fix _ | CoFix _) -> false + + | (Rel _ | Var _ | Const _ | Evar _), _ -> assert false + | _, (Rel _ | Var _ | Const _ | Evar _) -> assert false + +and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) = + let ks = + List.fold_left + (fun ks b -> + let dloc = (dummy_loc,Rawterm.InternalHole) in + (new_isevar isevars env dloc (substl ks b)) :: ks) + [] bs + in + if (list_for_all2eq + (fun u1 u -> evar_conv_x env isevars CONV u1 (substl ks u)) + us2 us) + & + (list_for_all2eq + (fun x1 x -> evar_conv_x env isevars CONV x1 (substl ks x)) + params1 params) + & (list_for_all2eq (evar_conv_x env isevars CONV) ts ts1) + & (evar_conv_x env isevars CONV c1 (applist (c,(List.rev ks)))) + then + (*TR*) (if !compter then (nbstruc:=!nbstruc+1; + nbimplstruc:=!nbimplstruc+(List.length ks);true) + else true) + else false + +let the_conv_x env isevars t1 t2 = evar_conv_x env isevars CONV t1 t2 +let the_conv_x_leq env isevars t1 t2 = evar_conv_x env isevars CUMUL t1 t2 + diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli new file mode 100644 index 00000000..8785d855 --- /dev/null +++ b/pretyping/evarconv.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_defs -> constr -> constr -> bool + +val the_conv_x_leq : env -> evar_defs -> constr -> constr -> bool + +(*i For debugging *) +val evar_conv_x : env -> evar_defs -> conv_pb -> constr -> constr -> bool +val evar_eqappr_x : + env -> evar_defs -> + conv_pb -> constr * constr list -> constr * constr list -> bool +(*i*) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml new file mode 100644 index 00000000..441070fe --- /dev/null +++ b/pretyping/evarutil.ml @@ -0,0 +1,579 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [] + | x::l -> + if List.mem x l then filter_unique (List.filter (fun y -> x<>y) l) + else x::filter_unique l + +(* +let distinct_id_list = + let rec drec fresh = function + [] -> List.rev fresh + | id::rest -> + let id' = next_ident_away_from id fresh in drec (id'::fresh) rest + in drec [] +*) + +(* +let filter_sign p sign x = + sign_it + (fun id ty (v,ids,sgn) -> + let (disc,v') = p v (id,ty) in + if disc then (v', id::ids, sgn) else (v', ids, add_sign (id,ty) sgn)) + sign + (x,[],nil_sign) +*) + +(* Expanding existential variables (pretyping.ml) *) +(* 1- whd_ise fails if an existential is undefined *) + +exception Uninstantiated_evar of existential_key + +let rec whd_ise sigma c = + match kind_of_term c with + | Evar (ev,args) when Evd.in_dom sigma ev -> + if Evd.is_defined sigma ev then + whd_ise sigma (existential_value sigma (ev,args)) + else raise (Uninstantiated_evar ev) + | _ -> c + + +(* Expand evars, possibly in the head of an application *) +let whd_castappevar_stack sigma c = + let rec whrec (c, l as s) = + match kind_of_term c with + | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> + whrec (existential_value sigma (ev,args), l) + | Cast (c,_) -> whrec (c, l) + | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) + | _ -> s + in + whrec (c, []) + +let whd_castappevar sigma c = applist (whd_castappevar_stack sigma c) + +let nf_evar = Pretype_errors.nf_evar +let j_nf_evar = Pretype_errors.j_nf_evar +let jl_nf_evar = Pretype_errors.jl_nf_evar +let jv_nf_evar = Pretype_errors.jv_nf_evar +let tj_nf_evar = Pretype_errors.tj_nf_evar + +(**********************) +(* Creating new evars *) +(**********************) + +let evar_env evd = Global.env_of_context evd.evar_hyps + +(* Generator of existential names *) +let new_evar = + let evar_ctr = ref 0 in + fun () -> incr evar_ctr; existential_of_int !evar_ctr + +let make_evar_instance env = + fold_named_context + (fun env (id, b, _) l -> (*if b=None then*) mkVar id :: l (*else l*)) + env ~init:[] + +(* create an untyped existential variable *) +let new_evar_in_sign env = + let ev = new_evar () in + mkEvar (ev, Array.of_list (make_evar_instance env)) + +(*------------------------------------* + * functional operations on evar sets * + *------------------------------------*) + +(* All ids of sign must be distincts! *) +let new_isevar_sign env sigma typ instance = + let sign = named_context env in + if not (list_distinct (ids_of_named_context sign)) then + error "new_isevar_sign: two vars have the same name"; + let newev = new_evar() in + let info = { evar_concl = typ; evar_hyps = sign; + evar_body = Evar_empty } in + (Evd.add sigma newev info, mkEvar (newev,Array.of_list instance)) + +(* We don't try to guess in which sort the type should be defined, since + any type has type Type. May cause some trouble, but not so far... *) +let new_Type () = mkType (new_univ ()) + +let new_Type_sort () = Type (new_univ ()) + +let judge_of_new_Type () = Typeops.judge_of_type (new_univ ()) +(* +let new_Type () = mkType dummy_univ + +let new_Type_sort () = Type dummy_univ + +let judge_of_new_Type () = + { uj_val = mkSort (Type dummy_univ); + uj_type = mkSort (Type dummy_univ) } +*) + +(* This refreshes universes in types; works only for inferred types (i.e. for + types of the form (x1:A1)...(xn:An)B with B a sort or an atom in + head normal form) *) +let refresh_universes t = + let modified = ref false in + let rec refresh t = match kind_of_term t with + | Sort (Type _) -> modified := true; new_Type () + | Prod (na,u,v) -> mkProd (na,u,refresh v) + | _ -> t in + let t' = refresh t in + if !modified then t' else t + +(* Declaring any type to be in the sort Type shouldn't be harmful since + cumulativity now includes Prop and Set in Type. *) +let new_type_var env sigma = + let instance = make_evar_instance env in + new_isevar_sign env sigma (new_Type ()) instance + +let split_evar_to_arrow sigma (ev,args) = + let evd = Evd.map sigma ev in + let evenv = evar_env evd in + let (sigma1,dom) = new_type_var evenv sigma in + let hyps = evd.evar_hyps in + let nvar = next_ident_away (id_of_string "x") (ids_of_named_context hyps) in + let newenv = push_named (nvar, None, dom) evenv in + let (sigma2,rng) = new_type_var newenv sigma1 in + let x = named_hd newenv dom Anonymous in + let prod = mkProd (x, dom, subst_var nvar rng) in + let sigma3 = Evd.define sigma2 ev prod in + let evdom = fst (destEvar dom), args in + let evrng = + fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in + let prod' = mkProd (x, mkEvar evdom, mkEvar evrng) in + (sigma3,prod', evdom, evrng) + +(* Redefines an evar with a smaller context (i.e. it may depend on less + * variables) such that c becomes closed. + * Example: in [x:?1; y:(list ?2)] x=y /\ x=(nil bool) + * ?3 <-- ?1 no pb: env of ?3 is larger than ?1's + * ?1 <-- (list ?2) pb: ?2 may depend on x, but not ?1. + * What we do is that ?2 is defined by a new evar ?4 whose context will be + * a prefix of ?2's env, included in ?1's env. *) + +let do_restrict_hyps sigma ev args = + let args = Array.to_list args in + let evd = Evd.map sigma ev in + let env = evar_env evd in + let hyps = evd.evar_hyps in + let (_,(rsign,ncargs)) = + List.fold_left + (fun (sign,(rs,na)) a -> + (List.tl sign, + if not(closed0 a) then + (rs,na) + else + (add_named_decl (List.hd sign) rs, a::na))) + (hyps,([],[])) args + in + let sign' = List.rev rsign in + let env' = reset_with_named_context sign' env in + let instance = make_evar_instance env' in + let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl instance in + let nc = refresh_universes nc in (* needed only if nc is an inferred type *) + let sigma'' = Evd.define sigma' ev nc in + (sigma'', nc) + + + + +(*------------------------------------* + * operations on the evar constraints * + *------------------------------------*) + +type evar_constraint = conv_pb * constr * constr +type evar_defs = + { mutable evars : Evd.evar_map; + mutable conv_pbs : evar_constraint list; + mutable history : (existential_key * (loc * Rawterm.hole_kind)) list } + +let create_evar_defs evd = { evars=evd; conv_pbs=[]; history=[] } +let evars_of d = d.evars +let evars_reset_evd evd d = d.evars <- evd +let add_conv_pb d pb = d.conv_pbs <- pb::d.conv_pbs +let evar_source ev d = + try List.assoc ev d.history + with Failure _ -> (dummy_loc, Rawterm.InternalHole) + +(* ise_try [f1;...;fn] tries fi() for i=1..n, restoring the evar constraints + * when fi returns false or an exception. Returns true if one of the fi + * returns true, and false if every fi return false (in the latter case, + * the evar constraints are restored). + *) +let ise_try isevars l = + let u = isevars.evars in + let rec test = function + [] -> isevars.evars <- u; false + | f::l -> + (try f() with reraise -> isevars.evars <- u; raise reraise) + or (isevars.evars <- u; test l) + in test l + + + +(* say if the section path sp corresponds to an existential *) +let ise_in_dom isevars sp = Evd.in_dom isevars.evars sp + +(* map the given section path to the enamed_declaration *) +let ise_map isevars sp = Evd.map isevars.evars sp + +(* define the existential of section path sp as the constr body *) +let ise_define isevars sp body = + let body = refresh_universes body in (* needed only if an inferred type *) + isevars.evars <- Evd.define isevars.evars sp body + +let is_defined_evar isevars (n,_) = Evd.is_defined isevars.evars n + +(* Does k corresponds to an (un)defined existential ? *) +let ise_undefined isevars c = match kind_of_term c with + | Evar ev -> not (is_defined_evar isevars ev) + | _ -> false + +let need_restriction isevars args = not (array_for_all closed0 args) + + +(* We try to instanciate the evar assuming the body won't depend + * on arguments that are not Rels or Vars, or appearing several times. + *) +(* Note: error_not_clean should not be an error: it simply means that the + * conversion test that lead to the faulty call to [real_clean] should return + * false. The problem is that we won't get the right error message. + *) + +let real_clean env isevars ev args rhs = + let subst = List.map (fun (x,y) -> (y,mkVar x)) (filter_unique args) in + let rec subs k t = + match kind_of_term t with + | Rel i -> + if i<=k then t + else (try List.assoc (mkRel (i-k)) subst with Not_found -> t) + | Evar (ev,args) -> + let args' = Array.map (subs k) args in + if need_restriction isevars args' then + if Evd.is_defined isevars.evars ev then + subs k (existential_value isevars.evars (ev,args')) + else begin + let (sigma,rc) = do_restrict_hyps isevars.evars ev args' in + isevars.evars <- sigma; + isevars.history <- + (fst (destEvar rc),evar_source ev isevars)::isevars.history; + rc + end + else + mkEvar (ev,args') + | Var _ -> (try List.assoc t subst with Not_found -> t) + | _ -> map_constr_with_binders succ subs k t + in + let body = subs 0 rhs in + if not (closed0 body) + then error_not_clean env isevars.evars ev body (evar_source ev isevars); + body + +let make_evar_instance_with_rel env = + let n = rel_context_length (rel_context env) in + let vars = + fold_named_context + (fun env (id,b,_) l -> (* if b=None then *) mkVar id :: l (*else l*)) + env ~init:[] in + snd (fold_rel_context + (fun env (_,b,_) (i,l) -> + (i-1, (*if b=None then *) mkRel i :: l (*else l*))) + env ~init:(n,vars)) + +let make_subst env args = + snd (fold_named_context + (fun env (id,b,c) (args,l as g) -> + match b, args with + | (* None *) _ , a::rest -> (rest, (id,a)::l) +(* | Some _, _ -> g*) + | _ -> anomaly "Instance does not match its signature") + env ~init:(List.rev args,[])) + +(* [new_isevar] declares a new existential in an env env with type typ *) +(* Converting the env into the sign of the evar to define *) + +let push_rel_context_to_named_context env = + let sign0 = named_context env in + let (subst,_,sign) = + Sign.fold_rel_context + (fun (na,c,t) (subst,avoid,sign) -> + let na = if na = Anonymous then Name(id_of_string"_") else na in + let id = next_name_away na avoid in + ((mkVar id)::subst, + id::avoid, + add_named_decl (id,option_app (substl subst) c, + type_app (substl subst) t) + sign)) + (rel_context env) ~init:([],ids_of_named_context sign0,sign0) + in (subst, reset_with_named_context sign env) + +let new_isevar isevars env src typ = + let subst,env' = push_rel_context_to_named_context env in + let typ' = substl subst typ in + let instance = make_evar_instance_with_rel env in + let (sigma',evar) = new_isevar_sign env' isevars.evars typ' instance in + isevars.evars <- sigma'; + isevars.history <- (fst (destEvar evar),src)::isevars.history; + evar + +(* [evar_define] solves the problem lhs = rhs when lhs is an uninstantiated + * evar, i.e. tries to find the body ?sp for lhs=mkEvar (sp,args) + * ?sp [ sp.hyps \ args ] unifies to rhs + * ?sp must be a closed term, not referring to itself. + * Not so trivial because some terms of args may be terms that are not + * variables. In this case, the non-var-or-Rels arguments are replaced + * by . [clean_rhs] will ignore this part of the subtitution. + * This leads to incompleteness (we don't deal with pbs that require + * inference of dependent types), but it seems sensible. + * + * If after cleaning, some free vars still occur, the function [restrict_hyps] + * tries to narrow the env of the evars that depend on Rels. + * + * If after that free Rels still occur it means that the instantiation + * cannot be done, as in [x:?1; y:nat; z:(le y y)] x=z + * ?1 would be instantiated by (le y y) but y is not in the scope of ?1 + *) + +let evar_define env isevars (ev,argsv) rhs = + if occur_evar ev rhs + then error_occur_check env (evars_of isevars) ev rhs; + let args = Array.to_list argsv in + let evd = ise_map isevars ev in + (* the bindings to invert *) + let worklist = make_subst (evar_env evd) args in + let body = real_clean env isevars ev worklist rhs in + ise_define isevars ev body; + [ev] + +(*-------------------*) +(* Auxiliary functions for the conversion algorithms modulo evars + *) + +let has_undefined_isevars isevars t = + try let _ = local_strong (whd_ise isevars.evars) t in false + with Uninstantiated_evar _ -> true + +let head_is_evar isevars = + let rec hrec k = match kind_of_term k with + | Evar (n,_) -> not (Evd.is_defined isevars.evars n) + | App (f,_) -> hrec f + | Cast (c,_) -> hrec c + | _ -> false + in + hrec + +let rec is_eliminator c = match kind_of_term c with + | App _ -> true + | Case _ -> true + | Cast (c,_) -> is_eliminator c + | _ -> false + +let head_is_embedded_evar isevars c = + (head_is_evar isevars c) & (is_eliminator c) + +let head_evar = + let rec hrec c = match kind_of_term c with + | Evar (ev,_) -> ev + | Case (_,_,c,_) -> hrec c + | App (c,_) -> hrec c + | Cast (c,_) -> hrec c + | _ -> failwith "headconstant" + in + hrec + +(* This code (i.e. solve_pb, etc.) takes a unification + * problem, and tries to solve it. If it solves it, then it removes + * all the conversion problems, and re-runs conversion on each one, in + * the hopes that the new solution will aid in solving them. + * + * The kinds of problems it knows how to solve are those in which + * the usable arguments of an existential var are all themselves + * universal variables. + * The solution to this problem is to do renaming for the Var's, + * to make them match up with the Var's which are found in the + * hyps of the existential, to do a "pop" for each Rel which is + * not an argument of the existential, and a subst1 for each which + * is, again, with the corresponding variable. This is done by + * evar_define + * + * Thus, we take the arguments of the existential which we are about + * to assign, and zip them with the identifiers in the hypotheses. + * Then, we process all the Var's in the arguments, and sort the + * Rel's into ascending order. Then, we just march up, doing + * subst1's and pop's. + * + * NOTE: We can do this more efficiently for the relative arguments, + * by building a long substituend by hand, but this is a pain in the + * ass. + *) + +let status_changed lev (pbty,t1,t2) = + try + List.mem (head_evar t1) lev or List.mem (head_evar t2) lev + with Failure _ -> + try List.mem (head_evar t2) lev with Failure _ -> false + +let get_changed_pb isevars lev = + let (pbs,pbs1) = + List.fold_left + (fun (pbs,pbs1) pb -> + if status_changed lev pb then + (pb::pbs,pbs1) + else + (pbs,pb::pbs1)) + ([],[]) + isevars.conv_pbs + in + isevars.conv_pbs <- pbs1; + pbs + +(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint + * definitions. We try to unify the xi with the yi pairwise. The pairs + * that don't unify are discarded (i.e. ?i is redefined so that it does not + * depend on these args). *) + +let solve_refl conv_algo env isevars ev argsv1 argsv2 = + if argsv1 = argsv2 then [] else + let evd = Evd.map isevars.evars ev in + let hyps = evd.evar_hyps in + let (_,rsign) = + array_fold_left2 + (fun (sgn,rsgn) a1 a2 -> + if conv_algo env isevars CONV a1 a2 then + (List.tl sgn, add_named_decl (List.hd sgn) rsgn) + else + (List.tl sgn, rsgn)) + (hyps,[]) argsv1 argsv2 + in + let nsign = List.rev rsign in + let nargs = (Array.of_list (List.map mkVar (ids_of_named_context nsign))) in + let newev = new_evar () in + let info = { evar_concl = evd.evar_concl; evar_hyps = nsign; + evar_body = Evar_empty } in + isevars.evars <- + Evd.define (Evd.add isevars.evars newev info) ev (mkEvar (newev,nargs)); + isevars.history <- (newev,evar_source ev isevars)::isevars.history; + [ev] + + +(* Tries to solve problem t1 = t2. + * Precondition: t1 is an uninstanciated evar + * Returns an optional list of evars that were instantiated, or None + * if the problem couldn't be solved. *) + +(* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) +let solve_simple_eqn conv_algo env isevars (pbty,(n1,args1 as ev1),t2) = + let t2 = nf_evar isevars.evars t2 in + let lsp = match kind_of_term t2 with + | Evar (n2,args2 as ev2) + when not (Evd.is_defined isevars.evars n2) -> + if n1 = n2 then + solve_refl conv_algo env isevars n1 args1 args2 + else + if Array.length args1 < Array.length args2 then + evar_define env isevars ev2 (mkEvar ev1) + else + evar_define env isevars ev1 t2 + | _ -> + evar_define env isevars ev1 t2 in + let pbs = get_changed_pb isevars lsp in + List.for_all (fun (pbty,t1,t2) -> conv_algo env isevars pbty t1 t2) pbs + +(* Operations on value/type constraints *) + +type type_constraint = constr option +type val_constraint = constr option + +(* Old comment... + * Basically, we have the following kind of constraints (in increasing + * strength order): + * (false,(None,None)) -> no constraint at all + * (true,(None,None)) -> we must build a judgement which _TYPE is a kind + * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty + * (_,(Some v,_)) -> we must build a judgement which _VAL is v + * Maybe a concrete datatype would be easier to understand. + * We differentiate (true,(None,None)) from (_,(None,Some Type)) + * because otherwise Case(s) would be misled, as in + * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead + * of Set. + *) + +(* The empty type constraint *) +let empty_tycon = None + +(* Builds a type constraint *) +let mk_tycon ty = Some ty + +(* Constrains the value of a type *) +let empty_valcon = None + +(* Builds a value constraint *) +let mk_valcon c = Some c + +(* Refining an evar to a product or a sort *) + +let refine_evar_as_arrow isevars ev = + let (sigma,prod,evdom,evrng) = split_evar_to_arrow isevars.evars ev in + evars_reset_evd sigma isevars; + let hst = evar_source (fst ev) isevars in + isevars.history <- (fst evrng,hst)::(fst evdom, hst)::isevars.history; + (prod,evdom,evrng) + +let define_evar_as_arrow isevars ev = + let (prod,_,_) = refine_evar_as_arrow isevars ev in + prod + +let define_evar_as_sort isevars (ev,args) = + let s = new_Type () in + let sigma' = Evd.define isevars.evars ev s in + evars_reset_evd sigma' isevars; + destSort s + + +(* Propagation of constraints through application and abstraction: + Given a type constraint on a functional term, returns the type + constraint on its domain and codomain. If the input constraint is + an evar instantiate it with the product of 2 new evars. *) + +let split_tycon loc env isevars = function + | None -> Anonymous,None,None + | Some c -> + let sigma = evars_of isevars in + let t = whd_betadeltaiota env sigma c in + match kind_of_term t with + | Prod (na,dom,rng) -> na, Some dom, Some rng + | Evar (n,_ as ev) when not (Evd.is_defined isevars.evars n) -> + let (_,evdom,evrng) = refine_evar_as_arrow isevars ev in + Anonymous, Some (mkEvar evdom), Some (mkEvar evrng) + | _ -> error_not_product_loc loc env sigma c + +let valcon_of_tycon x = x + +let lift_tycon = option_app (lift 1) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli new file mode 100644 index 00000000..011d2a92 --- /dev/null +++ b/pretyping/evarutil.mli @@ -0,0 +1,97 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> constr +val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment +val jl_nf_evar : + evar_map -> unsafe_judgment list -> unsafe_judgment list +val jv_nf_evar : + evar_map -> unsafe_judgment array -> unsafe_judgment array +val tj_nf_evar : + evar_map -> unsafe_type_judgment -> unsafe_type_judgment + +(* Replacing all evars *) +exception Uninstantiated_evar of existential_key +val whd_ise : evar_map -> constr -> constr +val whd_castappevar : evar_map -> constr -> constr + +(* Creating new existential variables *) +val new_evar : unit -> evar +val new_evar_in_sign : env -> constr + +val evar_env : evar_info -> env + +type evar_defs +val evars_of : evar_defs -> evar_map +val create_evar_defs : evar_map -> evar_defs +val evars_reset_evd : evar_map -> evar_defs -> unit +val evar_source : existential_key -> evar_defs -> loc * hole_kind + +type evar_constraint = conv_pb * constr * constr +val add_conv_pb : evar_defs -> evar_constraint -> unit + +val is_defined_evar : evar_defs -> existential -> bool +val ise_try : evar_defs -> (unit -> bool) list -> bool +val ise_undefined : evar_defs -> constr -> bool +val has_undefined_isevars : evar_defs -> constr -> bool + +val new_isevar_sign : + Environ.env -> Evd.evar_map -> Term.constr -> Term.constr list -> + Evd.evar_map * Term.constr + +val new_isevar : evar_defs -> env -> loc * hole_kind -> constr -> constr + +val is_eliminator : constr -> bool +val head_is_embedded_evar : evar_defs -> constr -> bool +val solve_simple_eqn : + (env -> evar_defs -> conv_pb -> constr -> constr -> bool) + -> env -> evar_defs -> conv_pb * existential * constr -> bool + +val define_evar_as_arrow : evar_defs -> existential -> types +val define_evar_as_sort : evar_defs -> existential -> sorts + +(* Value/Type constraints *) + +val new_Type_sort : unit -> sorts +val new_Type : unit -> constr +val judge_of_new_Type : unit -> unsafe_judgment +val refresh_universes : types -> types + +type type_constraint = constr option +type val_constraint = constr option + +val empty_tycon : type_constraint +val mk_tycon : constr -> type_constraint +val empty_valcon : val_constraint +val mk_valcon : constr -> val_constraint + +val split_tycon : + loc -> env -> evar_defs -> type_constraint -> + name * type_constraint * type_constraint + +val valcon_of_tycon : type_constraint -> val_constraint + +val lift_tycon : type_constraint -> type_constraint diff --git a/pretyping/evd.ml b/pretyping/evd.ml new file mode 100644 index 00000000..7a3e7c02 --- /dev/null +++ b/pretyping/evd.ml @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (ev,x)::acc) evc [] +let dom evc = Evarmap.fold (fun ev _ acc -> ev::acc) evc [] +let map evc k = Evarmap.find k evc +let rmv evc k = Evarmap.remove k evc +let remap evc k i = Evarmap.add k i evc +let in_dom evc k = Evarmap.mem k evc + +let add evd ev newinfo = Evarmap.add ev newinfo evd + +let define evd ev body = + let oldinfo = map evd ev in + let newinfo = + { evar_concl = oldinfo.evar_concl; + evar_hyps = oldinfo.evar_hyps; + evar_body = Evar_defined body} + in + match oldinfo.evar_body with + | Evar_empty -> Evarmap.add ev newinfo evd + | _ -> anomaly "cannot define an isevar twice" + +(* The list of non-instantiated existential declarations *) + +let non_instantiated sigma = + let listev = to_list sigma in + List.fold_left + (fun l ((ev,evd) as d) -> + if evd.evar_body = Evar_empty then (d::l) else l) + [] listev + +let is_evar sigma ev = in_dom sigma ev + +let is_defined sigma ev = + let info = map sigma ev in + not (info.evar_body = Evar_empty) + +let evar_body ev = ev.evar_body + +let string_of_existential ev = "?" ^ string_of_int ev + +let existential_of_int ev = ev diff --git a/pretyping/evd.mli b/pretyping/evd.mli new file mode 100644 index 00000000..f66667aa --- /dev/null +++ b/pretyping/evd.mli @@ -0,0 +1,57 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar -> evar_info -> evar_map + +val dom : evar_map -> evar list +val map : evar_map -> evar -> evar_info +val rmv : evar_map -> evar -> evar_map +val remap : evar_map -> evar -> evar_info -> evar_map +val in_dom : evar_map -> evar -> bool +val to_list : evar_map -> (evar * evar_info) list + +val define : evar_map -> evar -> constr -> evar_map + +val non_instantiated : evar_map -> (evar * evar_info) list +val is_evar : evar_map -> evar -> bool + +val is_defined : evar_map -> evar -> bool + +val evar_body : evar_info -> evar_body + +val string_of_existential : evar -> string +val existential_of_int : int -> evar diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml new file mode 100644 index 00000000..0b9283ae --- /dev/null +++ b/pretyping/indrec.ml @@ -0,0 +1,553 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mip.mind_sort <> (Prop Null) + | Some d -> d + in + if not (List.exists ((=) kind) mip.mind_kelim) then + raise + (InductiveError + (NotAllowedCaseAnalysis + (dep,(new_sort_in_family kind),ind))); + + let nbargsprod = mip.mind_nrealargs + 1 in + + (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *) + (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *) + let env' = push_rel_context lnamespar env in + + let indf = make_ind_family(ind, extended_rel_list 0 lnamespar) in + let constrs = get_constructors env indf in + + let rec add_branch env k = + if k = Array.length mip.mind_consnames then + let nbprod = k+1 in + let indf = make_ind_family(ind,extended_rel_list nbprod lnamespar) in + let lnamesar,_ = get_arity env indf in + let ci = make_default_case_info env RegularStyle ind in + let depind = build_dependent_inductive env indf in + let deparsign = (Anonymous,None,depind)::lnamesar in + let p = + it_mkLambda_or_LetIn_name env' + (appvect + (mkRel ((if dep then nbargsprod else mip.mind_nrealargs) + nbprod), + if dep then extended_rel_vect 0 deparsign + else extended_rel_vect 0 lnamesar)) + (if dep then deparsign else lnamesar) in + it_mkLambda_or_LetIn_name env' + (mkCase (ci, lift nbargsprod p, + mkRel 1, + rel_vect nbargsprod k)) + deparsign + else + let cs = lift_constructor (k+1) constrs.(k) in + let t = build_branch_type env dep (mkRel (k+1)) cs in + mkLambda_string "f" t + (add_branch (push_rel (Anonymous, None, t) env) (k+1)) + in + let typP = make_arity env' dep indf (new_sort_in_family kind) in + it_mkLambda_or_LetIn_name env + (mkLambda_string "P" typP + (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + +(* check if the type depends recursively on one of the inductive scheme *) + +(**********************************************************************) +(* Building the recursive elimination *) + +(* + * t is the type of the constructor co and recargs is the information on + * the recursive calls. (It is assumed to be in form given by the user). + * build the type of the corresponding branch of the recurrence principle + * assuming f has this type, branch_rec gives also the term + * [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of + * the case operation + * FPvect gives for each inductive definition if we want an elimination + * on it with which predicate and which recursive function. + *) + +let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = + let make_prod = make_prod_dep dep in + let nparams = List.length vargs in + let process_pos env depK pk = + let rec prec env i sign p = + let p',largs = whd_betadeltaiota_nolet_stack env sigma p in + match kind_of_term p' with + | Prod (n,t,c) -> + let d = (n,None,t) in + make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) + | LetIn (n,b,t,c) -> + let d = (n,Some b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) + | Ind (_,_) -> + let realargs = list_skipn nparams largs in + let base = applist (lift i pk,realargs) in + if depK then + Reduction.beta_appvect + base [|applist (mkRel (i+1),extended_rel_list 0 sign)|] + else + base + | _ -> assert false + in + prec env 0 [] + in + let rec process_constr env i c recargs nhyps li = + if nhyps > 0 then match kind_of_term c with + | Prod (n,t,c_0) -> + let (optionpos,rest) = + match recargs with + | [] -> None,[] + | ra::rest -> + (match dest_recarg ra with + | Mrec j when is_rec -> (depPvect.(j),rest) + | Imbr _ -> + Options.if_verbose warning "Ignoring recursive call"; + (None,rest) + | _ -> (None, rest)) + in + (match optionpos with + | None -> + make_prod env + (n,t, + process_constr (push_rel (n,None,t) env) (i+1) c_0 rest + (nhyps-1) (i::li)) + | Some(dep',p) -> + let nP = lift (i+1+decP) p in + let env' = push_rel (n,None,t) env in + let t_0 = process_pos env' dep' nP (lift 1 t) in + make_prod_dep (dep or dep') env + (n,t, + mkArrow t_0 + (process_constr + (push_rel (Anonymous,None,t_0) env') + (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) + | LetIn (n,b,t,c_0) -> + mkLetIn (n,b,t, + process_constr + (push_rel (n,Some b,t) env) + (i+1) c_0 recargs (nhyps-1) li) + | _ -> assert false + else + if dep then + let realargs = List.map (fun k -> mkRel (i-k)) (List.rev li) in + let params = List.map (lift i) vargs in + let co = applist (mkConstruct cs.cs_cstr,params@realargs) in + Reduction.beta_appvect c [|co|] + else c + in + let nhyps = List.length cs.cs_args in + let nP = match depPvect.(tyi) with + | Some(_,p) -> lift (nhyps+decP) p + | _ -> assert false in + let base = appvect (nP,cs.cs_concl_realargs) in + let c = it_mkProd_or_LetIn base cs.cs_args in + process_constr env 0 c recargs nhyps [] + +let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs = + let process_pos env fk = + let rec prec env i hyps p = + let p',largs = whd_betadeltaiota_nolet_stack env sigma p in + match kind_of_term p' with + | Prod (n,t,c) -> + let d = (n,None,t) in + lambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) + | LetIn (n,b,t,c) -> + let d = (n,Some b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) + | Ind _ -> + let realargs = list_skipn nparams largs + and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in + applist(lift i fk,realargs@[arg]) + | _ -> assert false + in + prec env 0 [] + in + (* ici, cstrprods est la liste des produits du constructeur instantié *) + let rec process_constr env i f = function + | (n,None,t as d)::cprest, recarg::rest -> + let optionpos = + match dest_recarg recarg with + | Norec -> None + | Imbr _ -> None + | Mrec i -> fvect.(i) + in + (match optionpos with + | None -> + lambda_name env + (n,t,process_constr (push_rel d env) (i+1) + (whd_beta (applist (lift 1 f, [(mkRel 1)]))) + (cprest,rest)) + | Some(_,f_0) -> + let nF = lift (i+1+decF) f_0 in + let env' = push_rel d env in + let arg = process_pos env' nF (lift 1 t) in + lambda_name env + (n,t,process_constr env' (i+1) + (whd_beta (applist (lift 1 f, [(mkRel 1); arg]))) + (cprest,rest))) + | (n,Some c,t as d)::cprest, rest -> + mkLetIn + (n,c,t, + process_constr (push_rel d env) (i+1) (lift 1 f) + (cprest,rest)) + | [],[] -> f + | _,[] | [],_ -> anomaly "process_constr" + + in + process_constr env 0 f (List.rev cstr.cs_args, recargs) + +(* Main function *) +let mis_make_indrec env sigma listdepkind (ind,mib,mip) = + let nparams = mip.mind_nparams in + let lnamespar = mip.mind_params_ctxt in + let nrec = List.length listdepkind in + let depPvec = + Array.create mib.mind_ntypes (None : (bool * constr) option) in + let _ = + let rec + assign k = function + | [] -> () + | (indi,mibi,mipi,dep,_)::rest -> + (Array.set depPvec (snd indi) (Some(dep,mkRel k)); + assign (k-1) rest) + in + assign nrec listdepkind in + let recargsvec = + Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in + let make_one_rec p = + let makefix nbconstruct = + let rec mrec i ln ltyp ldef = function + | (indi,mibi,mipi,dep,_)::rest -> + let tyi = snd indi in + let nctyi = + Array.length mipi.mind_consnames in (* nb constructeurs du type*) + + (* arity in the context of the fixpoint, i.e. + P1..P_nrec f1..f_nbconstruct *) + let args = extended_rel_list (nrec+nbconstruct) lnamespar in + let indf = make_ind_family(indi,args) in + let lnames,_ = get_arity env indf in + + let nar = mipi.mind_nrealargs in + let dect = nar+nrec+nbconstruct in + + let branches = + (* constructors in context of the Cases expr, i.e. + P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) + let args' = extended_rel_list (dect+nrec+1) lnamespar in + let indf' = make_ind_family(indi,args') in + let constrs = get_constructors env indf' in + let vecfi = rel_vect (dect+1-i-nctyi) nctyi in + array_map3 + (make_rec_branch_arg env sigma (nparams,depPvec,nar+1)) + vecfi constrs (dest_subterms recargsvec.(tyi)) in + let j = (match depPvec.(tyi) with + | Some (_,c) when isRel c -> destRel c + | _ -> assert false) in + let deftyi = + let ci = make_default_case_info env RegularStyle indi in + let indf' = lift_inductive_family nrec indf in + let depind = build_dependent_inductive env indf' in + let lnames' = Termops.lift_rel_context nrec lnames in + let p = + let arsign = + if dep then (Anonymous,None,depind)::lnames' else lnames' in + it_mkLambda_or_LetIn_name env + (appvect + (mkRel ((if dep then 1 else 0) + dect + j), + extended_rel_vect 0 arsign)) arsign + in + it_mkLambda_or_LetIn_name env + (lambda_create env + (depind,mkCase (ci, lift (nar+1) p, mkRel 1, branches))) + lnames' + in + let typtyi = + let ind = build_dependent_inductive env indf in + it_mkProd_or_LetIn_name env + (prod_create env + (ind, + (if dep then + let ext_lnames = (Anonymous,None,ind)::lnames in + let args = extended_rel_list 0 ext_lnames in + applist (mkRel (nbconstruct+nar+j+1), args) + else + let args = extended_rel_list 1 lnames in + applist (mkRel (nbconstruct+nar+j+1), args)))) + lnames + in + mrec (i+nctyi) (nar::ln) (typtyi::ltyp) (deftyi::ldef) rest + | [] -> + let fixn = Array.of_list (List.rev ln) in + let fixtyi = Array.of_list (List.rev ltyp) in + let fixdef = Array.of_list (List.rev ldef) in + let names = Array.create nrec (Name(id_of_string "F")) in + mkFix ((fixn,p),(names,fixtyi,fixdef)) + in + mrec 0 [] [] [] + in + let rec make_branch env i = function + | (indi,mibi,mipi,dep,_)::rest -> + let tyi = snd indi in + let nconstr = Array.length mipi.mind_consnames in + let rec onerec env j = + if j = nconstr then + make_branch env (i+j) rest + else + let recarg = (dest_subterms recargsvec.(tyi)).(j) in + let vargs = extended_rel_list (nrec+i+j) lnamespar in + let indf = (indi, vargs) in + let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in + let p_0 = + type_rec_branch + true dep env sigma (vargs,depPvec,i+j) tyi cs recarg + in + mkLambda_string "f" p_0 + (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) + in onerec env 0 + | [] -> + makefix i listdepkind + in + let rec put_arity env i = function + | (indi,_,_,dep,kinds)::rest -> + let indf = make_ind_family (indi,extended_rel_list i lnamespar) in + let typP = make_arity env dep indf (new_sort_in_family kinds) in + mkLambda_string "P" typP + (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) + | [] -> + make_branch env 0 listdepkind + in + let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in + let env' = push_rel_context lnamespar env in + if mis_is_recursive_subset + (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) + mipi.mind_recargs + then + it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamespar + else + mis_make_case_com (Some dep) env sigma (indi,mibi,mipi) kind + in + list_tabulate make_one_rec nrec + +(**********************************************************************) +(* This builds elimination predicate for Case tactic *) + +let make_case_com depopt env sigma ity kind = + let (mib,mip) = lookup_mind_specif env ity in + mis_make_case_com depopt env sigma (ity,mib,mip) kind + +let make_case_dep env = make_case_com (Some true) env +let make_case_nodep env = make_case_com (Some false) env +let make_case_gen env = make_case_com None env + + +(**********************************************************************) +(* [instanciate_indrec_scheme s rec] replace the sort of the scheme + [rec] by [s] *) + +let change_sort_arity sort = + let rec drec a = match kind_of_term a with + | Cast (c,t) -> drec c + | Prod (n,t,c) -> mkProd (n, t, drec c) + | Sort _ -> mkSort sort + | _ -> assert false + in + drec + +(* [npar] is the number of expected arguments (then excluding letin's) *) +let instanciate_indrec_scheme sort = + let rec drec npar elim = + match kind_of_term elim with + | Lambda (n,t,c) -> + if npar = 0 then + mkLambda (n, change_sort_arity sort t, c) + else + mkLambda (n, t, drec (npar-1) c) + | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) + | _ -> anomaly "instanciate_indrec_scheme: wrong elimination type" + in + drec + +(* Change the sort in the type of an inductive definition, builds the + corresponding eta-expanded term *) +let instanciate_type_indrec_scheme sort npars term = + let rec drec np elim = + match kind_of_term elim with + | Prod (n,t,c) -> + if np = 0 then + let t' = change_sort_arity sort t in + mkProd (n, t', c), + mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) + else + let c',term' = drec (np-1) c in + mkProd (n, t, c'), mkLambda (n, t, term') + | LetIn (n,b,t,c) -> let c',term' = drec np c in + mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') + | _ -> anomaly "instanciate_type_indrec_scheme: wrong elimination type" + in + drec npars + +(**********************************************************************) +(* Interface to build complex Scheme *) + +let check_arities listdepkind = + List.iter + (function (indi,mibi,mipi,dep,kind) -> + let id = mipi.mind_typename in + let kelim = mipi.mind_kelim in + if not (List.exists ((=) kind) kelim) then + raise + (InductiveError (BadInduction (dep, id, new_sort_in_family kind)))) + listdepkind + +let build_mutual_indrec env sigma = function + | (mind,mib,mip,dep,s)::lrecspec -> + let (sp,tyi) = mind in + let listdepkind = + (mind,mib,mip, dep,s):: + (List.map + (function (mind',mibi',mipi',dep',s') -> + let (sp',_) = mind' in + if sp=sp' then + let (mibi',mipi') = lookup_mind_specif env mind' in + (mind',mibi',mipi',dep',s') + else + raise (InductiveError NotMutualInScheme)) + lrecspec) + in + let _ = check_arities listdepkind in + mis_make_indrec env sigma listdepkind (mind,mib,mip) + | _ -> anomaly "build_indrec expects a non empty list of inductive types" + +let build_indrec env sigma ind = + let (mib,mip) = lookup_mind_specif env ind in + let kind = family_of_sort mip.mind_sort in + let dep = kind <> InProp in + List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] (ind,mib,mip)) + +(**********************************************************************) +(* To handle old Case/Match syntax in Pretyping *) + +(*****************************************) +(* To interpret Case and Match operators *) +(* Expects a dependent predicate *) + +let type_rec_branches recursive env sigma indt p c = + let IndType (indf,realargs) = indt in + let (ind,params) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let recargs = mip.mind_recargs in + let tyi = snd ind in + let init_depPvec i = if i = tyi then Some(true,p) else None in + let depPvec = Array.init mib.mind_ntypes init_depPvec in + let vargs = Array.of_list params in + let constructors = get_constructors env indf in + let lft = + array_map2 + (type_rec_branch recursive true env sigma (params,depPvec,0) tyi) + constructors (dest_subterms recargs) in + (lft,Reduction.beta_appvect p (Array.of_list (realargs@[c]))) +(* Non recursive case. Pb: does not deal with unification + let (p,ra,_) = type_case_branches env (ind,params@realargs) pj c in + (p,ra) +*) + +(*s Eliminations. *) + +let elimination_suffix = function + | InProp -> "_ind" + | InSet -> "_rec" + | InType -> "_rect" + +let make_elimination_ident id s = add_suffix id (elimination_suffix s) + +(* Look up function for the default elimination constant *) + +let lookup_eliminator ind_sp s = + let kn,i = ind_sp in + let mp,dp,l = repr_kn kn in + let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in + let id = add_suffix ind_id (elimination_suffix s) in + (* Try first to get an eliminator defined in the same section as the *) + (* inductive type *) + let ref = ConstRef (make_kn mp dp (label_of_id id)) in + try + let _ = sp_of_global ref in + constr_of_reference ref + with Not_found -> + (* Then try to get a user-defined eliminator in some other places *) + (* using short name (e.g. for "eq_rec") *) + try constr_of_reference (Nametab.locate (make_short_qualid id)) + with Not_found -> + errorlabstrm "default_elim" + (str "Cannot find the elimination combinator " ++ + pr_id id ++ spc () ++ + str "The elimination of the inductive definition " ++ + pr_id id ++ spc () ++ str "on sort " ++ + spc () ++ print_sort_family s ++ + str " is probably not allowed") + + +(* let env = Global.env() in + let path = sp_of_global None (IndRef ind_sp) in + let dir, base = repr_path path in + let id = add_suffix base (elimination_suffix s) in + (* Try first to get an eliminator defined in the same section as the *) + (* inductive type *) + try construct_absolute_reference (Names.make_path dir id) + with Not_found -> + (* Then try to get a user-defined eliminator in some other places *) + (* using short name (e.g. for "eq_rec") *) + try constr_of_reference (Nametab.locate (make_short_qualid id)) + with Not_found -> + errorlabstrm "default_elim" + (str "Cannot find the elimination combinator " ++ + pr_id id ++ spc () ++ + str "The elimination of the inductive definition " ++ + pr_id base ++ spc () ++ str "on sort " ++ + spc () ++ print_sort_family s ++ + str " is probably not allowed") +*) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli new file mode 100644 index 00000000..f6f76706 --- /dev/null +++ b/pretyping/indrec.mli @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_map -> inductive -> sorts_family -> constr +val make_case_nodep : env -> evar_map -> inductive -> sorts_family -> constr +val make_case_gen : env -> evar_map -> inductive -> sorts_family -> constr + +(* This builds an elimination scheme associated (using the own arity + of the inductive) *) + +val build_indrec : env -> evar_map -> inductive -> constr +val instanciate_indrec_scheme : sorts -> int -> constr -> constr +val instanciate_type_indrec_scheme : sorts -> int -> constr -> types -> + constr * types + +(* This builds complex [Scheme] *) + +val build_mutual_indrec : + env -> evar_map -> + (inductive * mutual_inductive_body * one_inductive_body + * bool * sorts_family) list + -> constr list + +(* These are for old Case/Match typing *) + +val type_rec_branches : bool -> env -> evar_map -> inductive_type + -> constr -> constr -> constr array * constr +val make_rec_branch_arg : + env -> evar_map -> + int * ('b * constr) option array * int -> + constr -> constructor_summary -> wf_paths list -> constr + +(* *) +val lookup_eliminator : inductive -> sorts_family -> constr +val elimination_suffix : sorts_family -> string +val make_elimination_ident : identifier -> sorts_family -> identifier diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml new file mode 100644 index 00000000..24a8fbc7 --- /dev/null +++ b/pretyping/inductiveops.ml @@ -0,0 +1,352 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + match dest_recarg ra with + | Mrec i -> List.mem i listind + | _ -> false) rvec + in + array_exists one_is_rec (dest_subterms rarg) + +let mis_is_recursive (ind,mib,mip) = + mis_is_recursive_subset (interval 0 (mib.mind_ntypes-1)) + mip.mind_recargs + +let mis_nf_constructor_type (ind,mib,mip) j = + let specif = mip.mind_nf_lc + and ntypes = mib.mind_ntypes + and nconstr = Array.length mip.mind_consnames in + let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + if j > nconstr then error "Not enough constructors in the type"; + substl (list_tabulate make_Ik ntypes) specif.(j-1) + +(* Arity of constructors excluding parameters and local defs *) +let mis_constr_nargs indsp = + let (mib,mip) = Global.lookup_inductive indsp in + let recargs = dest_subterms mip.mind_recargs in + Array.map List.length recargs + +let mis_constr_nargs_env env (kn,i) = + let mib = Environ.lookup_mind kn env in + let mip = mib.mind_packets.(i) in + let recargs = dest_subterms mip.mind_recargs in + Array.map List.length recargs + +let mis_constructor_nargs_env env ((kn,i),j) = + let mib = Environ.lookup_mind kn env in + let mip = mib.mind_packets.(i) in + recarg_length mip.mind_recargs j + mip.mind_nparams + +(* Annotation for cases *) +let make_case_info env ind style pats_source = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let print_info = + { ind_nargs = mip.mind_nrealargs; + style = style; + source = pats_source } in + { ci_ind = ind; + ci_npar = mip.mind_nparams; + ci_pp_info = print_info } + +let make_default_case_info env style ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + make_case_info env ind style + (Array.map (fun _ -> RegularPat) mip.mind_consnames) + +(*s Useful functions *) + +type constructor_summary = { + cs_cstr : constructor; + cs_params : constr list; + cs_nargs : int; + cs_args : rel_context; + cs_concl_realargs : constr array +} + +let lift_constructor n cs = { + cs_cstr = cs.cs_cstr; + cs_params = List.map (lift n) cs.cs_params; + cs_nargs = cs.cs_nargs; + cs_args = lift_rel_context n cs.cs_args; + cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs +} + +let instantiate_params t args sign = + let rec inst s t = function + | ((_,None,_)::ctxt,a::args) -> + (match kind_of_term t with + | Prod(_,_,t) -> inst (a::s) t (ctxt,args) + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") + | ((_,(Some b),_)::ctxt,args) -> + (match kind_of_term t with + | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") + | [], [] -> substl s t + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch" + in inst [] t (List.rev sign,args) + +let get_constructor (ind,mib,mip,params) j = + assert (j <= Array.length mip.mind_consnames); + let typi = mis_nf_constructor_type (ind,mib,mip) j in + let typi = instantiate_params typi params mip.mind_params_ctxt in + let (args,ccl) = decompose_prod_assum typi in + let (_,allargs) = decompose_app ccl in + let vargs = list_skipn mip.mind_nparams allargs in + { cs_cstr = ith_constructor_of_inductive ind j; + cs_params = params; + cs_nargs = rel_context_length args; + cs_args = args; + cs_concl_realargs = Array.of_list vargs } + +let get_constructors env (ind,params) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Array.init (Array.length mip.mind_consnames) + (fun j -> get_constructor (ind,mib,mip,params) (j+1)) + +let rec instantiate args c = match kind_of_term c, args with + | Prod (_,_,c), a::args -> instantiate args (subst1 a c) + | LetIn (_,b,_,c), args -> instantiate args (subst1 b c) + | _, [] -> c + | _ -> anomaly "too short arity" + +let get_arity env (ind,params) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let arity = mip.mind_nf_arity in + destArity (instantiate params arity) + +(* Functions to build standard types related to inductive *) +let build_dependent_constructor cs = + applist + (mkConstruct cs.cs_cstr, + (List.map (lift cs.cs_nargs) cs.cs_params) + @(extended_rel_list 0 cs.cs_args)) + +let build_dependent_inductive env ((ind, params) as indf) = + let arsign,_ = get_arity env indf in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nrealargs = mip.mind_nrealargs in + applist + (mkInd ind, + (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) + +(* builds the arity of an elimination predicate in sort [s] *) + +let make_arity_signature env dep indf = + let (arsign,_) = get_arity env indf in + if dep then + (* We need names everywhere *) + name_context env + ((Anonymous,None,build_dependent_inductive env indf)::arsign) + (* Costly: would be better to name one for all at definition time *) + else + (* No need to enforce names *) + arsign + +let make_arity env dep indf s = mkArity (make_arity_signature env dep indf, s) + +(* [p] is the predicate and [cs] a constructor summary *) +let build_branch_type env dep p cs = + let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in + if dep then + it_mkProd_or_LetIn_name env + (applist (base,[build_dependent_constructor cs])) + cs.cs_args + else + it_mkProd_or_LetIn base cs.cs_args + +(**************************************************) + +let extract_mrectype t = + let (t, l) = decompose_app t in + match kind_of_term t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +let find_mrectype env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +let find_rectype env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind -> + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let (par,rargs) = list_chop mip.mind_nparams l in + IndType((ind, par),rargs) + | _ -> raise Not_found + +let find_inductive env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind + when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + (ind, l) + | _ -> raise Not_found + +let find_coinductive env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind + when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + (ind, l) + | _ -> raise Not_found + + +(***********************************************) +(* find appropriate names for pattern variables. Useful in the + Case tactic. *) + +let is_dep_predicate env kelim pred nodep_ar = + let rec srec env pval pt nodep_ar = + let pt' = whd_betadeltaiota env Evd.empty pt in + let pv' = whd_betadeltaiota env Evd.empty pval in + match kind_of_term pv', kind_of_term pt', kind_of_term nodep_ar with + | Lambda (na,t,b), Prod (_,_,a), Prod (_,_,a') -> + srec (push_rel_assum (na,t) env) b a a' + | _, Prod (na,t,a), Prod (_,_,a') -> + srec (push_rel_assum (na,t) env) (lift 1 pv') a a' + | Lambda (_,_,b), Prod (_,_,_), _ -> (*dependent (mkRel 1) b*) true + | _, Prod (_,_,_), _ -> true + | _ -> false in + srec env pred.uj_val pred.uj_type nodep_ar + +let is_dependent_elimination_predicate env pred indf = + let (ind,params) = indf in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let kelim = mip.mind_kelim in + let arsign,s = get_arity env indf in + let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in + is_dep_predicate env kelim pred glob_t + +let is_dep_arity env kelim predty nodep_ar = + let rec srec pt nodep_ar = + let pt' = whd_betadeltaiota env Evd.empty pt in + match kind_of_term pt', kind_of_term nodep_ar with + | Prod (_,a1,a2), Prod (_,a1',a2') -> srec a2 a2' + | Prod (_,a1,a2), _ -> true + | _ -> false in + srec predty nodep_ar + +let is_dependent_elimination env predty indf = + let (ind,params) = indf in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let kelim = mip.mind_kelim in + let arsign,s = get_arity env indf in + let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in + is_dep_arity env kelim predty glob_t + +let set_names env n brty = + let (ctxt,cl) = decompose_prod_n_assum n brty in + it_mkProd_or_LetIn_name env cl ctxt + +let set_pattern_names env ind brv = + let (_,mip) = Inductive.lookup_mind_specif env ind in + let arities = + Array.map + (fun c -> + rel_context_length (fst (decompose_prod_assum c)) - + mip.mind_nparams) + mip.mind_nf_lc in + array_map2 (set_names env) arities brv + + +let type_case_branches_with_names env indspec pj c = + let (ind,args) = indspec in + let (lbrty,conclty,_) = Inductive.type_case_branches env indspec pj c in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let params = list_firstn mip.mind_nparams args in + if is_dependent_elimination_predicate env pj (ind,params) then + (set_pattern_names env ind lbrty, conclty) + else (lbrty, conclty) + +(* Type of Case predicates *) +let arity_of_case_predicate env (ind,params) dep k = + let arsign,_ = get_arity env (ind,params) in + let mind = build_dependent_inductive env (ind,params) in + let concl = if dep then mkArrow mind (mkSort k) else mkSort k in + it_mkProd_or_LetIn concl arsign + +(***********************************************) +(* Guard condition *) + +(* A function which checks that a term well typed verifies both + syntactic conditions *) + +let control_only_guard env = + let rec control_rec c = match kind_of_term c with + | Rel _ | Var _ -> () + | Sort _ | Meta _ -> () + | Ind _ -> () + | Construct _ -> () + | Const _ -> () + | CoFix (_,(_,tys,bds) as cofix) -> + Inductive.check_cofix env cofix; + Array.iter control_rec tys; + Array.iter control_rec bds; + | Fix (_,(_,tys,bds) as fix) -> + Inductive.check_fix env fix; + Array.iter control_rec tys; + Array.iter control_rec bds; + | Case(_,p,c,b) ->control_rec p;control_rec c;Array.iter control_rec b + | Evar (_,cl) -> Array.iter control_rec cl + | App (_,cl) -> Array.iter control_rec cl + | Cast (c1,c2) -> control_rec c1; control_rec c2 + | Prod (_,c1,c2) -> control_rec c1; control_rec c2 + | Lambda (_,c1,c2) -> control_rec c1; control_rec c2 + | LetIn (_,c1,c2,c3) -> control_rec c1; control_rec c2; control_rec c3 + in + control_rec diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli new file mode 100644 index 00000000..a8dcef29 --- /dev/null +++ b/pretyping/inductiveops.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* inductive_family +val dest_ind_family : inductive_family -> inductive * constr list +val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family +val liftn_inductive_family : int -> int -> inductive_family -> inductive_family +val lift_inductive_family : int -> inductive_family -> inductive_family +val substnl_ind_family : + constr list -> int -> inductive_family -> inductive_family + +(* An inductive type with its parameters and real arguments *) +type inductive_type = IndType of inductive_family * constr list +val make_ind_type : inductive_family * constr list -> inductive_type +val dest_ind_type : inductive_type -> inductive_family * constr list +val map_inductive_type : (constr -> constr) -> inductive_type -> inductive_type +val liftn_inductive_type : int -> int -> inductive_type -> inductive_type +val lift_inductive_type : int -> inductive_type -> inductive_type +val substnl_ind_type : + constr list -> int -> inductive_type -> inductive_type + +val mkAppliedInd : inductive_type -> constr +val mis_is_recursive_subset : int list -> wf_paths -> bool +val mis_is_recursive : + inductive * mutual_inductive_body * one_inductive_body -> bool +val mis_nf_constructor_type : + inductive * mutual_inductive_body * one_inductive_body -> int -> constr +val mis_constr_nargs : inductive -> int array + +val mis_constr_nargs_env : env -> inductive -> int array + +val mis_constructor_nargs_env : env -> constructor -> int + +type constructor_summary = { + cs_cstr : constructor; + cs_params : constr list; + cs_nargs : int; + cs_args : Sign.rel_context; + cs_concl_realargs : constr array; +} +val lift_constructor : int -> constructor_summary -> constructor_summary +val get_constructor : + inductive * mutual_inductive_body * one_inductive_body * constr list -> + int -> constructor_summary +val get_arity : env -> inductive_family -> Sign.arity +val get_constructors : env -> inductive_family -> constructor_summary array +val build_dependent_constructor : constructor_summary -> constr +val build_dependent_inductive : env -> inductive_family -> constr +val make_arity_signature : + env -> bool -> inductive_family -> Sign.rel_context +val make_arity : env -> bool -> inductive_family -> sorts -> types +val build_branch_type : env -> bool -> constr -> constructor_summary -> types + +(* Raise Not_found if not given an valid inductive type *) +val extract_mrectype : constr -> inductive * constr list +val find_mrectype : env -> evar_map -> constr -> inductive * constr list +val find_rectype : env -> evar_map -> constr -> inductive_type +val find_inductive : env -> evar_map -> constr -> inductive * constr list +val find_coinductive : env -> evar_map -> constr -> inductive * constr list + +(********************) +(* Determines if a case predicate type corresponds to dependent elimination *) +val is_dependent_elimination : + env -> types -> inductive_family -> bool + +(* Builds the case predicate arity (dependent or not) *) +val arity_of_case_predicate : + env -> inductive_family -> bool -> sorts -> types + +val type_case_branches_with_names : + env -> inductive * constr list -> unsafe_judgment -> constr -> + types array * types +val make_case_info : + env -> inductive -> case_style -> pattern_source array -> case_info +val make_default_case_info : env -> case_style -> inductive -> case_info + +(********************) +val control_only_guard : env -> types -> unit diff --git a/pretyping/instantiate.ml b/pretyping/instantiate.ml new file mode 100644 index 00000000..702cdfea --- /dev/null +++ b/pretyping/instantiate.ml @@ -0,0 +1,68 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* id = id' + | _ -> false + in + List.for_all is_id inst + +(* Vérifier que les instances des let-in sont compatibles ?? *) +let instantiate_sign_including_let sign args = + let rec instrec = function + | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args)) + | ([],[]) -> [] + | ([],_) | (_,[]) -> + anomaly "Signature and its instance do not match" + in + instrec (sign,args) + +let instantiate_evar sign c args = + let inst = instantiate_sign_including_let sign args in + if is_id_inst inst then + c + else + replace_vars inst c + +(* Existentials. *) + +let existential_type sigma (n,args) = + let info = + try Evd.map sigma n + with Not_found -> + anomaly ("Evar "^(string_of_existential n)^" was not declared") in + let hyps = info.evar_hyps in + instantiate_evar hyps info.evar_concl (Array.to_list args) + +exception NotInstantiatedEvar + +let existential_value sigma (n,args) = + let info = Evd.map sigma n in + let hyps = info.evar_hyps in + match evar_body info with + | Evar_defined c -> + instantiate_evar hyps c (Array.to_list args) + | Evar_empty -> + raise NotInstantiatedEvar + +let existential_opt_value sigma ev = + try Some (existential_value sigma ev) + with NotInstantiatedEvar -> None + diff --git a/pretyping/instantiate.mli b/pretyping/instantiate.mli new file mode 100644 index 00000000..44c4d579 --- /dev/null +++ b/pretyping/instantiate.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* existential -> constr +val existential_type : evar_map -> existential -> types +val existential_opt_value : evar_map -> existential -> constr option diff --git a/pretyping/matching.ml b/pretyping/matching.ml new file mode 100644 index 00000000..bdab3b5b --- /dev/null +++ b/pretyping/matching.ml @@ -0,0 +1,254 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* m + | (n, (na,t)::tl) -> + if List.mem n toabstract then + buildrec (mkLambda (na,t,m)) (n+1) tl + else + buildrec (lift (-1) m) (n+1) tl + in + buildrec m 1 stk + +let memb_metavars m n = + match (m,n) with + | (None, _) -> true + | (Some mvs, n) -> List.mem n mvs + +let eq_context ctxt1 ctxt2 = array_for_all2 eq_constr ctxt1 ctxt2 + +let matches_core convert allow_partial_app pat c = + let rec sorec stk sigma p t = + let cT = strip_outer_cast t in + match p,kind_of_term cT with + | PSoApp (n,args),m -> + let relargs = + List.map + (function + | PRel n -> n + | _ -> error "Only bound indices are currently allowed in second order pattern matching") + args in + let frels = Intset.elements (free_rels cT) in + if list_subset frels relargs then + constrain (n,build_lambda relargs stk cT) sigma + else + raise PatternMatchingFailure + + | PMeta (Some n), m -> + let depth = List.length stk in + let frels = Intset.elements (free_rels cT) in + if List.for_all (fun i -> i > depth) frels then + constrain (n,lift (-depth) cT) sigma + else + raise PatternMatchingFailure + + | PMeta None, m -> sigma + + | PRef (VarRef v1), Var v2 when v1 = v2 -> sigma + + | PVar v1, Var v2 when v1 = v2 -> sigma + + | PRef ref, _ when constr_of_reference ref = cT -> sigma + + | PRel n1, Rel n2 when n1 = n2 -> sigma + + | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> sigma + + | PSort (RType _), Sort (Type _) -> sigma + + | PApp (PMeta (Some n),args1), App (c2,args2) when allow_partial_app -> + let p = Array.length args2 - Array.length args1 in + if p>=0 then + let args21, args22 = array_chop p args2 in + let sigma = + let depth = List.length stk in + let c = mkApp(c2,args21) in + let frels = Intset.elements (free_rels c) in + if List.for_all (fun i -> i > depth) frels then + constrain (n,lift (-depth) c) sigma + else + raise PatternMatchingFailure in + array_fold_left2 (sorec stk) sigma args1 args22 + else raise PatternMatchingFailure + + | PApp (c1,arg1), App (c2,arg2) -> + (try array_fold_left2 (sorec stk) (sorec stk sigma c1 c2) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure) + + | PProd (na1,c1,d1), Prod(na2,c2,d2) -> + sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 + + | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> + sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 + + | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> + sorec ((na2,t2)::stk) (sorec stk sigma c1 c2) d1 d2 + + | PRef (ConstRef _ as ref), _ when convert <> None -> + let (env,evars) = out_some convert in + let c = constr_of_reference ref in + if is_conv env evars c cT then sigma + else raise PatternMatchingFailure + + | PCase (_,_,a1,br1), Case (_,_,a2,br2) -> + (* On ne teste pas le prédicat *) + if (Array.length br1) = (Array.length br2) then + array_fold_left2 (sorec stk) (sorec stk sigma a1 a2) br1 br2 + else + raise PatternMatchingFailure + (* À faire *) + | PFix f0, Fix f1 when f0 = f1 -> sigma + | PCoFix c0, CoFix c1 when c0 = c1 -> sigma + | _ -> raise PatternMatchingFailure + + in + Sort.list (fun (a,_) (b,_) -> a closed0 c) (fst mres)) then + raise PatternMatchingFailure; + if nocc = 0 then mres + else raise (NextOccurrence nocc) + +let special_meta = (-1) + +(* Tries to match a subterm of [c] with [pat] *) +let rec sub_match nocc pat c = + match kind_of_term c with + | Cast (c1,c2) -> + (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with + | PatternMatchingFailure -> + let (lm,lc) = try_sub_match nocc pat [c1] in + (lm,mkCast (List.hd lc, c2)) + | NextOccurrence nocc -> + let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in + (lm,mkCast (List.hd lc, c2))) + | Lambda (x,c1,c2) -> + (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with + | PatternMatchingFailure -> + let (lm,lc) = try_sub_match nocc pat [c1;c2] in + (lm,mkLambda (x,List.hd lc,List.nth lc 1)) + | NextOccurrence nocc -> + let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in + (lm,mkLambda (x,List.hd lc,List.nth lc 1))) + | Prod (x,c1,c2) -> + (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with + | PatternMatchingFailure -> + let (lm,lc) = try_sub_match nocc pat [c1;c2] in + (lm,mkProd (x,List.hd lc,List.nth lc 1)) + | NextOccurrence nocc -> + let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in + (lm,mkProd (x,List.hd lc,List.nth lc 1))) + | LetIn (x,c1,t2,c2) -> + (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with + | PatternMatchingFailure -> + let (lm,lc) = try_sub_match nocc pat [c1;t2;c2] in + (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2)) + | NextOccurrence nocc -> + let (lm,lc) = try_sub_match (nocc - 1) pat [c1;t2;c2] in + (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2))) + | App (c1,lc) -> + (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with + | PatternMatchingFailure -> + let (lm,le) = try_sub_match nocc pat (c1::(Array.to_list lc)) in + (lm,mkApp (List.hd le, Array.of_list (List.tl le))) + | NextOccurrence nocc -> + let (lm,le) = try_sub_match (nocc - 1) pat (c1::(Array.to_list lc)) in + (lm,mkApp (List.hd le, Array.of_list (List.tl le)))) + | Case (ci,hd,c1,lc) -> + (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with + | PatternMatchingFailure -> + let (lm,le) = try_sub_match nocc pat (c1::Array.to_list lc) in + (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) + | NextOccurrence nocc -> + let (lm,le) = try_sub_match (nocc - 1) pat (c1::Array.to_list lc) in + (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le)))) + | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _ + | Rel _|Meta _|Var _|Sort _ -> + (try authorized_occ nocc ((matches pat c),mkMeta special_meta) with + | PatternMatchingFailure -> raise (NextOccurrence nocc) + | NextOccurrence nocc -> raise (NextOccurrence (nocc - 1))) + +(* Tries [sub_match] for all terms in the list *) +and try_sub_match nocc pat lc = + let rec try_sub_match_rec nocc pat lacc = function + | [] -> raise (NextOccurrence nocc) + | c::tl -> + (try + let (lm,ce) = sub_match nocc pat c in + (lm,lacc@(ce::tl)) + with + | NextOccurrence nocc -> try_sub_match_rec nocc pat (lacc@[c]) tl) in + try_sub_match_rec nocc pat [] lc + +let is_matching pat n = + try let _ = matches pat n in true + with PatternMatchingFailure -> false + +let matches_conv env sigma = matches_core (Some (env,sigma)) false + +let is_matching_conv env sigma pat n = + try let _ = matches_conv env sigma pat n in true + with PatternMatchingFailure -> false + diff --git a/pretyping/matching.mli b/pretyping/matching.mli new file mode 100644 index 00000000..808c46a4 --- /dev/null +++ b/pretyping/matching.mli @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> patvar_map + +(* [is_matching pat c] just tells if [c] matches against [pat] *) + +val is_matching : constr_pattern -> constr -> bool + +(* [matches_conv env sigma] matches up to conversion in environment + [(env,sigma)] when constants in pattern are concerned; it raises + [PatternMatchingFailure] if not matchable; bindings are given in + increasing order based on the numbers given in the pattern *) + +val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map + +(* To skip to the next occurrence *) +exception NextOccurrence of int + +(* Tries to match a _closed_ subterm of [c] with [pat] *) +val sub_match : int -> constr_pattern -> constr -> patvar_map * constr + +(* [is_matching_conv env sigma pat c] tells if [c] matches against [pat] + up to conversion for constants in patterns *) + +val is_matching_conv : + env -> Evd.evar_map -> constr_pattern -> constr -> bool diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml new file mode 100644 index 00000000..80ab1b6e --- /dev/null +++ b/pretyping/pattern.ml @@ -0,0 +1,287 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (occur_meta_pattern f) or (array_exists occur_meta_pattern args) + | PLambda (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) + | PProd (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) + | PLetIn (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) + | PCase(_,None,c,br) -> + (occur_meta_pattern c) or (array_exists occur_meta_pattern br) + | PCase(_,Some p,c,br) -> + (occur_meta_pattern p) or + (occur_meta_pattern c) or (array_exists occur_meta_pattern br) + | PMeta _ | PSoApp _ -> true + | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false + +let rec subst_pattern subst pat = match pat with + | PRef ref -> + let ref' = subst_global subst ref in + if ref' == ref then pat else + PRef ref' + | PVar _ + | PEvar _ + | PRel _ -> pat + | PApp (f,args) -> + let f' = subst_pattern subst f in + let args' = array_smartmap (subst_pattern subst) args in + if f' == f && args' == args then pat else + PApp (f',args') + | PSoApp (i,args) -> + let args' = list_smartmap (subst_pattern subst) args in + if args' == args then pat else + PSoApp (i,args') + | PLambda (name,c1,c2) -> + let c1' = subst_pattern subst c1 in + let c2' = subst_pattern subst c2 in + if c1' == c1 && c2' == c2 then pat else + PLambda (name,c1',c2') + | PProd (name,c1,c2) -> + let c1' = subst_pattern subst c1 in + let c2' = subst_pattern subst c2 in + if c1' == c1 && c2' == c2 then pat else + PProd (name,c1',c2') + | PLetIn (name,c1,c2) -> + let c1' = subst_pattern subst c1 in + let c2' = subst_pattern subst c2 in + if c1' == c1 && c2' == c2 then pat else + PLetIn (name,c1',c2') + | PSort _ + | PMeta _ -> pat + | PCase (cs,typ, c, branches) -> + let typ' = option_smartmap (subst_pattern subst) typ in + let c' = subst_pattern subst c in + let branches' = array_smartmap (subst_pattern subst) branches in + if typ' == typ && c' == c && branches' == branches then pat else + PCase(cs,typ', c', branches') + | PFix fixpoint -> + let cstr = mkFix fixpoint in + let fixpoint' = destFix (subst_mps subst cstr) in + if fixpoint' == fixpoint then pat else + PFix fixpoint' + | PCoFix cofixpoint -> + let cstr = mkCoFix cofixpoint in + let cofixpoint' = destCoFix (subst_mps subst cstr) in + if cofixpoint' == cofixpoint then pat else + PCoFix cofixpoint' + +type constr_label = + | ConstNode of constant + | IndNode of inductive + | CstrNode of constructor + | VarNode of identifier + +exception BoundPattern;; + +let label_of_ref = function + | ConstRef sp -> ConstNode sp + | IndRef sp -> IndNode sp + | ConstructRef sp -> CstrNode sp + | VarRef id -> VarNode id + +let ref_of_label = function + | ConstNode sp -> ConstRef sp + | IndNode sp -> IndRef sp + | CstrNode sp -> ConstructRef sp + | VarNode id -> VarRef id + +let subst_label subst cstl = + let ref = ref_of_label cstl in + let ref' = subst_global subst ref in + if ref' == ref then cstl else + label_of_ref ref' + + +let rec head_pattern_bound t = + match t with + | PProd (_,_,b) -> head_pattern_bound b + | PLetIn (_,_,b) -> head_pattern_bound b + | PApp (c,args) -> head_pattern_bound c + | PCase (_,p,c,br) -> head_pattern_bound c + | PRef r -> label_of_ref r + | PVar id -> VarNode id + | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ + -> raise BoundPattern + (* Perhaps they were arguments, but we don't beta-reduce *) + | PLambda _ -> raise BoundPattern + | PCoFix _ -> anomaly "head_pattern_bound: not a type" + +let head_of_constr_reference c = match kind_of_term c with + | Const sp -> ConstNode sp + | Construct sp -> CstrNode sp + | Ind sp -> IndNode sp + | Var id -> VarNode id + | _ -> anomaly "Not a rigid reference" + +let rec pattern_of_constr t = + match kind_of_term t with + | Rel n -> PRel n + | Meta n -> PMeta (Some (id_of_string (string_of_int n))) + | Var id -> PVar id + | Sort (Prop c) -> PSort (RProp c) + | Sort (Type _) -> PSort (RType None) + | Cast (c,_) -> pattern_of_constr c + | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b) + | Prod (na,c,b) -> PProd (na,pattern_of_constr c,pattern_of_constr b) + | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b) + | App (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a) + | Const sp -> PRef (ConstRef sp) + | Ind sp -> PRef (IndRef sp) + | Construct sp -> PRef (ConstructRef sp) + | Evar (n,ctxt) -> PEvar (n,Array.map pattern_of_constr ctxt) + | Case (ci,p,a,br) -> + PCase ((Some ci.ci_ind,ci.ci_pp_info.style), + Some (pattern_of_constr p),pattern_of_constr a, + Array.map pattern_of_constr br) + | Fix f -> PFix f + | CoFix _ -> + error "pattern_of_constr: (co)fix currently not supported" + +(* To process patterns, we need a translation without typing at all. *) + +let rec inst lvar = function + | PVar id as x -> (try List.assoc id lvar with Not_found -> x) + | PApp (p,pl) -> PApp (inst lvar p, Array.map (inst lvar) pl) + | PSoApp (n,pl) -> PSoApp (n, List.map (inst lvar) pl) + | PLambda (n,a,b) -> PLambda (n,inst lvar a,inst lvar b) + | PProd (n,a,b) -> PProd (n,inst lvar a,inst lvar b) + | PLetIn (n,a,b) -> PLetIn (n,inst lvar a,inst lvar b) + | PCase (ci,po,p,pl) -> + PCase (ci,option_app (inst lvar) po,inst lvar p,Array.map (inst lvar) pl) + (* Non recursive *) + | (PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ as x) -> x + (* Bound to terms *) + | (PFix _ | PCoFix _ as r) -> + error ("Not instantiable pattern") + +let instantiate_pattern = inst + +let rec pat_of_raw metas vars = function + | RVar (_,id) -> + (try PRel (list_index (Name id) vars) + with Not_found -> PVar id) + | RPatVar (_,(false,n)) -> + metas := n::!metas; PMeta (Some n) + | RRef (_,r) -> + PRef r + (* Hack pour ne pas réécrire une interprétation complète des patterns*) + | RApp (_, RPatVar (_,(true,n)), cl) -> + PSoApp (n, List.map (pat_of_raw metas vars) cl) + | RApp (_,c,cl) -> + PApp (pat_of_raw metas vars c, + Array.of_list (List.map (pat_of_raw metas vars) cl)) + | RLambda (_,na,c1,c2) -> + PLambda (na, pat_of_raw metas vars c1, + pat_of_raw metas (na::vars) c2) + | RProd (_,na,c1,c2) -> + PProd (na, pat_of_raw metas vars c1, + pat_of_raw metas (na::vars) c2) + | RLetIn (_,na,c1,c2) -> + PLetIn (na, pat_of_raw metas vars c1, + pat_of_raw metas (na::vars) c2) + | RSort (_,s) -> + PSort s + | RHole _ -> + PMeta None + | RCast (_,c,t) -> + Options.if_verbose + Pp.warning "Cast not taken into account in constr pattern"; + pat_of_raw metas vars c + | ROrderedCase (_,st,po,c,br,_) -> + PCase ((None,st),option_app (pat_of_raw metas vars) po, + pat_of_raw metas vars c, + Array.map (pat_of_raw metas vars) br) + | RIf (_,c,(_,None),b1,b2) -> + PCase ((None,IfStyle),None, pat_of_raw metas vars c, + [|pat_of_raw metas vars b1; pat_of_raw metas vars b2|]) + | RCases (loc,(po,_),[c,_],brs) -> + let sp = + match brs with + | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind + | _ -> None in + (* When po disappears: switch to rtn type *) + PCase ((sp,Term.RegularStyle),option_app (pat_of_raw metas vars) po, + pat_of_raw metas vars c, + Array.init (List.length brs) + (pat_of_raw_branch loc metas vars sp brs)) + | r -> + let loc = loc_of_rawconstr r in + user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Not supported pattern") + +and pat_of_raw_branch loc metas vars ind brs i = + let bri = List.filter + (function + (_,_,[PatCstr(_,c,lv,_)],_) -> snd c = i+1 + | (loc,_,_,_) -> + user_err_loc (loc,"pattern_of_rawconstr", + Pp.str "Not supported pattern")) brs in + match bri with + [(_,_,[PatCstr(_,(indsp,_),lv,_)],br)] -> + if ind <> None & ind <> Some indsp then + user_err_loc (loc,"pattern_of_rawconstr", + Pp.str "All constructors must be in the same inductive type"); + let lna = + List.map + (function PatVar(_,na) -> na + | PatCstr(loc,_,_,_) -> + user_err_loc (loc,"pattern_of_rawconstr", + Pp.str "Not supported pattern")) lv in + let vars' = List.rev lna @ vars in + List.fold_right (fun na b -> PLambda(na,PMeta None,b)) lna + (pat_of_raw metas vars' br) + | _ -> user_err_loc (loc,"pattern_of_rawconstr", + str "No unique branch for " ++ int (i+1) ++ + str"-th constructor") + +let pattern_of_rawconstr c = + let metas = ref [] in + let p = pat_of_raw metas [] c in + (!metas,p) diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli new file mode 100644 index 00000000..cf0d4528 --- /dev/null +++ b/pretyping/pattern.mli @@ -0,0 +1,91 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds + +(* Only for v7 parsing/printing *) +val patvar_of_int : int -> patvar +val patvar_of_int_v7 : int -> patvar + +(* Patterns *) + +type constr_pattern = + | PRef of global_reference + | PVar of identifier + | PEvar of existential_key * constr_pattern array + | PRel of int + | PApp of constr_pattern * constr_pattern array + | PSoApp of patvar * constr_pattern list + | PLambda of name * constr_pattern * constr_pattern + | PProd of name * constr_pattern * constr_pattern + | PLetIn of name * constr_pattern * constr_pattern + | PSort of rawsort + | PMeta of patvar option + | PCase of (inductive option * case_style) + * constr_pattern option * constr_pattern * constr_pattern array + | PFix of fixpoint + | PCoFix of cofixpoint + +val occur_meta_pattern : constr_pattern -> bool + +val subst_pattern : substitution -> constr_pattern -> constr_pattern + +type constr_label = + | ConstNode of constant + | IndNode of inductive + | CstrNode of constructor + | VarNode of identifier + +val label_of_ref : global_reference -> constr_label + +val subst_label : substitution -> constr_label -> constr_label + +exception BoundPattern + +(* [head_pattern_bound t] extracts the head variable/constant of the + type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly + if [t] is an abstraction *) + +val head_pattern_bound : constr_pattern -> constr_label + +(* [head_of_constr_reference c] assumes [r] denotes a reference and + returns its label; raises an anomaly otherwise *) + +val head_of_constr_reference : Term.constr -> constr_label + +(* [pattern_of_constr c] translates a term [c] with metavariables into + a pattern; currently, no destructor (Cases, Fix, Cofix) and no + existential variable are allowed in [c] *) + +val pattern_of_constr : constr -> constr_pattern + +(* [pattern_of_rawconstr l c] translates a term [c] with metavariables into + a pattern; variables bound in [l] are replaced by the pattern to which they + are bound *) + +val pattern_of_rawconstr : rawconstr -> + patvar list * constr_pattern + +val instantiate_pattern : + (identifier * constr_pattern) list -> constr_pattern -> constr_pattern diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml new file mode 100644 index 00000000..fee1522f --- /dev/null +++ b/pretyping/pretype_errors.ml @@ -0,0 +1,164 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + push_rel + (na, option_app (nf_evar sigma) b, nf_evar sigma ty) + e) + ctxt + ~init:env0 + +(* This simplify the typing context of Cases clauses *) +(* hope it does not disturb other typing contexts *) +let contract env lc = + let l = ref [] in + let contract_context (na,c,t) env = + match c with + | Some c' when isRel c' -> + l := (substl !l c') :: !l; + env + | _ -> + let t' = substl !l t in + let c' = option_app (substl !l) c in + let na' = named_hd env t' na in + l := (mkRel 1) :: List.map (lift 1) !l; + push_rel (na',c',t') env in + let env = process_rel_context contract_context env in + (env, List.map (substl !l) lc) + +let contract2 env a b = match contract env [a;b] with + | env, [a;b] -> env,a,b | _ -> assert false + +let contract3 env a b c = match contract env [a;b;c] with + | env, [a;b;c] -> env,a,b,c | _ -> assert false + +let raise_pretype_error (loc,ctx,sigma,te) = + Stdpp.raise_with_loc loc (PretypeError(env_ise sigma ctx,te)) + +let raise_located_type_error (loc,ctx,sigma,te) = + Stdpp.raise_with_loc loc (TypeError(env_ise sigma ctx,te)) + + +let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty = + let env, c, actty, expty = contract3 env c actty expty in + let j = j_nf_evar sigma {uj_val=c;uj_type=actty} in + raise_located_type_error + (loc, env, sigma, ActualType (j, nf_evar sigma expty)) + +let error_cant_apply_not_functional_loc loc env sigma rator randl = + let ja = Array.of_list (jl_nf_evar sigma randl) in + raise_located_type_error + (loc, env, sigma, + CantApplyNonFunctional (j_nf_evar sigma rator, ja)) + +let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl = + let ja = Array.of_list (jl_nf_evar sigma randl) in + raise_located_type_error + (loc, env, sigma, + CantApplyBadType + ((n,nf_evar sigma c, nf_evar sigma t), + j_nf_evar sigma rator, ja)) + +let error_ill_formed_branch_loc loc env sigma c i actty expty = + let simp t = Reduction.nf_betaiota (nf_evar sigma t) in + raise_located_type_error + (loc, env, sigma, + IllFormedBranch (nf_evar sigma c,i,simp actty, simp expty)) + +let error_number_branches_loc loc env sigma cj expn = + raise_located_type_error + (loc, env, sigma, + NumberBranches (j_nf_evar sigma cj, expn)) + +let error_case_not_inductive_loc loc env sigma cj = + raise_located_type_error + (loc, env, sigma, CaseNotInductive (j_nf_evar sigma cj)) + +let error_ill_typed_rec_body_loc loc env sigma i na jl tys = + raise_located_type_error + (loc, env, sigma, + IllTypedRecBody (i,na,jv_nf_evar sigma jl, + Array.map (nf_evar sigma) tys)) + +(*s Implicit arguments synthesis errors. It is hard to find + a precise location. *) + +let error_occur_check env sigma ev c = + let c = nf_evar sigma c in + raise (PretypeError (env_ise sigma env, OccurCheck (ev,c))) + +let error_not_clean env sigma ev c (loc,k) = + let c = nf_evar sigma c in + raise_with_loc loc + (PretypeError (env_ise sigma env, NotClean (ev,c,k))) + +let error_unsolvable_implicit loc env sigma e = + raise_with_loc loc (PretypeError (env_ise sigma env, UnsolvableImplicit e)) + +(*s Ml Case errors *) + +let error_cant_find_case_type_loc loc env sigma expr = + raise_pretype_error + (loc, env, sigma, CantFindCaseType (nf_evar sigma expr)) + +(*s Pretyping errors *) + +let error_unexpected_type_loc loc env sigma actty expty = + let env, actty, expty = contract2 env actty expty in + raise_pretype_error + (loc, env, sigma, + UnexpectedType (nf_evar sigma actty, nf_evar sigma expty)) + +let error_not_product_loc loc env sigma c = + raise_pretype_error (loc, env, sigma, NotProduct (nf_evar sigma c)) + +(*s Error in conversion from AST to rawterms *) + +let error_var_not_found_loc loc s = + raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli new file mode 100644 index 00000000..ebeff99d --- /dev/null +++ b/pretyping/pretype_errors.mli @@ -0,0 +1,100 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> constr +val j_nf_evar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment +val jl_nf_evar : + Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list +val jv_nf_evar : + Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array +val tj_nf_evar : + Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment + + +(* Raising errors *) +val error_actual_type_loc : + loc -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b + +val error_cant_apply_not_functional_loc : + loc -> env -> Evd.evar_map -> + unsafe_judgment -> unsafe_judgment list -> 'b + +val error_cant_apply_bad_type_loc : + loc -> env -> Evd.evar_map -> int * constr * constr -> + unsafe_judgment -> unsafe_judgment list -> 'b + +val error_case_not_inductive_loc : + loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b + +val error_ill_formed_branch_loc : + loc -> env -> Evd.evar_map -> + constr -> int -> constr -> constr -> 'b + +val error_number_branches_loc : + loc -> env -> Evd.evar_map -> + unsafe_judgment -> int -> 'b + +val error_ill_typed_rec_body_loc : + loc -> env -> Evd.evar_map -> + int -> name array -> unsafe_judgment array -> types array -> 'b + +(*s Implicit arguments synthesis errors *) + +val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b + +val error_not_clean : + env -> Evd.evar_map -> existential_key -> constr -> loc * hole_kind -> 'b + +val error_unsolvable_implicit : loc -> env -> Evd.evar_map -> hole_kind -> 'b + +(*s Ml Case errors *) + +val error_cant_find_case_type_loc : + loc -> env -> Evd.evar_map -> constr -> 'b + +(*s Pretyping errors *) + +val error_unexpected_type_loc : + loc -> env -> Evd.evar_map -> constr -> constr -> 'b + +val error_not_product_loc : + loc -> env -> Evd.evar_map -> constr -> 'b + +(*s Error in conversion from AST to rawterms *) + +val error_var_not_found_loc : loc -> identifier -> 'b diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml new file mode 100644 index 00000000..36df9c8a --- /dev/null +++ b/pretyping/pretyping.ml @@ -0,0 +1,1024 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (name,liftn n (k-i) c)) 0 l + +let transform_rec loc env sigma (pj,c,lf) indt = + let p = pj.uj_val in + let (indf,realargs) = dest_ind_type indt in + let (ind,params) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let recargs = mip.mind_recargs in + let mI = mkInd ind in + let ci = make_default_case_info env (if Options.do_translate() then RegularStyle else MatchStyle) ind in + let nconstr = Array.length mip.mind_consnames in + if Array.length lf <> nconstr then + (let cj = {uj_val=c; uj_type=mkAppliedInd indt} in + error_number_branches_loc loc env sigma cj nconstr); + let tyi = snd ind in + if mis_is_recursive_subset [tyi] recargs then + let dep = + is_dependent_elimination env (nf_evar sigma pj.uj_type) indf in + let init_depFvec i = if i = tyi then Some(dep,mkRel 1) else None in + let depFvec = Array.init mib.mind_ntypes init_depFvec in + (* build now the fixpoint *) + let lnames,_ = get_arity env indf in + let nar = List.length lnames in + let nparams = mip.mind_nparams in + let constrs = get_constructors env (lift_inductive_family (nar+2) indf) in + let branches = + array_map3 + (fun f t reca -> + whd_beta + (Indrec.make_rec_branch_arg env sigma + (nparams,depFvec,nar+1) + f t reca)) + (Array.map (lift (nar+2)) lf) constrs (dest_subterms recargs) + in + let deffix = + it_mkLambda_or_LetIn_name env + (lambda_create env + (applist (mI,List.append (List.map (lift (nar+1)) params) + (extended_rel_list 0 lnames)), + mkCase (ci, lift (nar+2) p, mkRel 1, branches))) + (lift_rel_context 1 lnames) + in + if noccurn 1 deffix then + whd_beta (applist (pop deffix,realargs@[c])) + else + let ind = applist (mI,(List.append + (List.map (lift nar) params) + (extended_rel_list 0 lnames))) in + let typPfix = + it_mkProd_or_LetIn_name env + (prod_create env + (ind, + (if dep then + let ext_lnames = (Anonymous,None,ind)::lnames in + let args = extended_rel_list 0 ext_lnames in + whd_beta (applist (lift (nar+1) p, args)) + else + let args = extended_rel_list 1 lnames in + whd_beta (applist (lift (nar+1) p, args))))) + lnames in + let fix = + mkFix (([|nar|],0), + ([|Name(id_of_string "F")|],[|typPfix|],[|deffix|])) in + applist (fix,realargs@[c]) + else + mkCase (ci, p, c, lf) + +(************************************************************************) + +(* To embed constr in rawconstr *) +let ((constr_in : constr -> Dyn.t), + (constr_out : Dyn.t -> constr)) = create "constr" + +let mt_evd = Evd.empty + +let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t) + +(* Utilisé pour inférer le prédicat des Cases *) +(* Semble exagérement fort *) +(* Faudra préférer une unification entre les types de toutes les clauses *) +(* et autoriser des ? à rester dans le résultat de l'unification *) + +let evar_type_fixpoint loc env isevars lna lar vdefj = + let lt = Array.length vdefj in + if Array.length lar = lt then + for i = 0 to lt-1 do + if not (the_conv_x_leq env isevars + (vdefj.(i)).uj_type + (lift lt lar.(i))) then + error_ill_typed_rec_body_loc loc env (evars_of isevars) + i lna vdefj lar + done + +let check_branches_message loc env isevars c (explft,lft) = + for i = 0 to Array.length explft - 1 do + if not (the_conv_x_leq env isevars lft.(i) explft.(i)) then + let sigma = evars_of isevars in + error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) + done + +(* coerce to tycon if any *) +let inh_conv_coerce_to_tycon loc env isevars j = function + | None -> j + | Some typ -> inh_conv_coerce_to loc env isevars j typ + +let push_rels vars env = List.fold_right push_rel vars env + +(* +let evar_type_case isevars env ct pt lft p c = + let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c + in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty) +*) + +let strip_meta id = (* For Grammar v7 compatibility *) + let s = string_of_id id in + if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) + else id + +let pretype_id loc env (lvar,unbndltacvars) id = + let id = strip_meta id in (* May happen in tactics defined by Grammar *) + try + List.assoc id lvar + with Not_found -> + try + let (n,typ) = lookup_rel_id id (rel_context env) in + { uj_val = mkRel n; uj_type = type_app (lift n) typ } + with Not_found -> + try + let (_,_,typ) = lookup_named id env in + { uj_val = mkVar id; uj_type = typ } + with Not_found -> + try (* To build a nicer ltac error message *) + match List.assoc id unbndltacvars with + | None -> user_err_loc (loc,"", + str (string_of_id id ^ " ist not bound to a term")) + | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 + with Not_found -> + error_var_not_found_loc loc id + +(* make a dependent predicate from an undependent one *) + +let make_dep_of_undep env (IndType (indf,realargs)) pj = + let n = List.length realargs in + let rec decomp n p = + if n=0 then p else + match kind_of_term p with + | Lambda (_,_,c) -> decomp (n-1) c + | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) + in + let sign,s = decompose_prod_n n pj.uj_type in + let ind = build_dependent_inductive env indf in + let s' = mkProd (Anonymous, ind, s) in + let ccl = lift 1 (decomp n pj.uj_val) in + let ccl' = mkLambda (Anonymous, ind, ccl) in + {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} + +(*************************************************************************) +(* Main pretyping function *) + +let pretype_ref isevars env ref = + let c = constr_of_reference ref in + make_judge c (Retyping.get_type_of env Evd.empty c) + +let pretype_sort = function + | RProp c -> judge_of_prop_contents c + | RType _ -> judge_of_new_Type () + +(* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *) +(* in environment [env], with existential variables [(evars_of isevars)] and *) +(* the type constraint tycon *) +let rec pretype tycon env isevars lvar = function + + | RRef (loc,ref) -> + inh_conv_coerce_to_tycon loc env isevars + (pretype_ref isevars env ref) + tycon + + | RVar (loc, id) -> + inh_conv_coerce_to_tycon loc env isevars + (pretype_id loc env lvar id) + tycon + + | REvar (loc, ev, instopt) -> + (* Ne faudrait-il pas s'assurer que hyps est bien un + sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) + let hyps = (Evd.map (evars_of isevars) ev).evar_hyps in + let args = match instopt with + | None -> instance_from_named_context hyps + | Some inst -> failwith "Evar subtitutions not implemented" in + let c = mkEvar (ev, args) in + let j = (Retyping.get_judgment_of env (evars_of isevars) c) in + inh_conv_coerce_to_tycon loc env isevars j tycon + + | RPatVar (loc,(someta,n)) -> + anomaly "Found a pattern variable in a rawterm to type" + + | RHole (loc,k) -> + if !compter then nbimpl:=!nbimpl+1; + (match tycon with + | Some ty -> + { uj_val = new_isevar isevars env (loc,k) ty; uj_type = ty } + | None -> error_unsolvable_implicit loc env (evars_of isevars) k) + + | RRec (loc,fixkind,names,bl,lar,vdef) -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,None,ty)::bl -> + let ty' = pretype_type empty_valcon env isevars lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env isevars lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + array_map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) isevars lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = push_rec_types (names,ftys,[||]) env in + let vdefj = + array_map2_i + (fun i ctxt def -> + (* we lift nbfix times the type in tycon, because of + * the nbfix variables pushed to newenv *) + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix ftys.(i)) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv isevars lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env isevars names ftys vdefj; + let fixj = + match fixkind with + | RFix (vn,i as vni) -> + let fix = (vni,(names,ftys,Array.map j_val vdefj)) in + (try check_fix env fix with e -> Stdpp.raise_with_loc loc e); + make_judge (mkFix fix) ftys.(i) + | RCoFix i -> + let cofix = (i,(names,ftys,Array.map j_val vdefj)) in + (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); + make_judge (mkCoFix cofix) ftys.(i) in + inh_conv_coerce_to_tycon loc env isevars fixj tycon + + | RSort (loc,s) -> + inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon + + | RApp (loc,f,args) -> + let fj = pretype empty_tycon env isevars lvar f in + let floc = loc_of_rawconstr f in + let rec apply_rec env n resj = function + | [] -> resj + | c::rest -> + let argloc = loc_of_rawconstr c in + let resj = inh_app_fun env isevars resj in + let resty = + whd_betadeltaiota env (evars_of isevars) resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + let hj = pretype (mk_tycon c1) env isevars lvar c in + let newresj = + { uj_val = applist (j_val resj, [j_val hj]); + uj_type = subst1 hj.uj_val c2 } in + apply_rec env (n+1) newresj rest + + | _ -> + let hj = pretype empty_tycon env isevars lvar c in + error_cant_apply_not_functional_loc + (join_loc floc argloc) env (evars_of isevars) + resj [hj] + + in let resj = apply_rec env 1 fj args in + (* + let apply_one_arg (floc,tycon,jl) c = + let (dom,rng) = split_tycon floc env isevars tycon in + let cj = pretype dom env isevars lvar c in + let rng_tycon = option_app (subst1 cj.uj_val) rng in + let argloc = loc_of_rawconstr c in + (join_loc floc argloc,rng_tycon,(argloc,cj)::jl) in + let _,_,jl = + List.fold_left apply_one_arg (floc,mk_tycon j.uj_type,[]) args in + let jl = List.rev jl in + let resj = inh_apply_rel_list loc env isevars jl (floc,j) tycon in + *) + inh_conv_coerce_to_tycon loc env isevars resj tycon + + | RLambda(loc,name,c1,c2) -> + let (name',dom,rng) = split_tycon loc env isevars tycon in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env isevars lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) isevars lvar c2 in + judge_of_abstraction env name j j' + + | RProd(loc,name,c1,c2) -> + let j = pretype_type empty_valcon env isevars lvar c1 in + let var = (name,j.utj_val) in + let env' = push_rel_assum var env in + let j' = pretype_type empty_valcon env' isevars lvar c2 in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> Stdpp.raise_with_loc loc e in + inh_conv_coerce_to_tycon loc env isevars resj tycon + + | RLetIn(loc,name,c1,c2) -> + let j = pretype empty_tycon env isevars lvar c1 in + let t = Evarutil.refresh_universes j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = option_app (lift 1) tycon in + let j' = pretype tycon (push_rel var env) isevars lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = type_app (subst1 j.uj_val) j'.uj_type } + + | RLetTuple (loc,nal,(na,po),c,d) -> + let cj = pretype empty_tycon env isevars lvar c in + let (IndType (indf,realargs) as indt) = + try find_rectype env (evars_of isevars) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env (evars_of isevars) cj + in + let cstrs = get_constructors env indf in + if Array.length cstrs <> 1 then + user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); + let cs = cstrs.(0) in + if List.length nal <> cs.cs_nargs then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rels fsign env in + (* Make dependencies from arity signature impossible *) + let arsgn,_ = get_arity env indf in + let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let nar = List.length arsgn in + (match po with + | Some p -> + let env_p = push_rels psign env in + let pj = pretype_type empty_valcon env_p isevars lvar p in + let ccl = nf_evar (evars_of isevars) pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env (evars_of isevars) lp inst in + let fj = pretype (mk_tycon fty) env_f isevars lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env LetStyle mis in + mkCase (ci, p, cj.uj_val,[|f|]) in + let cs = build_dependent_constructor cs in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + + | None -> + let tycon = option_app (lift cs.cs_nargs) tycon in + let fj = pretype tycon env_f isevars lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar (evars_of isevars) fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env (evars_of isevars) + cj.uj_val in + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env LetStyle mis in + mkCase (ci, p, cj.uj_val,[|f|] ) + in + { uj_val = v; uj_type = ccl }) + + (* Special Case for let constructions to avoid exponential behavior *) + | ROrderedCase (loc,st,po,c,[|f|],xx) when st <> MatchStyle -> + let cj = pretype empty_tycon env isevars lvar c in + let (IndType (indf,realargs) as indt) = + try find_rectype env (evars_of isevars) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env (evars_of isevars) cj + in + let j = match po with + | Some p -> + let pj = pretype empty_tycon env isevars lvar p in + let dep = is_dependent_elimination env pj.uj_type indf in + let ar = + arity_of_case_predicate env indf dep (Type (new_univ())) in + let _ = the_conv_x_leq env isevars pj.uj_type ar in + let pj = j_nf_evar (evars_of isevars) pj in + let pj = if dep then pj else make_dep_of_undep env indt pj in + let (bty,rsty) = + Indrec.type_rec_branches + false env (evars_of isevars) indt pj.uj_val cj.uj_val + in + if Array.length bty <> 1 then + error_number_branches_loc + loc env (evars_of isevars) cj (Array.length bty); + let fj = + let tyc = bty.(0) in + pretype (mk_tycon tyc) env isevars lvar f + in + let fv = j_val fj in + let ft = fj.uj_type in + check_branches_message loc env isevars cj.uj_val (bty,[|ft|]); + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env st mis in + mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|]) + in + { uj_val = v; uj_type = rsty } + + | None -> + (* get type information from type of branches *) + let expbr = Cases.branch_scheme env isevars false indf in + if Array.length expbr <> 1 then + error_number_branches_loc loc env (evars_of isevars) + cj (Array.length expbr); + let expti = expbr.(0) in + let fj = pretype (mk_tycon expti) env isevars lvar f in + let use_constraint () = + (* get type information from constraint *) + (* warning: if the constraint comes from an evar type, it *) + (* may be Type while Prop or Set would be expected *) + match tycon with + | Some pred -> + let arsgn = make_arity_signature env true indf in + let pred = lift (List.length arsgn) pred in + let pred = + it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred) + arsgn in + false, pred + | None -> + let sigma = evars_of isevars in + error_cant_find_case_type_loc loc env sigma cj.uj_val + in + let ok, p = + try + let pred = + Cases.pred_case_ml + env (evars_of isevars) false indt (0,fj.uj_type) + in + if has_undefined_isevars isevars pred then + use_constraint () + else + true, pred + with Cases.NotInferable _ -> + use_constraint () + in + let p = nf_evar (evars_of isevars) p in + let (bty,rsty) = + Indrec.type_rec_branches + false env (evars_of isevars) indt p cj.uj_val + in + let _ = option_app (the_conv_x_leq env isevars rsty) tycon in + let fj = + if ok then fj + else pretype (mk_tycon bty.(0)) env isevars lvar f + in + let fv = fj.uj_val in + let ft = fj.uj_type in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env st mis in + mkCase (ci, (nf_betaiota p), cj.uj_val,[|fv|] ) + in + { uj_val = v; uj_type = rsty } in + + (* Build the LetTuple form for v8 *) + let c = + let (ind,params) = dest_ind_family indf in + let rtntypopt, indnalopt = match po with + | None -> None, (Anonymous,None) + | Some p -> + let pj = pretype empty_tycon env isevars lvar p in + let dep = is_dependent_elimination env pj.uj_type indf in + let rec decomp_lam_force n avoid l p = + (* avoid is not exhaustive ! *) + if n = 0 then (List.rev l,p,avoid) else + match p with + | RLambda (_,(Name id as na),_,c) -> + decomp_lam_force (n-1) (id::avoid) (na::l) c + | RLambda (_,(Anonymous as na),_,c) -> + decomp_lam_force (n-1) avoid (na::l) c + | _ -> + let x = Nameops.next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in + let (nal,p,avoid) = + decomp_lam_force (List.length realargs) [] [] p in + let na,rtntyp,_ = + if dep then decomp_lam_force 1 avoid [] p + else [Anonymous],p,[] in + let intyp = + if List.for_all + (function + | Anonymous -> true + | Name id -> not (occur_rawconstr id rtntyp)) nal + then (* No dependency in realargs *) + None + else + let args = List.map (fun _ -> Anonymous) params @ nal in + Some (dummy_loc,ind,args) in + (Some rtntyp,(List.hd na,intyp)) in + let cs = (get_constructors env indf).(0) in + match indnalopt with + | (na,None) -> (* Represented as a let *) + let rec decomp_lam_force n avoid l p = + if n = 0 then (List.rev l,p) else + match p with + | RLambda (_,(Name id as na),_,c) -> + decomp_lam_force (n-1) (id::avoid) (na::l) c + | RLambda (_,(Anonymous as na),_,c) -> + decomp_lam_force (n-1) avoid (na::l) c + | _ -> + let x = Nameops.next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (let a = RVar (dummy_loc,x) in + match p with + | RApp (loc,p,l) -> RApp (loc,p,l@[a]) + | _ -> (RApp (dummy_loc,p,[a]))) in + let (nal,d) = decomp_lam_force cs.cs_nargs [] [] f in + RLetTuple (loc,nal,(na,rtntypopt),c,d) + | _ -> (* Represented as a match *) + let detype_eqn constr construct_nargs branch = + let name_cons = function + | Anonymous -> fun l -> l + | Name id -> fun l -> id::l in + let make_pat na avoid b ids = + PatVar (dummy_loc,na), + name_cons na avoid,name_cons na ids + in + let rec buildrec ids patlist avoid n b = + if n=0 then + (dummy_loc, ids, + [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)], + b) + else + match b with + | RLambda (_,x,_,b) -> + let pat,new_avoid,new_ids = make_pat x avoid b ids in + buildrec new_ids (pat::patlist) new_avoid (n-1) b + + | RLetIn (_,x,_,b) -> + let pat,new_avoid,new_ids = make_pat x avoid b ids in + buildrec new_ids (pat::patlist) new_avoid (n-1) b + + | RCast (_,c,_) -> (* Oui, il y a parfois des cast *) + buildrec ids patlist avoid n c + + | _ -> (* eta-expansion *) + (* nommage de la nouvelle variable *) + let id = Nameops.next_ident_away (id_of_string "x") avoid in + let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in + let pat,new_avoid,new_ids = + make_pat (Name id) avoid new_b ids in + buildrec new_ids (pat::patlist) new_avoid (n-1) new_b + + in + buildrec [] [] [] construct_nargs branch in + let eqn = detype_eqn (ind,1) cs.cs_nargs f in + RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],[eqn]) + in + xx := Some c; + (* End building the v8 syntax *) + j + + | RIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env isevars lvar c in + let (IndType (indf,realargs) as indt) = + try find_rectype env (evars_of isevars) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env (evars_of isevars) cj in + let cstrs = get_constructors env indf in + if Array.length cstrs <> 2 then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors"); + + (* Make dependencies from arity signature impossible *) + let arsgn,_ = get_arity env indf in + let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rels psign env in + let pj = pretype_type empty_valcon env_p isevars lvar p in + let ccl = nf_evar (evars_of isevars) pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + pred, lift (- nar) (beta_applist (pred,[cj.uj_val])) + | None -> + let p = match tycon with + | Some ty -> ty + | None -> new_isevar isevars env (loc,InternalHole) (new_Type ()) + in + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = liftn n 2 pred in + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args in + let env_c = push_rels csgn env in + let bj = pretype (Some pi) env_c isevars lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let pred = nf_evar (evars_of isevars) pred in + let p = nf_evar (evars_of isevars) p in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env IfStyle mis in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } + + | ROrderedCase (loc,st,po,c,lf,x) -> + let isrec = (st = MatchStyle) in + let cj = pretype empty_tycon env isevars lvar c in + let (IndType (indf,realargs) as indt) = + try find_rectype env (evars_of isevars) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env (evars_of isevars) cj in + let (dep,pj) = match po with + | Some p -> + let pj = pretype empty_tycon env isevars lvar p in + let dep = is_dependent_elimination env pj.uj_type indf in + let ar = + arity_of_case_predicate env indf dep (Type (new_univ())) in + let _ = the_conv_x_leq env isevars pj.uj_type ar in + (dep, pj) + | None -> + (* get type information from type of branches *) + let expbr = Cases.branch_scheme env isevars isrec indf in + let rec findtype i = + if i >= Array.length lf + then + (* get type information from constraint *) + (* warning: if the constraint comes from an evar type, it *) + (* may be Type while Prop or Set would be expected *) + match tycon with + | Some pred -> + let arsgn = make_arity_signature env true indf in + let pred = lift (List.length arsgn) pred in + let pred = + it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred) + arsgn in + (true, + Retyping.get_judgment_of env (evars_of isevars) pred) + | None -> + let sigma = evars_of isevars in + error_cant_find_case_type_loc loc env sigma cj.uj_val + else + try + let expti = expbr.(i) in + let fj = + pretype (mk_tycon expti) env isevars lvar lf.(i) in + let pred = + Cases.pred_case_ml (* eta-expanse *) + env (evars_of isevars) isrec indt (i,fj.uj_type) in + if has_undefined_isevars isevars pred then findtype (i+1) + else + let pty = + Retyping.get_type_of env (evars_of isevars) pred in + let pj = { uj_val = pred; uj_type = pty } in +(* + let _ = option_app (the_conv_x_leq env isevars pred) tycon + in +*) + (true,pj) + with Cases.NotInferable _ -> findtype (i+1) in + findtype 0 + in + let pj = j_nf_evar (evars_of isevars) pj in + let pj = if dep then pj else make_dep_of_undep env indt pj in + let (bty,rsty) = + Indrec.type_rec_branches + isrec env (evars_of isevars) indt pj.uj_val cj.uj_val in + let _ = option_app (the_conv_x_leq env isevars rsty) tycon in + if Array.length bty <> Array.length lf then + error_number_branches_loc loc env (evars_of isevars) + cj (Array.length bty) + else + let lfj = + array_map2 + (fun tyc f -> pretype (mk_tycon tyc) env isevars lvar f) bty + lf in + let lfv = Array.map j_val lfj in + let lft = Array.map (fun j -> j.uj_type) lfj in + check_branches_message loc env isevars cj.uj_val (bty,lft); + let v = + if isrec + then + transform_rec loc env (evars_of isevars)(pj,cj.uj_val,lfv) indt + else + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env st mis in + mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, + Array.map (fun j-> j.uj_val) lfj) + in + (* Build the Cases form for v8 *) + let c = + let (ind,params) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let recargs = mip.mind_recargs in + let mI = mkInd ind in + let nconstr = Array.length mip.mind_consnames in + let tyi = snd ind in + if isrec && mis_is_recursive_subset [tyi] recargs then + Some (Detyping.detype (false,env) + (ids_of_context env) (names_of_rel_context env) + (nf_evar (evars_of isevars) v)) + else + (* Translate into a "match ... with" *) + let rtntypopt, indnalopt = match po with + | None -> None, (Anonymous,None) + | Some p -> + let rec decomp_lam_force n avoid l p = + (* avoid is not exhaustive ! *) + if n = 0 then (List.rev l,p,avoid) else + match p with + | RLambda (_,(Name id as na),_,c) -> + decomp_lam_force (n-1) (id::avoid) (na::l) c + | RLambda (_,(Anonymous as na),_,c) -> + decomp_lam_force (n-1) avoid (na::l) c + | _ -> + let x = Nameops.next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in + let (nal,p,avoid) = + decomp_lam_force (List.length realargs) [] [] p in + let na,rtntyopt,_ = + if dep then decomp_lam_force 1 avoid [] p + else [Anonymous],p,[] in + let intyp = + if nal=[] then None else + let args = List.map (fun _ -> Anonymous) params @ nal in + Some (dummy_loc,ind,args) in + (Some rtntyopt,(List.hd na,intyp)) in + let rawbranches = + array_map3 (fun bj b cstr -> + let rec strip n r = if n=0 then r else + match r with + | RLambda (_,_,_,t) -> strip (n-1) t + | RLetIn (_,_,_,t) -> strip (n-1) t + | _ -> assert false in + let n = rel_context_length cstr.cs_args in + try + let _,ccl = decompose_lam_n_assum n bj.uj_val in + if noccur_between 1 n ccl then Some (strip n b) else None + with _ -> (* Not eta-expanded or not reduced *) None) + lfj lf (get_constructors env indf) in + if st = IfStyle & snd indnalopt = None + & rawbranches.(0) <> None && rawbranches.(1) <> None then + (* Translate into a "if ... then ... else" *) + (* TODO: translate into a "if" even if po is dependent *) + Some (RIf (loc,c,(fst indnalopt,rtntypopt), + out_some rawbranches.(0),out_some rawbranches.(1))) + else + let detype_eqn constr construct_nargs branch = + let name_cons = function + | Anonymous -> fun l -> l + | Name id -> fun l -> id::l in + let make_pat na avoid b ids = + PatVar (dummy_loc,na), + name_cons na avoid,name_cons na ids + in + let rec buildrec ids patlist avoid n b = + if n=0 then + (dummy_loc, ids, + [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)], + b) + else + match b with + | RLambda (_,x,_,b) -> + let pat,new_avoid,new_ids = make_pat x avoid b ids in + buildrec new_ids (pat::patlist) new_avoid (n-1) b + + | RLetIn (_,x,_,b) -> + let pat,new_avoid,new_ids = make_pat x avoid b ids in + buildrec new_ids (pat::patlist) new_avoid (n-1) b + + | RCast (_,c,_) -> (* Oui, il y a parfois des cast *) + buildrec ids patlist avoid n c + + | _ -> (* eta-expansion *) + (* nommage de la nouvelle variable *) + let id = Nameops.next_ident_away (id_of_string "x") avoid in + let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in + let pat,new_avoid,new_ids = + make_pat (Name id) avoid new_b ids in + buildrec new_ids (pat::patlist) new_avoid (n-1) new_b + + in + buildrec [] [] [] construct_nargs branch in + let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in + let get_consnarg j = + let typi = mis_nf_constructor_type (ind,mib,mip) (j+1) in + let _,t = decompose_prod_n_assum mip.mind_nparams typi in + List.rev (fst (decompose_prod_assum t)) in + let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in + let consnargsl = Array.map List.length consnargs in + let constructs = Array.init (Array.length lf) (fun i -> (ind,i+1)) in + let eqns = array_map3 detype_eqn constructs consnargsl lf in + Some (RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],Array.to_list eqns)) in + x := c; + (* End build the Cases form for v8 *) + { uj_val = v; + uj_type = rsty } + + | RCases (loc,po,tml,eqns) -> + Cases.compile_cases loc + ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) + tycon env (* loc *) (po,tml,eqns) + + | RCast(loc,c,t) -> + let tj = pretype_type empty_tycon env isevars lvar t in + let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in + (* User Casts are for helping pretyping, experimentally not to be kept*) + (* ... except for Correctness *) + let v = mkCast (cj.uj_val, tj.utj_val) in + let cj = { uj_val = v; uj_type = tj.utj_val } in + inh_conv_coerce_to_tycon loc env isevars cj tycon + + | RDynamic (loc,d) -> + if (tag d) = "constr" then + let c = constr_out d in + let j = (Retyping.get_judgment_of env (evars_of isevars) c) in + j + (*inh_conv_coerce_to_tycon loc env isevars j tycon*) + else + user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic")) + +(* [pretype_type valcon env isevars lvar c] coerces [c] into a type *) +and pretype_type valcon env isevars lvar = function + | RHole loc -> + if !compter then nbimpl:=!nbimpl+1; + (match valcon with + | Some v -> + let s = + let sigma = evars_of isevars in + let t = Retyping.get_type_of env sigma v in + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | Evar v when is_Type (existential_type sigma v) -> + define_evar_as_sort isevars v + | _ -> anomaly "Found a type constraint which is not a type" + in + { utj_val = v; + utj_type = s } + | None -> + let s = new_Type_sort () in + { utj_val = new_isevar isevars env loc (mkSort s); + utj_type = s}) + | c -> + let j = pretype empty_tycon env isevars lvar c in + let tj = inh_coerce_to_sort env isevars j in + match valcon with + | None -> tj + | Some v -> + if the_conv_x_leq env isevars v tj.utj_val then tj + else + error_unexpected_type_loc + (loc_of_rawconstr c) env (evars_of isevars) tj.utj_val v + + +let unsafe_infer tycon isevars env lvar constr = + let j = pretype tycon env isevars lvar constr in + j_nf_evar (evars_of isevars) j + +let unsafe_infer_type valcon isevars env lvar constr = + let tj = pretype_type valcon env isevars lvar constr in + tj_nf_evar (evars_of isevars) tj + +(* If fail_evar is false, [process_evars] builds a meta_map with the + unresolved Evar that were not in initial sigma; otherwise it fail + on the first unresolved Evar not already in the initial sigma. *) +(* [fail_evar] says how to process unresolved evars: + * true -> raise an error message + * false -> convert them into new Metas (casted with their type) + *) +(* assumes the defined existentials have been replaced in c (should be + done in unsafe_infer and unsafe_infer_type) *) +let check_evars fail_evar env initial_sigma isevars c = + let sigma = evars_of isevars in + let rec proc_rec c = + match kind_of_term c with + | Evar (ev,args as k) -> + assert (Evd.in_dom sigma ev); + if not (Evd.in_dom initial_sigma ev) then + (if fail_evar then + let (loc,k) = evar_source ev isevars in + error_unsolvable_implicit loc env sigma k) + | _ -> iter_constr proc_rec c + in + proc_rec c + +(* TODO: comment faire remonter l'information si le typage a resolu des + variables du sigma original. il faudrait que la fonction de typage + retourne aussi le nouveau sigma... +*) + +(* constr with holes *) +type open_constr = evar_map * constr + +let ise_resolve_casted_gen fail_evar sigma env lvar typ c = + let isevars = create_evar_defs sigma in + let j = unsafe_infer (mk_tycon typ) isevars env lvar c in + check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type)); + (evars_of isevars, j) + +let ise_resolve_casted sigma env typ c = + ise_resolve_casted_gen true sigma env ([],[]) typ c + +(* Raw calls to the unsafe inference machine: boolean says if we must fail + on unresolved evars, or replace them by Metas; the unsafe_judgment list + allows us to extend env with some bindings *) +let ise_infer_gen fail_evar sigma env lvar exptyp c = + let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in + let isevars = create_evar_defs sigma in + let j = unsafe_infer tycon isevars env lvar c in + check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type)); + (evars_of isevars, j) + +let ise_infer_type_gen fail_evar sigma env lvar c = + let isevars = create_evar_defs sigma in + let tj = unsafe_infer_type empty_valcon isevars env lvar c in + check_evars fail_evar env sigma isevars tj.utj_val; + (evars_of isevars, tj) + +type var_map = (identifier * unsafe_judgment) list + +let understand_judgment sigma env c = + snd (ise_infer_gen true sigma env ([],[]) None c) + +let understand_type_judgment sigma env c = + snd (ise_infer_type_gen true sigma env ([],[]) c) + +let understand sigma env c = + let _, c = ise_infer_gen true sigma env ([],[]) None c in + c.uj_val + +let understand_type sigma env c = + let _,c = ise_infer_type_gen true sigma env ([],[]) c in + c.utj_val + +let understand_gen_ltac sigma env lvar ~expected_type:exptyp c = + let _, c = ise_infer_gen true sigma env lvar exptyp c in + c.uj_val + +let understand_gen sigma env lvar ~expected_type:exptyp c = + let _, c = ise_infer_gen true sigma env (lvar,[]) exptyp c in + c.uj_val + +let understand_gen_tcc sigma env lvar exptyp c = + let metamap, c = ise_infer_gen false sigma env (lvar,[]) exptyp c in + metamap, c.uj_val + +let interp_sort = function + | RProp c -> Prop c + | RType _ -> new_Type_sort () + +let interp_elimination_sort = function + | RProp Null -> InProp + | RProp Pos -> InSet + | RType _ -> InType diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli new file mode 100644 index 00000000..4357e504 --- /dev/null +++ b/pretyping/pretyping.mli @@ -0,0 +1,86 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> var_map + -> expected_type:(constr option) -> rawconstr -> constr + +val understand_gen_ltac : + evar_map -> env -> var_map * (identifier * identifier option) list + -> expected_type:(constr option) -> rawconstr -> constr + +(* Generic call to the interpreter from rawconstr to constr, turning + unresolved holes into metas. Returns also the typing context of + these metas. Work as [understand_gen] for the rest. *) +val understand_gen_tcc : + evar_map -> env -> var_map + -> constr option -> rawconstr -> open_constr + +(* Standard call to get a constr from a rawconstr, resolving implicit args *) +val understand : evar_map -> env -> rawconstr -> constr + +(* Idem but the rawconstr is intended to be a type *) +val understand_type : evar_map -> env -> rawconstr -> constr + +(* Idem but returns the judgment of the understood term *) +val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment + +(* Idem but returns the judgment of the understood type *) +val understand_type_judgment : evar_map -> env -> rawconstr + -> unsafe_type_judgment + +(* To embed constr in rawconstr *) +val constr_in : constr -> Dyn.t +val constr_out : Dyn.t -> constr + +(*i*) +(* Internal of Pretyping... + * Unused outside, but useful for debugging + *) +val pretype : + type_constraint -> env -> evar_defs -> + var_map * (identifier * identifier option) list -> + rawconstr -> unsafe_judgment + +val pretype_type : + val_constraint -> env -> evar_defs -> + var_map * (identifier * identifier option) list -> + rawconstr -> unsafe_type_judgment +(*i*) + +val interp_sort : rawsort -> sorts + +val interp_elimination_sort : rawsort -> sorts_family diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml new file mode 100644 index 00000000..520f09e9 --- /dev/null +++ b/pretyping/rawterm.ml @@ -0,0 +1,365 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* loc + | PatCstr(loc,_,_,_) -> loc + +type patvar = identifier + +type rawsort = RProp of Term.contents | RType of Univ.universe option + +type fix_kind = RFix of (int array * int) | RCoFix of int + +type binder_kind = BProd | BLambda | BLetIn + +type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier + +type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list + +type 'a bindings = + | ImplicitBindings of 'a list + | ExplicitBindings of 'a explicit_bindings + | NoBindings + +type 'a with_bindings = 'a * 'a bindings + +type hole_kind = + | ImplicitArg of global_reference * int + | BinderType of name + | QuestionMark + | CasesType + | InternalHole + | TomatchTypeParameter of inductive * int + +type rawconstr = + | RRef of (loc * global_reference) + | RVar of (loc * identifier) + | REvar of loc * existential_key * rawconstr list option + | RPatVar of loc * (bool * patvar) (* Used for patterns only *) + | RApp of loc * rawconstr * rawconstr list + | RLambda of loc * name * rawconstr * rawconstr + | RProd of loc * name * rawconstr * rawconstr + | RLetIn of loc * name * rawconstr * rawconstr + | RCases of loc * (rawconstr option * rawconstr option ref) * + (rawconstr * (name * (loc * inductive * name list) option) ref) list * + (loc * identifier list * cases_pattern list * rawconstr) list + | ROrderedCase of loc * case_style * rawconstr option * rawconstr * + rawconstr array * rawconstr option ref + | RLetTuple of loc * name list * (name * rawconstr option) * + rawconstr * rawconstr + | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr + | RRec of loc * fix_kind * identifier array * rawdecl list array * + rawconstr array * rawconstr array + | RSort of loc * rawsort + | RHole of (loc * hole_kind) + | RCast of loc * rawconstr * rawconstr + | RDynamic of loc * Dyn.t + +and rawdecl = name * rawconstr option * rawconstr + +let cases_predicate_names tml = + List.flatten (List.map (function + | (tm,{contents=(na,None)}) -> [na] + | (tm,{contents=(na,Some (_,_,nal))}) -> na::nal) tml) + +(*i - if PRec (_, names, arities, bodies) is in env then arities are + typed in env too and bodies are typed in env enriched by the + arities incrementally lifted + + [On pourrait plutot mettre les arités aves le type qu'elles auront + dans le contexte servant à typer les body ???] + + - boolean in POldCase means it is recursive +i*) +let map_rawdecl f (na,obd,ty) = (na,option_app f obd,f ty) + +let map_rawconstr f = function + | RVar (loc,id) -> RVar (loc,id) + | RApp (loc,g,args) -> RApp (loc,f g, List.map f args) + | RLambda (loc,na,ty,c) -> RLambda (loc,na,f ty,f c) + | RProd (loc,na,ty,c) -> RProd (loc,na,f ty,f c) + | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c) + | RCases (loc,(tyopt,rtntypopt),tml,pl) -> + RCases (loc,(option_app f tyopt,ref (option_app f !rtntypopt)), + List.map (fun (tm,x) -> (f tm,x)) tml, + List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl) + | ROrderedCase (loc,b,tyopt,tm,bv,x) -> + ROrderedCase (loc,b,option_app f tyopt,f tm, Array.map f bv,ref (option_app f !x)) + | RLetTuple (loc,nal,(na,po),b,c) -> + RLetTuple (loc,nal,(na,option_app f po),f b,f c) + | RIf (loc,c,(na,po),b1,b2) -> + RIf (loc,f c,(na,option_app f po),f b1,f b2) + | RRec (loc,fk,idl,bl,tyl,bv) -> + RRec (loc,fk,idl,Array.map (List.map (map_rawdecl f)) bl, + Array.map f tyl,Array.map f bv) + | RCast (loc,c,t) -> RCast (loc,f c,f t) + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x + + +(* +let name_app f e = function + | Name id -> let (id, e) = f id e in (Name id, e) + | Anonymous -> Anonymous, e + +let fold_ident g idl e = + let (idl,e) = + Array.fold_right + (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e) + in (Array.of_list idl,e) + +let map_rawconstr_with_binders_loc loc g f e = function + | RVar (_,id) -> RVar (loc,id) + | RApp (_,a,args) -> RApp (loc,f e a, List.map (f e) args) + | RLambda (_,na,ty,c) -> + let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c) + | RProd (_,na,ty,c) -> + let na,e = name_app g e na in RProd (loc,na,f e ty,f e c) + | RLetIn (_,na,b,c) -> + let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c) + | RCases (_,tyopt,tml,pl) -> + (* We don't modify pattern variable since we don't traverse patterns *) + let g' id e = snd (g id e) in + let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in + RCases + (loc,option_app (f e) tyopt,List.map (f e) tml, List.map h pl) + | ROrderedCase (_,b,tyopt,tm,bv) -> + ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv) + | RRec (_,fk,idl,tyl,bv) -> + let idl',e' = fold_ident g idl e in + RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv) + | RCast (_,c,t) -> RCast (loc,f e c,f e t) + | RSort (_,x) -> RSort (loc,x) + | RHole (_,x) -> RHole (loc,x) + | RRef (_,x) -> RRef (loc,x) + | REvar (_,x,l) -> REvar (loc,x,l) + | RPatVar (_,x) -> RPatVar (loc,x) + | RDynamic (_,x) -> RDynamic (loc,x) +*) + +let occur_rawconstr id = + let rec occur = function + | RVar (loc,id') -> id = id' + | RApp (loc,f,args) -> (occur f) or (List.exists occur args) + | RLambda (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) + | RProd (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) + | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c)) + | RCases (loc,(tyopt,rtntypopt),tml,pl) -> + (occur_option tyopt) or (occur_option !rtntypopt) + or (List.exists (fun (tm,_) -> occur tm) tml) + or (List.exists occur_pattern pl) + | ROrderedCase (loc,b,tyopt,tm,bv,_) -> + (occur_option tyopt) or (occur tm) or (array_exists occur bv) + | RLetTuple (loc,nal,rtntyp,b,c) -> + occur_return_type rtntyp id + or (occur b) or (not (List.mem (Name id) nal) & (occur c)) + | RIf (loc,c,rtntyp,b1,b2) -> + occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2) + | RRec (loc,fk,idl,bl,tyl,bv) -> + not (array_for_all4 (fun fid bl ty bd -> + let rec occur_fix = function + [] -> not (occur ty) && (fid=id or not(occur bd)) + | (na,bbd,bty)::bl -> + not (occur bty) && + (match bbd with + Some bd -> not (occur bd) + | _ -> true) && + (na=Name id or not(occur_fix bl)) in + occur_fix bl) + idl bl tyl bv) + | RCast (loc,c,t) -> (occur c) or (occur t) + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false + + and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c) + + and occur_option = function None -> false | Some p -> occur p + + and occur_return_type (na,tyopt) id = na <> Name id & occur_option tyopt + + in occur + +let rec subst_pat subst pat = + match pat with + | PatVar _ -> pat + | PatCstr (loc,((kn,i),j),cpl,n) -> + let kn' = subst_kn subst kn + and cpl' = list_smartmap (subst_pat subst) cpl in + if kn' == kn && cpl' == cpl then pat else + PatCstr (loc,((kn',i),j),cpl',n) + +let rec subst_raw subst raw = + match raw with + | RRef (loc,ref) -> + let ref' = subst_global subst ref in + if ref' == ref then raw else + RRef (loc,ref') + + | RVar _ -> raw + | REvar _ -> raw + | RPatVar _ -> raw + + | RApp (loc,r,rl) -> + let r' = subst_raw subst r + and rl' = list_smartmap (subst_raw subst) rl in + if r' == r && rl' == rl then raw else + RApp(loc,r',rl') + + | RLambda (loc,n,r1,r2) -> + let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in + if r1' == r1 && r2' == r2 then raw else + RLambda (loc,n,r1',r2') + + | RProd (loc,n,r1,r2) -> + let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in + if r1' == r1 && r2' == r2 then raw else + RProd (loc,n,r1',r2') + + | RLetIn (loc,n,r1,r2) -> + let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in + if r1' == r1 && r2' == r2 then raw else + RLetIn (loc,n,r1',r2') + + | RCases (loc,(ro,rtno),rl,branches) -> + let ro' = option_smartmap (subst_raw subst) ro + and rtno' = ref (option_smartmap (subst_raw subst) !rtno) + and rl' = list_smartmap (fun (a,x as y) -> + let a' = subst_raw subst a in + let (n,topt) = !x in + let topt' = option_smartmap + (fun (loc,(sp,i),x as t) -> + let sp' = subst_kn subst sp in + if sp == sp' then t else (loc,(sp',i),x)) topt in + if a == a' && topt == topt' then y else (a',ref (n,topt'))) rl + and branches' = list_smartmap + (fun (loc,idl,cpl,r as branch) -> + let cpl' = list_smartmap (subst_pat subst) cpl + and r' = subst_raw subst r in + if cpl' == cpl && r' == r then branch else + (loc,idl,cpl',r')) + branches + in + if ro' == ro && rl' == rl && branches' == branches then raw else + RCases (loc,(ro',rtno'),rl',branches') + + | ROrderedCase (loc,b,ro,r,ra,x) -> + let ro' = option_smartmap (subst_raw subst) ro + and r' = subst_raw subst r + and ra' = array_smartmap (subst_raw subst) ra in + if ro' == ro && r' == r && ra' == ra then raw else + ROrderedCase (loc,b,ro',r',ra',x) + + | RLetTuple (loc,nal,(na,po),b,c) -> + let po' = option_smartmap (subst_raw subst) po + and b' = subst_raw subst b + and c' = subst_raw subst c in + if po' == po && b' == b && c' == c then raw else + RLetTuple (loc,nal,(na,po'),b',c') + + | RIf (loc,c,(na,po),b1,b2) -> + let po' = option_smartmap (subst_raw subst) po + and b1' = subst_raw subst b1 + and b2' = subst_raw subst b2 + and c' = subst_raw subst c in + if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else + RIf (loc,c',(na,po'),b1',b2') + + | RRec (loc,fix,ida,bl,ra1,ra2) -> + let ra1' = array_smartmap (subst_raw subst) ra1 + and ra2' = array_smartmap (subst_raw subst) ra2 in + let bl' = array_smartmap + (list_smartmap (fun (na,obd,ty as dcl) -> + let ty' = subst_raw subst ty in + let obd' = option_smartmap (subst_raw subst) obd in + if ty'==ty & obd'==obd then dcl else (na,obd',ty'))) + bl in + if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else + RRec (loc,fix,ida,bl',ra1',ra2') + + | RSort _ -> raw + + | RHole (loc,ImplicitArg (ref,i)) -> + let ref' = subst_global subst ref in + if ref' == ref then raw else + RHole (loc,ImplicitArg (ref',i)) + | RHole (loc, (BinderType _ | QuestionMark | CasesType | + InternalHole | TomatchTypeParameter _)) -> raw + + | RCast (loc,r1,r2) -> + let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in + if r1' == r1 && r2' == r2 then raw else + RCast (loc,r1',r2') + + | RDynamic _ -> raw + +let loc_of_rawconstr = function + | RRef (loc,_) -> loc + | RVar (loc,_) -> loc + | REvar (loc,_,_) -> loc + | RPatVar (loc,_) -> loc + | RApp (loc,_,_) -> loc + | RLambda (loc,_,_,_) -> loc + | RProd (loc,_,_,_) -> loc + | RLetIn (loc,_,_,_) -> loc + | RCases (loc,_,_,_) -> loc + | ROrderedCase (loc,_,_,_,_,_) -> loc + | RLetTuple (loc,_,_,_,_) -> loc + | RIf (loc,_,_,_,_) -> loc + | RRec (loc,_,_,_,_,_) -> loc + | RSort (loc,_) -> loc + | RHole (loc,_) -> loc + | RCast (loc,_,_) -> loc + | RDynamic (loc,_) -> loc + +type 'a raw_red_flag = { + rBeta : bool; + rIota : bool; + rZeta : bool; + rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*) + rConst : 'a list +} + +let all_flags = + {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []} + +type 'a occurrences = int list * 'a + +type ('a,'b) red_expr_gen = + | Red of bool + | Hnf + | Simpl of 'a occurrences option + | Cbv of 'b raw_red_flag + | Lazy of 'b raw_red_flag + | Unfold of 'b occurrences list + | Fold of 'a list + | Pattern of 'a occurrences list + | ExtraRedExpr of string * 'a + +type ('a,'b) may_eval = + | ConstrTerm of 'a + | ConstrEval of ('a, 'b) red_expr_gen * 'a + | ConstrContext of (loc * identifier) * 'a + | ConstrTypeOf of 'a diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli new file mode 100644 index 00000000..d78d1866 --- /dev/null +++ b/pretyping/rawterm.mli @@ -0,0 +1,139 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* loc + +type patvar = identifier + +type rawsort = RProp of Term.contents | RType of Univ.universe option + +type fix_kind = RFix of (int array * int) | RCoFix of int + +type binder_kind = BProd | BLambda | BLetIn + +type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier + +type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list + +type 'a bindings = + | ImplicitBindings of 'a list + | ExplicitBindings of 'a explicit_bindings + | NoBindings + +type 'a with_bindings = 'a * 'a bindings + +type hole_kind = + | ImplicitArg of global_reference * int + | BinderType of name + | QuestionMark + | CasesType + | InternalHole + | TomatchTypeParameter of inductive * int + +type rawconstr = + | RRef of (loc * global_reference) + | RVar of (loc * identifier) + | REvar of loc * existential_key * rawconstr list option + | RPatVar of loc * (bool * patvar) (* Used for patterns only *) + | RApp of loc * rawconstr * rawconstr list + | RLambda of loc * name * rawconstr * rawconstr + | RProd of loc * name * rawconstr * rawconstr + | RLetIn of loc * name * rawconstr * rawconstr + | RCases of loc * (rawconstr option * rawconstr option ref) * + (rawconstr * (name * (loc * inductive * name list) option) ref) list * + (loc * identifier list * cases_pattern list * rawconstr) list + | ROrderedCase of loc * case_style * rawconstr option * rawconstr * + rawconstr array * rawconstr option ref + | RLetTuple of loc * name list * (name * rawconstr option) * + rawconstr * rawconstr + | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr + | RRec of loc * fix_kind * identifier array * rawdecl list array * + rawconstr array * rawconstr array + | RSort of loc * rawsort + | RHole of (loc * hole_kind) + | RCast of loc * rawconstr * rawconstr + | RDynamic of loc * Dyn.t + +and rawdecl = name * rawconstr option * rawconstr + +val cases_predicate_names : + (rawconstr * (name * (loc * inductive * name list) option) ref) list -> + name list + +(*i - if PRec (_, names, arities, bodies) is in env then arities are + typed in env too and bodies are typed in env enriched by the + arities incrementally lifted + + [On pourrait plutot mettre les arités aves le type qu'elles auront + dans le contexte servant à typer les body ???] + + - boolean in POldCase means it is recursive + - option in PHole tell if the "?" was apparent or has been implicitely added +i*) + +val map_rawconstr : (rawconstr -> rawconstr) -> rawconstr -> rawconstr + +(* +val map_rawconstr_with_binders_loc : loc -> + (identifier -> 'a -> identifier * 'a) -> + ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr +*) + +val occur_rawconstr : identifier -> rawconstr -> bool + +val loc_of_rawconstr : rawconstr -> loc + +val subst_raw : Names.substitution -> rawconstr -> rawconstr + +type 'a raw_red_flag = { + rBeta : bool; + rIota : bool; + rZeta : bool; + rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*) + rConst : 'a list +} + +val all_flags : 'a raw_red_flag + +type 'a occurrences = int list * 'a + +type ('a,'b) red_expr_gen = + | Red of bool + | Hnf + | Simpl of 'a occurrences option + | Cbv of 'b raw_red_flag + | Lazy of 'b raw_red_flag + | Unfold of 'b occurrences list + | Fold of 'a list + | Pattern of 'a occurrences list + | ExtraRedExpr of string * 'a + +type ('a,'b) may_eval = + | ConstrTerm of 'a + | ConstrEval of ('a, 'b) red_expr_gen * 'a + | ConstrContext of (loc * identifier) * 'a + | ConstrTypeOf of 'a diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml new file mode 100755 index 00000000..f34d5624 --- /dev/null +++ b/pretyping/recordops.ml @@ -0,0 +1,176 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* f a e | None -> e + +let cache_structure (_,(ind,struc)) = + structure_table := Indmap.add ind struc !structure_table; + projection_table := + List.fold_right (option_fold_right (fun proj -> KNmap.add proj struc)) + struc.s_PROJ !projection_table + +let subst_structure (_,subst,((kn,i),struc as obj)) = + let kn' = subst_kn subst kn in + let proj' = list_smartmap + (option_smartmap (subst_kn subst)) + struc.s_PROJ + in + if proj' == struc.s_PROJ && kn' == kn then obj else + (kn',i),{struc with s_PROJ = proj'} + +let (inStruc,outStruc) = + declare_object {(default_object "STRUCTURE") with + cache_function = cache_structure; + load_function = (fun _ o -> cache_structure o); + subst_function = subst_structure; + classify_function = (fun (_,x) -> Substitute x); + export_function = (function x -> Some x) } + +let add_new_struc (s,c,n,l) = + Lib.add_anonymous_leaf (inStruc (s,{s_CONST=c;s_PARAM=n;s_PROJ=l})) + +let find_structure indsp = Indmap.find indsp !structure_table + +let find_projection_nparams = function + | ConstRef cst -> (KNmap.find cst !projection_table).s_PARAM + | _ -> raise Not_found + +(*s Un "object" est une fonction construisant une instance d'une structure *) + +(* Table des definitions "object" : pour chaque object c, + + c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n) + + avec ti = (ci ui1...uir) + + Pour tout ci, et Li, la ième projection de la structure R (si + définie), on déclare une "coercion" + + o_DEF = c + o_TABS = B1...Bk + o_PARAMS = a1...am + o_TCOMP = ui1...uir +*) + +type obj_typ = { + o_DEF : constr; + o_TABS : constr list; (* dans l'ordre *) + o_TPARAMS : constr list; (* dans l'ordre *) + o_TCOMPS : constr list } (* dans l'ordre *) + +let subst_obj subst obj = + let o_DEF' = subst_mps subst obj.o_DEF in + let o_TABS' = list_smartmap (subst_mps subst) obj.o_TABS in + let o_TPARAMS' = list_smartmap (subst_mps subst) obj.o_TPARAMS in + let o_TCOMPS' = list_smartmap (subst_mps subst) obj.o_TCOMPS in + if o_DEF' == obj.o_DEF + && o_TABS' == obj.o_TABS + && o_TPARAMS' == obj.o_TPARAMS + && o_TCOMPS' == obj.o_TCOMPS + then + obj + else + { o_DEF = o_DEF' ; + o_TABS = o_TABS' ; + o_TPARAMS = o_TPARAMS' ; + o_TCOMPS = o_TCOMPS' } + +let object_table = + (ref [] : ((global_reference * global_reference) * obj_typ) list ref) + +let cache_object (_,x) = object_table := x :: (!object_table) + +let subst_object (_,subst,((r1,r2),o as obj)) = + let r1' = subst_global subst r1 in + let r2' = subst_global subst r2 in + let o' = subst_obj subst o in + if r1' == r1 && r2' == r2 && o' == o then obj else + (r1',r2'),o' + +let (inObjDef,outObjDef) = + declare_object {(default_object "OBJDEF") with + open_function = (fun i o -> if i=1 then cache_object o); + cache_function = cache_object; + subst_function = subst_object; + classify_function = (fun (_,x) -> Substitute x); + export_function = (function x -> Some x) } + +let add_new_objdef (o,c,la,lp,l) = + try + let _ = List.assoc o !object_table in () + with Not_found -> + Lib.add_anonymous_leaf + (inObjDef (o,{o_DEF=c;o_TABS=la;o_TPARAMS=lp;o_TCOMPS=l})) + +let cache_objdef1 (_,sp) = () + +let (inObjDef1,outObjDef1) = + declare_object {(default_object "OBJDEF1") with + open_function = (fun i o -> if i=1 then cache_objdef1 o); + cache_function = cache_objdef1; + export_function = (function x -> Some x) } + +let objdef_info o = List.assoc o !object_table + +let freeze () = + !structure_table, !projection_table, !object_table + +let unfreeze (s,p,o) = + structure_table := s; projection_table := p; object_table := o + +let init () = + structure_table := Indmap.empty; projection_table := KNmap.empty; + object_table:=[] + +let _ = init() + +let _ = + Summary.declare_summary "objdefs" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; + Summary.survive_module = false; + Summary.survive_section = false } diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli new file mode 100755 index 00000000..66c1f34d --- /dev/null +++ b/pretyping/recordops.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit + +(* [find_structure isp] returns the infos associated to inductive path + [isp] if it corresponds to a structure, otherwise fails with [Not_found] *) +val find_structure : inductive -> struc_typ + +(* raise [Not_found] if not a projection *) +val find_projection_nparams : global_reference -> int + +type obj_typ = { + o_DEF : constr; + o_TABS : constr list; (* dans l'ordre *) + o_TPARAMS : constr list; (* dans l'ordre *) + o_TCOMPS : constr list } (* dans l'ordre *) + +val objdef_info : (global_reference * global_reference) -> obj_typ +val add_new_objdef : + (global_reference * global_reference) * Term.constr * Term.constr list * + Term.constr list * Term.constr list -> unit + + +val inStruc : inductive * struc_typ -> obj +val outStruc : obj -> inductive * struc_typ +val inObjDef1 : kernel_name -> obj +val outObjDef1 : obj -> kernel_name diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml new file mode 100644 index 00000000..a030dcf2 --- /dev/null +++ b/pretyping/reductionops.ml @@ -0,0 +1,717 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_map -> constr -> constr +type reduction_function = contextual_reduction_function +type local_reduction_function = constr -> constr + +type contextual_stack_reduction_function = + env -> evar_map -> constr -> constr * constr list +type stack_reduction_function = contextual_stack_reduction_function +type local_stack_reduction_function = constr -> constr * constr list + +type contextual_state_reduction_function = + env -> evar_map -> state -> state +type state_reduction_function = contextual_state_reduction_function +type local_state_reduction_function = state -> state + +(*************************************) +(*** Reduction Functions Operators ***) +(*************************************) + +let rec whd_state (x, stack as s) = + match kind_of_term x with + | App (f,cl) -> whd_state (f, append_stack cl stack) + | Cast (c,_) -> whd_state (c, stack) + | _ -> s + +let appterm_of_stack (f,s) = (f,list_of_stack s) + +let whd_stack x = appterm_of_stack (whd_state (x, empty_stack)) +let whd_castapp_stack = whd_stack + +let stack_reduction_of_reduction red_fun env sigma s = + let t = red_fun env sigma (app_stack s) in + whd_stack t + +let strong whdfun env sigma t = + let rec strongrec env t = + map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in + strongrec env t + +let local_strong whdfun = + let rec strongrec t = map_constr strongrec (whdfun t) in + strongrec + +let rec strong_prodspine redfun c = + let x = redfun c in + match kind_of_term x with + | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun b) + | _ -> x + +(*************************************) +(*** Reduction using bindingss ***) +(*************************************) + +(* This signature is very similar to Closure.RedFlagsSig except there + is eta but no per-constant unfolding *) + +module type RedFlagsSig = sig + type flags + type flag + val fbeta : flag + val fevar : flag + val fdelta : flag + val feta : flag + val fiota : flag + val fzeta : flag + val mkflags : flag list -> flags + val red_beta : flags -> bool + val red_delta : flags -> bool + val red_evar : flags -> bool + val red_eta : flags -> bool + val red_iota : flags -> bool + val red_zeta : flags -> bool +end + +(* Naive Implementation +module RedFlags = (struct + type flag = BETA | DELTA | EVAR | IOTA | ZETA | ETA + type flags = flag list + let fbeta = BETA + let fdelta = DELTA + let fevar = EVAR + let fiota = IOTA + let fzeta = ZETA + let feta = ETA + let mkflags l = l + let red_beta = List.mem BETA + let red_delta = List.mem DELTA + let red_evar = List.mem EVAR + let red_eta = List.mem ETA + let red_iota = List.mem IOTA + let red_zeta = List.mem ZETA +end : RedFlagsSig) +*) + +(* Compact Implementation *) +module RedFlags = (struct + type flag = int + type flags = int + let fbeta = 1 + let fdelta = 2 + let fevar = 4 + let feta = 8 + let fiota = 16 + let fzeta = 32 + let mkflags = List.fold_left (lor) 0 + let red_beta f = f land fbeta <> 0 + let red_delta f = f land fdelta <> 0 + let red_evar f = f land fevar <> 0 + let red_eta f = f land feta <> 0 + let red_iota f = f land fiota <> 0 + let red_zeta f = f land fzeta <> 0 +end : RedFlagsSig) + +open RedFlags + +(* Local *) +let beta = mkflags [fbeta] +let evar = mkflags [fevar] +let betaevar = mkflags [fevar; fbeta] +let betaiota = mkflags [fiota; fbeta] +let betaiotazeta = mkflags [fiota; fbeta;fzeta] + +(* Contextual *) +let delta = mkflags [fdelta;fevar] +let betadelta = mkflags [fbeta;fdelta;fzeta;fevar] +let betadeltaeta = mkflags [fbeta;fdelta;fzeta;fevar;feta] +let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fevar;fiota] +let betadeltaiota_nolet = mkflags [fbeta;fdelta;fevar;fiota] +let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fevar;fiota;feta] +let betaiotaevar = mkflags [fbeta;fiota;fevar] +let betaetalet = mkflags [fbeta;feta;fzeta] +let betalet = mkflags [fbeta;fzeta] + +(* Beta Reduction tools *) + +let rec stacklam recfun env t stack = + match (decomp_stack stack,kind_of_term t) with + | Some (h,stacktl), Lambda (_,_,c) -> stacklam recfun (h::env) c stacktl + | _ -> recfun (substl env t, stack) + +let beta_applist (c,l) = + stacklam app_stack [] c (append_stack (Array.of_list l) empty_stack) + +(* Iota reduction tools *) + +type 'a miota_args = { + mP : constr; (* the result type *) + mconstr : constr; (* the constructor *) + mci : case_info; (* special info to re-build pattern *) + mcargs : 'a list; (* the constructor's arguments *) + mlf : 'a array } (* the branch code vector *) + +let reducible_mind_case c = match kind_of_term c with + | Construct _ | CoFix _ -> true + | _ -> false + +let contract_cofix (bodynum,(types,names,bodies as typedbodies)) = + let nbodies = Array.length bodies in + let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in + substl (list_tabulate make_Fi nbodies) bodies.(bodynum) + +let reduce_mind_case mia = + match kind_of_term mia.mconstr with + | Construct (ind_sp,i as cstr_sp) -> +(* let ncargs = (fst mia.mci).(i-1) in*) + let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in + applist (mia.mlf.(i-1),real_cargs) + | CoFix cofix -> + let cofix_def = contract_cofix cofix in + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + | _ -> assert false + +(* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce + Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) + +let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) = + let nbodies = Array.length recindices in + let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in + substl (list_tabulate make_Fi nbodies) bodies.(bodynum) + +let fix_recarg ((recindices,bodynum),_) stack = + assert (0 <= bodynum & bodynum < Array.length recindices); + let recargnum = Array.get recindices bodynum in + try + Some (recargnum, stack_nth stack recargnum) + with Not_found -> + None + +type fix_reduction_result = NotReducible | Reduced of state + +let reduce_fix whdfun fix stack = + match fix_recarg fix stack with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = whdfun (recarg, empty_stack) in + let stack' = stack_assign stack recargnum (app_stack recarg') in + (match kind_of_term recarg'hd with + | Construct _ -> Reduced (contract_fix fix, stack') + | _ -> NotReducible) + +(* Generic reduction function *) + +(* Y avait un commentaire pour whd_betadeltaiota : + + NB : Cette fonction alloue peu c'est l'appel + ``let (c,cargs) = whfun (recarg, empty_stack)'' + ------------------- + qui coute cher *) + +let rec whd_state_gen flags env sigma = + let rec whrec (x, stack as s) = + match kind_of_term x with + | Rel n when red_delta flags -> + (match lookup_rel n env with + | (_,Some body,_) -> whrec (lift n body, stack) + | _ -> s) + | Var id when red_delta flags -> + (match lookup_named id env with + | (_,Some body,_) -> whrec (body, stack) + | _ -> s) + | Evar ev when red_evar flags -> + (match existential_opt_value sigma ev with + | Some body -> whrec (body, stack) + | None -> s) + | Const const when red_delta flags -> + (match constant_opt_value env const with + | Some body -> whrec (body, stack) + | None -> s) + | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack + | Cast (c,_) -> whrec (c, stack) + | App (f,cl) -> whrec (f, append_stack cl stack) + | Lambda (na,t,c) -> + (match decomp_stack stack with + | Some (a,m) when red_beta flags -> stacklam whrec [a] c m + | None when red_eta flags -> + let env' = push_rel (na,None,t) env in + let whrec' = whd_state_gen flags env' sigma in + (match kind_of_term (app_stack (whrec' (c, empty_stack))) with + | App (f,cl) -> + let napp = Array.length cl in + if napp > 0 then + let x', l' = whrec' (array_last cl, empty_stack) in + match kind_of_term x', decomp_stack l' with + | Rel 1, None -> + let lc = Array.sub cl 0 (napp-1) in + let u = if napp=1 then f else appvect (f,lc) in + if noccurn 1 u then (pop u,empty_stack) else s + | _ -> s + else s + | _ -> s) + | _ -> s) + + | Case (ci,p,d,lf) when red_iota flags -> + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack (c,cargs), lf), stack) + + | Fix fix when red_iota flags -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + + | x -> s + in + whrec + +let local_whd_state_gen flags = + let rec whrec (x, stack as s) = + match kind_of_term x with + | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack + | Cast (c,_) -> whrec (c, stack) + | App (f,cl) -> whrec (f, append_stack cl stack) + | Lambda (_,_,c) -> + (match decomp_stack stack with + | Some (a,m) when red_beta flags -> stacklam whrec [a] c m + | None when red_eta flags -> + (match kind_of_term (app_stack (whrec (c, empty_stack))) with + | App (f,cl) -> + let napp = Array.length cl in + if napp > 0 then + let x', l' = whrec (array_last cl, empty_stack) in + match kind_of_term x', decomp_stack l' with + | Rel 1, None -> + let lc = Array.sub cl 0 (napp-1) in + let u = if napp=1 then f else appvect (f,lc) in + if noccurn 1 u then (pop u,empty_stack) else s + | _ -> s + else s + | _ -> s) + | _ -> s) + + | Case (ci,p,d,lf) when red_iota flags -> + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack (c,cargs), lf), stack) + + | Fix fix when red_iota flags -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + + | x -> s + in + whrec + +(* 1. Beta Reduction Functions *) + +let whd_beta_state = local_whd_state_gen beta +let whd_beta_stack x = appterm_of_stack (whd_beta_state (x, empty_stack)) +let whd_beta x = app_stack (whd_beta_state (x,empty_stack)) + +(* Nouveau ! *) +let whd_betaetalet_state = local_whd_state_gen betaetalet +let whd_betaetalet_stack x = + appterm_of_stack (whd_betaetalet_state (x, empty_stack)) +let whd_betaetalet x = app_stack (whd_betaetalet_state (x,empty_stack)) + +let whd_betalet_state = local_whd_state_gen betalet +let whd_betalet_stack x = appterm_of_stack (whd_betalet_state (x, empty_stack)) +let whd_betalet x = app_stack (whd_betalet_state (x,empty_stack)) + +(* 2. Delta Reduction Functions *) + +let whd_delta_state e = whd_state_gen delta e +let whd_delta_stack env sigma x = + appterm_of_stack (whd_delta_state env sigma (x, empty_stack)) +let whd_delta env sigma c = + app_stack (whd_delta_state env sigma (c, empty_stack)) + +let whd_betadelta_state e = whd_state_gen betadelta e +let whd_betadelta_stack env sigma x = + appterm_of_stack (whd_betadelta_state env sigma (x, empty_stack)) +let whd_betadelta env sigma c = + app_stack (whd_betadelta_state env sigma (c, empty_stack)) + +let whd_betaevar_state e = whd_state_gen betaevar e +let whd_betaevar_stack env sigma c = + appterm_of_stack (whd_betaevar_state env sigma (c, empty_stack)) +let whd_betaevar env sigma c = + app_stack (whd_betaevar_state env sigma (c, empty_stack)) + + +let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e +let whd_betadeltaeta_stack env sigma x = + appterm_of_stack (whd_betadeltaeta_state env sigma (x, empty_stack)) +let whd_betadeltaeta env sigma x = + app_stack (whd_betadeltaeta_state env sigma (x, empty_stack)) + +(* 3. Iota reduction Functions *) + +let whd_betaiota_state = local_whd_state_gen betaiota +let whd_betaiota_stack x = + appterm_of_stack (whd_betaiota_state (x, empty_stack)) +let whd_betaiota x = + app_stack (whd_betaiota_state (x, empty_stack)) + +let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta +let whd_betaiotazeta_stack x = + appterm_of_stack (whd_betaiotazeta_state (x, empty_stack)) +let whd_betaiotazeta x = + app_stack (whd_betaiotazeta_state (x, empty_stack)) + +let whd_betaiotaevar_state e = whd_state_gen betaiotaevar e +let whd_betaiotaevar_stack env sigma x = + appterm_of_stack (whd_betaiotaevar_state env sigma (x, empty_stack)) +let whd_betaiotaevar env sigma x = + app_stack (whd_betaiotaevar_state env sigma (x, empty_stack)) + +let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e +let whd_betadeltaiota_stack env sigma x = + appterm_of_stack (whd_betadeltaiota_state env sigma (x, empty_stack)) +let whd_betadeltaiota env sigma x = + app_stack (whd_betadeltaiota_state env sigma (x, empty_stack)) + +let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e +let whd_betadeltaiotaeta_stack env sigma x = + appterm_of_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack)) +let whd_betadeltaiotaeta env sigma x = + app_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack)) + +let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e +let whd_betadeltaiota_nolet_stack env sigma x = + appterm_of_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack)) +let whd_betadeltaiota_nolet env sigma x = + app_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack)) + +(****************************************************************************) +(* Reduction Functions *) +(****************************************************************************) + +(* Replacing defined evars for error messages *) +let rec whd_evar sigma c = + match kind_of_term c with + | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> + whd_evar sigma (Instantiate.existential_value sigma (ev,args)) + | _ -> collapse_appl c + +let nf_evar sigma = + local_strong (whd_evar sigma) + +(* lazy reduction functions. The infos must be created for each term *) +let clos_norm_flags flgs env sigma t = + norm_val (create_clos_infos flgs env) (inject (nf_evar sigma t)) + +let nf_beta = clos_norm_flags Closure.beta empty_env Evd.empty +let nf_betaiota = clos_norm_flags Closure.betaiota empty_env Evd.empty +let nf_betadeltaiota env sigma = + clos_norm_flags Closure.betadeltaiota env sigma + +(* lazy weak head reduction functions *) +let whd_flags flgs env sigma t = + whd_val (create_clos_infos flgs env) (inject (nf_evar sigma t)) + +(********************************************************************) +(* Conversion *) +(********************************************************************) +(* +let fkey = Profile.declare_profile "fhnf";; +let fhnf info v = Profile.profile2 fkey fhnf info v;; + +let fakey = Profile.declare_profile "fhnf_apply";; +let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;; +*) + +(* Conversion utility functions *) + +type conversion_test = constraints -> constraints + +type conv_pb = + | CONV + | CUMUL + +let pb_is_equal pb = pb = CONV + +let pb_equal = function + | CUMUL -> CONV + | CONV -> CONV + +let sort_cmp pb s0 s1 cuniv = + match (s0,s1) with + | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible + | (Prop c1, Type u) -> + (match pb with + CUMUL -> cuniv + | _ -> raise NotConvertible) + | (Type u1, Type u2) -> + (match pb with + | CONV -> enforce_eq u1 u2 cuniv + | CUMUL -> enforce_geq u2 u1 cuniv) + | (_, _) -> raise NotConvertible + +let base_sort_cmp pb s0 s1 = + match (s0,s1) with + | (Prop c1, Prop c2) -> c1 = c2 + | (Prop c1, Type u) -> pb = CUMUL + | (Type u1, Type u2) -> true + | (_, _) -> false + + +let test_conversion f env sigma x y = + try let _ = f env (nf_evar sigma x) (nf_evar sigma y) in true + with NotConvertible -> false + +let is_conv env sigma = test_conversion Reduction.conv env sigma +let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma +let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq + +(********************************************************************) +(* Special-Purpose Reduction *) +(********************************************************************) + +let whd_meta metamap c = match kind_of_term c with + | Meta p -> (try List.assoc p metamap with Not_found -> c) + | _ -> c + +(* Try to replace all metas. Does not replace metas in the metas' values + * Differs from (strong whd_meta). *) +let plain_instance s c = + let rec irec u = match kind_of_term u with + | Meta p -> (try List.assoc p s with Not_found -> u) + | App (f,l) when isCast f -> + let (f,t) = destCast f in + let l' = Array.map irec l in + (match kind_of_term f with + | Meta p -> + (* Don't flatten application nodes: this is used to extract a + proof-term from a proof-tree and we want to keep the structure + of the proof-tree *) + (try let g = List.assoc p s in + match kind_of_term g with + | App _ -> + let h = id_of_string "H" in + mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l')) + | _ -> mkApp (g,l') + with Not_found -> mkApp (f,l')) + | _ -> mkApp (irec f,l')) + | Cast (m,_) when isMeta m -> + (try List.assoc (destMeta m) s with Not_found -> u) + | _ -> map_constr irec u + in + if s = [] then c else irec c + +(* Pourquoi ne fait-on pas nf_betaiota si s=[] ? *) +let instance s c = + if s = [] then c else local_strong whd_betaiota (plain_instance s c) + + +(* pseudo-reduction rule: + * [hnf_prod_app env s (Prod(_,B)) N --> B[N] + * with an HNF on the first argument to produce a product. + * if this does not work, then we use the string S as part of our + * error message. *) + +let hnf_prod_app env sigma t n = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Prod (_,_,b) -> subst1 n b + | _ -> anomaly "hnf_prod_app: Need a product" + +let hnf_prod_appvect env sigma t nl = + Array.fold_left (hnf_prod_app env sigma) t nl + +let hnf_prod_applist env sigma t nl = + List.fold_left (hnf_prod_app env sigma) t nl + +let hnf_lam_app env sigma t n = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Lambda (_,_,b) -> subst1 n b + | _ -> anomaly "hnf_lam_app: Need an abstraction" + +let hnf_lam_appvect env sigma t nl = + Array.fold_left (hnf_lam_app env sigma) t nl + +let hnf_lam_applist env sigma t nl = + List.fold_left (hnf_lam_app env sigma) t nl + +let splay_prod env sigma = + let rec decrec env m c = + let t = whd_betadeltaiota env sigma c in + match kind_of_term t with + | Prod (n,a,c0) -> + decrec (push_rel (n,None,a) env) + ((n,a)::m) c0 + | _ -> m,t + in + decrec env [] + +let splay_prod_assum env sigma = + let rec prodec_rec env l c = + let t = whd_betadeltaiota_nolet env sigma c in + match kind_of_term c with + | Prod (x,t,c) -> + prodec_rec (push_rel (x,None,t) env) + (Sign.add_rel_decl (x, None, t) l) c + | LetIn (x,b,t,c) -> + prodec_rec (push_rel (x, Some b, t) env) + (Sign.add_rel_decl (x, Some b, t) l) c + | Cast (c,_) -> prodec_rec env l c + | _ -> l,t + in + prodec_rec env Sign.empty_rel_context + +let splay_arity env sigma c = + let l, c = splay_prod env sigma c in + match kind_of_term c with + | Sort s -> l,s + | _ -> error "not an arity" + +let sort_of_arity env c = snd (splay_arity env Evd.empty c) + +let decomp_n_prod env sigma n = + let rec decrec env m ln c = if m = 0 then (ln,c) else + match kind_of_term (whd_betadeltaiota env sigma c) with + | Prod (n,a,c0) -> + decrec (push_rel (n,None,a) env) + (m-1) (Sign.add_rel_decl (n,None,a) ln) c0 + | _ -> error "decomp_n_prod: Not enough products" + in + decrec env n Sign.empty_rel_context + +(* One step of approximation *) + +let rec apprec env sigma s = + let (t, stack as s) = whd_betaiota_state s in + match kind_of_term t with + | Case (ci,p,d,lf) -> + let (cr,crargs) = whd_betadeltaiota_stack env sigma d in + let rslt = mkCase (ci, p, applist (cr,crargs), lf) in + if reducible_mind_case cr then + apprec env sigma (rslt, stack) + else + s + | Fix fix -> + (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with + | Reduced s -> apprec env sigma s + | NotReducible -> s) + | _ -> s + +let hnf env sigma c = apprec env sigma (c, empty_stack) + +(* A reduction function like whd_betaiota but which keeps casts + * and does not reduce redexes containing existential variables. + * Used in Correctness. + * Added by JCF, 29/1/98. *) + +let whd_programs_stack env sigma = + let rec whrec (x, stack as s) = + match kind_of_term x with + | App (f,cl) -> + let n = Array.length cl - 1 in + let c = cl.(n) in + if occur_existential c then + s + else + whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack) + | LetIn (_,b,_,c) -> + if occur_existential b then + s + else + stacklam whrec [b] c stack + | Lambda (_,_,c) -> + (match decomp_stack stack with + | None -> s + | Some (a,m) -> stacklam whrec [a] c m) + | Case (ci,p,d,lf) -> + if occur_existential d then + s + else + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack(c,cargs), lf), stack) + | Fix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s + in + whrec + +let whd_programs env sigma x = + app_stack (whd_programs_stack env sigma (x, empty_stack)) + +exception IsType + +let find_conclusion env sigma = + let rec decrec env c = + let t = whd_betadeltaiota env sigma c in + match kind_of_term t with + | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 + | t -> t + in + decrec env + +let is_arity env sigma c = + match find_conclusion env sigma c with + | Sort _ -> true + | _ -> false + +let info_arity env sigma c = + match find_conclusion env sigma c with + | Sort (Prop Null) -> false + | Sort (Prop Pos) -> true + | _ -> raise IsType + +let is_info_arity env sigma c = + try (info_arity env sigma c) with IsType -> true + +let is_type_arity env sigma c = + match find_conclusion env sigma c with + | Sort (Type _) -> true + | _ -> false + +let is_info_type env sigma t = + let s = t.utj_type in + (s = Prop Pos) || + (s <> Prop Null && + try info_arity env sigma t.utj_val with IsType -> true) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli new file mode 100644 index 00000000..65cdd5cd --- /dev/null +++ b/pretyping/reductionops.mli @@ -0,0 +1,190 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_map -> constr -> constr +type reduction_function = contextual_reduction_function +type local_reduction_function = constr -> constr + +type contextual_stack_reduction_function = + env -> evar_map -> constr -> constr * constr list +type stack_reduction_function = contextual_stack_reduction_function +type local_stack_reduction_function = constr -> constr * constr list + +type contextual_state_reduction_function = + env -> evar_map -> state -> state +type state_reduction_function = contextual_state_reduction_function +type local_state_reduction_function = state -> state + +(* Removes cast and put into applicative form *) +val whd_stack : local_stack_reduction_function + +(* For compatibility: alias for whd\_stack *) +val whd_castapp_stack : local_stack_reduction_function + +(*s Reduction Function Operators *) + +val strong : reduction_function -> reduction_function +val local_strong : local_reduction_function -> local_reduction_function +val strong_prodspine : local_reduction_function -> local_reduction_function +(*i +val stack_reduction_of_reduction : + 'a reduction_function -> 'a state_reduction_function +i*) +val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a + +(*s Generic Optimized Reduction Function using Closures *) + +val clos_norm_flags : Closure.RedFlags.reds -> reduction_function +(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) +val nf_beta : local_reduction_function +val nf_betaiota : local_reduction_function +val nf_betadeltaiota : reduction_function +val nf_evar : evar_map -> constr -> constr + +(* Lazy strategy, weak head reduction *) +val whd_evar : evar_map -> constr -> constr +val whd_beta : local_reduction_function +val whd_betaiota : local_reduction_function +val whd_betaiotazeta : local_reduction_function +val whd_betadeltaiota : contextual_reduction_function +val whd_betadeltaiota_nolet : contextual_reduction_function +val whd_betaetalet : local_reduction_function +val whd_betalet : local_reduction_function + +val whd_beta_stack : local_stack_reduction_function +val whd_betaiota_stack : local_stack_reduction_function +val whd_betaiotazeta_stack : local_stack_reduction_function +val whd_betadeltaiota_stack : contextual_stack_reduction_function +val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function +val whd_betaetalet_stack : local_stack_reduction_function +val whd_betalet_stack : local_stack_reduction_function + +val whd_state : local_state_reduction_function +val whd_beta_state : local_state_reduction_function +val whd_betaiota_state : local_state_reduction_function +val whd_betaiotazeta_state : local_state_reduction_function +val whd_betadeltaiota_state : contextual_state_reduction_function +val whd_betadeltaiota_nolet_state : contextual_state_reduction_function +val whd_betaetalet_state : local_state_reduction_function +val whd_betalet_state : local_state_reduction_function + +(*s Head normal forms *) + +val whd_delta_stack : stack_reduction_function +val whd_delta_state : state_reduction_function +val whd_delta : reduction_function +val whd_betadelta_stack : stack_reduction_function +val whd_betadelta_state : state_reduction_function +val whd_betadelta : reduction_function +val whd_betaevar_stack : stack_reduction_function +val whd_betaevar_state : state_reduction_function +val whd_betaevar : reduction_function +val whd_betaiotaevar_stack : stack_reduction_function +val whd_betaiotaevar_state : state_reduction_function +val whd_betaiotaevar : reduction_function +val whd_betadeltaeta_stack : stack_reduction_function +val whd_betadeltaeta_state : state_reduction_function +val whd_betadeltaeta : reduction_function +val whd_betadeltaiotaeta_stack : stack_reduction_function +val whd_betadeltaiotaeta_state : state_reduction_function +val whd_betadeltaiotaeta : reduction_function + +val beta_applist : constr * constr list -> constr + +val hnf_prod_app : env -> evar_map -> constr -> constr -> constr +val hnf_prod_appvect : env -> evar_map -> constr -> constr array -> constr +val hnf_prod_applist : env -> evar_map -> constr -> constr list -> constr +val hnf_lam_app : env -> evar_map -> constr -> constr -> constr +val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr +val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr + +val splay_prod : env -> evar_map -> constr -> (name * constr) list * constr +val splay_arity : env -> evar_map -> constr -> (name * constr) list * sorts +val sort_of_arity : env -> constr -> sorts +val decomp_n_prod : + env -> evar_map -> int -> constr -> Sign.rel_context * constr +val splay_prod_assum : + env -> evar_map -> constr -> Sign.rel_context * constr + +type 'a miota_args = { + mP : constr; (* the result type *) + mconstr : constr; (* the constructor *) + mci : case_info; (* special info to re-build pattern *) + mcargs : 'a list; (* the constructor's arguments *) + mlf : 'a array } (* the branch code vector *) + +val reducible_mind_case : constr -> bool +val reduce_mind_case : constr miota_args -> constr + +val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term +val is_arity : env -> evar_map -> constr -> bool +val is_info_type : env -> evar_map -> unsafe_type_judgment -> bool +val is_info_arity : env -> evar_map -> constr -> bool +(*i Pour l'extraction +val is_type_arity : env -> 'a evar_map -> constr -> bool +val is_info_cast_type : env -> 'a evar_map -> constr -> bool +val contents_of_cast_type : env -> 'a evar_map -> constr -> contents +i*) + +val whd_programs : reduction_function + +(* [reduce_fix] contracts a fix redex if it is actually reducible *) + +type fix_reduction_result = NotReducible | Reduced of state + +val fix_recarg : fixpoint -> constr stack -> (int * constr) option +val reduce_fix : local_state_reduction_function -> fixpoint + -> constr stack -> fix_reduction_result + +(*s Conversion Functions (uses closures, lazy strategy) *) + +type conversion_test = constraints -> constraints + +type conv_pb = + | CONV + | CUMUL + +val pb_is_equal : conv_pb -> bool +val pb_equal : conv_pb -> conv_pb + +val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test +val base_sort_cmp : conv_pb -> sorts -> sorts -> bool + +val is_conv : env -> evar_map -> constr -> constr -> bool +val is_conv_leq : env -> evar_map -> constr -> constr -> bool +val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool + +(*s Special-Purpose Reduction Functions *) + +val whd_meta : (metavariable * constr) list -> constr -> constr +val plain_instance : (metavariable * constr) list -> constr -> constr +val instance : (metavariable * constr) list -> constr -> constr + +(*s Obsolete Reduction Functions *) + +(*i +val hnf : env -> 'a evar_map -> constr -> constr * constr list +i*) +val apprec : state_reduction_function diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml new file mode 100644 index 00000000..061382f7 --- /dev/null +++ b/pretyping/retyping.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* s + | _ -> anomaly "Retyping: found a type of type which is not a sort" + +let rec subst_type env sigma typ = function + | [] -> typ + | h::rest -> + match kind_of_term (whd_betadeltaiota env sigma typ) with + | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest + | _ -> anomaly "Non-functional construction" + +(* Si ft est le type d'un terme f, lequel est appliqué à args, *) +(* [sort_of_atomic_ty] calcule ft[args] qui doit être une sorte *) +(* On suit une méthode paresseuse, en espèrant que ft est une arité *) +(* et sinon on substitue *) + +let sort_of_atomic_type env sigma ft args = + let rec concl_of_arity env ar = + match kind_of_term (whd_betadeltaiota env sigma ar) with + | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b + | Sort s -> s + | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) + in concl_of_arity env ft + +let typeur sigma metamap = + let rec type_of env cstr= + match kind_of_term cstr with + | Meta n -> + (try strip_outer_cast (List.assoc n metamap) + with Not_found -> anomaly "type_of: this is not a well-typed term") + | Rel n -> + let (_,_,ty) = lookup_rel n env in + lift n ty + | Var id -> + (try + let (_,_,ty) = lookup_named id env in + body_of_type ty + with Not_found -> + anomaly ("type_of: variable "^(string_of_id id)^" unbound")) + | Const c -> + let cb = lookup_constant c env in + body_of_type cb.const_type + | Evar ev -> existential_type sigma ev + | Ind ind -> body_of_type (type_of_inductive env ind) + | Construct cstr -> body_of_type (type_of_constructor env cstr) + | Case (_,p,c,lf) -> + let Inductiveops.IndType(_,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> anomaly "type_of: Bad recursive type" in + let t = whd_beta (applist (p, realargs)) in + (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with + | Prod _ -> whd_beta (applist (t, [c])) + | _ -> t) + | Lambda (name,c1,c2) -> + mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2) + | LetIn (name,b,c1,c2) -> + subst1 b (type_of (push_rel (name,Some b,c1) env) c2) + | Fix ((_,i),(_,tys,_)) -> tys.(i) + | CoFix (i,(_,tys,_)) -> tys.(i) + | App(f,args)-> + strip_outer_cast + (subst_type env sigma (type_of env f) (Array.to_list args)) + | Cast (c,t) -> t + | Sort _ | Prod _ -> mkSort (sort_of env cstr) + + and sort_of env t = + match kind_of_term t with + | Cast (c,s) when isSort s -> destSort s + | Sort (Prop c) -> type_0 + | Sort (Type u) -> Type (Univ.super u) + | Prod (name,t,c2) -> + (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with + | _, (Prop Null as s) -> s + | Prop _, (Prop Pos as s) -> s + | Type _, (Prop Pos as s) when + Environ.engagement env = Some ImpredicativeSet -> s + | Type _ as s, Prop Pos -> s + | _, (Type u2 as s) -> s (*Type Univ.dummy_univ*)) + | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args + | Lambda _ | Fix _ | Construct _ -> + anomaly "sort_of: Not a type (1)" + | _ -> outsort env sigma (type_of env t) + + and sort_family_of env t = + match kind_of_term t with + | Cast (c,s) when isSort s -> family_of_sort (destSort s) + | Sort (Prop c) -> InType + | Sort (Type u) -> InType + | Prod (name,t,c2) -> sort_family_of (push_rel (name,None,t) env) c2 + | App(f,args) -> + family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) + | Lambda _ | Fix _ | Construct _ -> + anomaly "sort_of: Not a type (1)" + | _ -> family_of_sort (outsort env sigma (type_of env t)) + + in type_of, sort_of, sort_family_of + +let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c +let get_sort_of env sigma t = let _,f,_ = typeur sigma [] in f env t +let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c + +let get_type_of_with_meta env sigma metamap = + let f,_,_ = typeur sigma metamap in f env + +(* Makes an assumption from a constr *) +let get_assumption_of env evc c = c + +(* Makes an unsafe judgment from a constr *) +let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } + diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli new file mode 100644 index 00000000..f29ac8d8 --- /dev/null +++ b/pretyping/retyping.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_map -> constr -> constr +val get_sort_of : env -> evar_map -> types -> sorts +val get_sort_family_of : env -> evar_map -> types -> sorts_family + +val get_type_of_with_meta : env -> evar_map -> metamap -> constr -> constr + +(* Makes an assumption from a constr *) +val get_assumption_of : env -> evar_map -> constr -> types + +(* Makes an unsafe judgment from a constr *) +val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml new file mode 100644 index 00000000..7e79a4fe --- /dev/null +++ b/pretyping/tacred.ml @@ -0,0 +1,953 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None & cb.const_opaque then + errorlabstrm "set_transparent_const" + (str "Cannot make" ++ spc () ++ + Nametab.pr_global_env Idset.empty (ConstRef sp) ++ + spc () ++ str "transparent because it was declared opaque."); + Conv_oracle.set_transparent_const sp + +let set_opaque_var = Conv_oracle.set_opaque_var +let set_transparent_var = Conv_oracle.set_transparent_var + +let _ = + Summary.declare_summary "Transparent constants and variables" + { Summary.freeze_function = Conv_oracle.freeze; + Summary.unfreeze_function = Conv_oracle.unfreeze; + Summary.init_function = Conv_oracle.init; + Summary.survive_module = false; + Summary.survive_section = false } + +let is_evaluable env ref = + match ref with + EvalConstRef kn -> + let (ids,kns) = Conv_oracle.freeze() in + KNpred.mem kn kns & + let cb = Environ.lookup_constant kn env in + cb.const_body <> None & not cb.const_opaque + | EvalVarRef id -> + let (ids,sps) = Conv_oracle.freeze() in + Idpred.mem id ids & + let (_,value,_) = Environ.lookup_named id env in + value <> None + +type evaluable_reference = + | EvalConst of constant + | EvalVar of identifier + | EvalRel of int + | EvalEvar of existential + +let mkEvalRef = function + | EvalConst cst -> mkConst cst + | EvalVar id -> mkVar id + | EvalRel n -> mkRel n + | EvalEvar ev -> mkEvar ev + +let isEvalRef env c = match kind_of_term c with + | Const sp -> is_evaluable env (EvalConstRef sp) + | Var id -> is_evaluable env (EvalVarRef id) + | Rel _ | Evar _ -> true + | _ -> false + +let destEvalRef c = match kind_of_term c with + | Const cst -> EvalConst cst + | Var id -> EvalVar id + | Rel n -> EvalRel n + | Evar ev -> EvalEvar ev + | _ -> anomaly "Not an evaluable reference" + +let reference_opt_value sigma env = function + | EvalConst cst -> constant_opt_value env cst + | EvalVar id -> + let (_,v,_) = lookup_named id env in + v + | EvalRel n -> + let (_,v,_) = lookup_rel n env in + option_app (lift n) v + | EvalEvar ev -> existential_opt_value sigma ev + +exception NotEvaluable +let reference_value sigma env c = + match reference_opt_value sigma env c with + | None -> raise NotEvaluable + | Some d -> d + +(************************************************************************) +(* Reduction of constant hiding fixpoints (e.g. for Simpl). The trick *) +(* is to reuse the name of the function after reduction of the fixpoint *) + +type constant_evaluation = + | EliminationFix of int * (int * (int * constr) list * int) + | EliminationMutualFix of + int * evaluable_reference * + (evaluable_reference option array * (int * (int * constr) list * int)) + | EliminationCases of int + | NotAnElimination + +(* We use a cache registered as a global table *) + + +module CstOrdered = + struct + type t = constant + let compare = Pervasives.compare + end +module Cstmap = Map.Make(CstOrdered) + +let eval_table = ref Cstmap.empty + +type frozen = (int * constant_evaluation) Cstmap.t + +let init () = + eval_table := Cstmap.empty + +let freeze () = + !eval_table + +let unfreeze ct = + eval_table := ct + +let _ = + Summary.declare_summary "evaluation" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; + Summary.survive_module = false; + Summary.survive_section = false } + + +(* Check that c is an "elimination constant" + [xn:An]..[x1:A1](

MutCase (Rel i) of f1..fk end g1 ..gp) + or [xn:An]..[x1:A1](Fix(f|t) (Rel i1) ..(Rel ip)) + with i1..ip distinct variables not occuring in t + keep relevenant information ([i1,Ai1;..;ip,Aip],n,b) + with b = true in case of a fixpoint in order to compute + an equivalent of Fix(f|t)[xi<-ai] as + [yip:Bip]..[yi1:Bi1](F bn..b1) + == [yip:Bip]..[yi1:Bi1](Fix(f|t)[xi<-ai] (Rel 1)..(Rel p)) + with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1] *) + +let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = + let n = List.length labs in + let nargs = List.length args in + if nargs > n then raise Elimconst; + let nbfix = Array.length bds in + let li = + List.map + (function d -> match kind_of_term d with + | Rel k -> + if + array_for_all (noccurn k) tys + && array_for_all (noccurn (k+nbfix)) bds + then + (k, List.nth labs (k-1)) + else + raise Elimconst + | _ -> + raise Elimconst) args + in + if list_distinct (List.map fst li) then + let k = lv.(i) in + if k < nargs then +(* Such an optimisation would need eta-expansion + let p = destRel (List.nth args k) in + EliminationFix (n-p+1,(nbfix,li,n)) +*) + EliminationFix (n,(nbfix,li,n)) + else + EliminationFix (n-nargs+lv.(i)+1,(nbfix,li,n)) + else + raise Elimconst + +(* Heuristic to look if global names are associated to other + components of a mutual fixpoint *) + +let invert_name labs l na0 env sigma ref = function + | Name id -> + if na0 <> Name id then + let refi = match ref with + | EvalRel _ | EvalEvar _ -> None + | EvalVar id' -> Some (EvalVar id) + | EvalConst kn -> + let (mp,dp,_) = repr_kn kn in + Some (EvalConst (make_kn mp dp (label_of_id id))) in + match refi with + | None -> None + | Some ref -> + match reference_opt_value sigma env ref with + | None -> None + | Some c -> + let labs',ccl = decompose_lam c in + let _, l' = whd_betalet_stack ccl in + let labs' = List.map snd labs' in + if labs' = labs & l = l' then Some ref else None + else Some ref + | Anonymous -> None (* Actually, should not occur *) + +(* [compute_consteval_direct] expand all constant in a whole, but + [compute_consteval_mutual_fix] only one by one, until finding the + last one before the Fix if the latter is mutually defined *) + +let compute_consteval_direct sigma env ref = + let rec srec env n labs c = + let c',l = whd_betadelta_stack env sigma c in + match kind_of_term c' with + | Lambda (id,t,g) when l=[] -> + srec (push_rel (id,None,t) env) (n+1) (t::labs) g + | Fix fix -> + (try check_fix_reversibility labs l fix + with Elimconst -> NotAnElimination) + | Case (_,_,d,_) when isRel d -> EliminationCases n + | _ -> NotAnElimination + in + match reference_opt_value sigma env ref with + | None -> NotAnElimination + | Some c -> srec env 0 [] c + +let compute_consteval_mutual_fix sigma env ref = + let rec srec env minarg labs ref c = + let c',l = whd_betalet_stack c in + let nargs = List.length l in + match kind_of_term c' with + | Lambda (na,t,g) when l=[] -> + srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g + | Fix ((lv,i),(names,_,_) as fix) -> + (* Last known constant wrapping Fix is ref = [labs](Fix l) *) + (match compute_consteval_direct sigma env ref with + | NotAnElimination -> (*Above const was eliminable but this not!*) + NotAnElimination + | EliminationFix (minarg',infos) -> + let refs = + Array.map + (invert_name labs l names.(i) env sigma ref) names in + let new_minarg = max (minarg'+minarg-nargs) minarg' in + EliminationMutualFix (new_minarg,ref,(refs,infos)) + | _ -> assert false) + | _ when isEvalRef env c' -> + (* Forget all \'s and args and do as if we had started with c' *) + let ref = destEvalRef c' in + (match reference_opt_value sigma env ref with + | None -> anomaly "Should have been trapped by compute_direct" + | Some c -> srec env (minarg-nargs) [] ref c) + | _ -> (* Should not occur *) NotAnElimination + in + match reference_opt_value sigma env ref with + | None -> (* Should not occur *) NotAnElimination + | Some c -> srec env 0 [] ref c + +let compute_consteval sigma env ref = + match compute_consteval_direct sigma env ref with + | EliminationFix (_,(nbfix,_,_)) when nbfix <> 1 -> + compute_consteval_mutual_fix sigma env ref + | elim -> elim + +let reference_eval sigma env = function + | EvalConst cst as ref -> + (try + Cstmap.find cst !eval_table + with Not_found -> begin + let v = compute_consteval sigma env ref in + eval_table := Cstmap.add cst v !eval_table; + v + end) + | ref -> compute_consteval sigma env ref + +let rev_firstn_liftn fn ln = + let rec rfprec p res l = + if p = 0 then + res + else + match l with + | [] -> invalid_arg "Reduction.rev_firstn_liftn" + | a::rest -> rfprec (p-1) ((lift ln a)::res) rest + in + rfprec fn [] + +(* EliminationFix ([(yi1,Ti1);...;(yip,Tip)],n) means f is some + [y1:T1,...,yn:Tn](Fix(..) yi1 ... yip); + f is applied to largs and we need for recursive calls to build + [x1:Ti1',...,xp:Tip'](f a1..a(n-p) yi1 ... yip) + where a1...an are the n first arguments of largs and Tik' is Tik[yil=al] + To check ... *) + +let make_elim_fun (names,(nbfix,lv,n)) largs = + let labs = list_firstn n (list_of_stack largs) in + let p = List.length lv in + let ylv = List.map fst lv in + let la' = list_map_i + (fun q aq -> + try (mkRel (p+1-(list_index (n-q) ylv))) + with Not_found -> aq) 0 + (List.map (lift p) labs) + in + fun i -> + match names.(i) with + | None -> None + | Some ref -> Some ( +(* let fi = + if nbfix = 1 then + mkEvalRef ref + else + match ref with + | EvalConst (sp,args) -> + mkConst (make_path (dirpath sp) id (kind_of_path sp),args) + | _ -> anomaly "elimination of local fixpoints not implemented" + in +*) + list_fold_left_i + (fun i c (k,a) -> + mkLambda (Name(id_of_string"x"), + substl (rev_firstn_liftn (n-k) (-i) la') a, + c)) + 0 (applistc (mkEvalRef ref) la') lv) + +(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)] make + the reduction using this extra information *) + +let contract_fix_use_function f + ((recindices,bodynum),(types,names,bodies as typedbodies)) = + let nbodies = Array.length recindices in + let make_Fi j = match f j with + | None -> mkFix((recindices,j),typedbodies) + | Some c -> c in +(* match List.nth names j with Name id -> f id | _ -> assert false in*) + let lbodies = list_tabulate make_Fi nbodies in + substl (List.rev lbodies) bodies.(bodynum) + +let reduce_fix_use_function f whfun fix stack = + match fix_recarg fix stack with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = + if isRel recarg then + (* The recarg cannot be a local def, no worry about the right env *) + (recarg, empty_stack) + else + whfun (recarg, empty_stack) in + let stack' = stack_assign stack recargnum (app_stack recarg') in + (match kind_of_term recarg'hd with + | Construct _ -> + Reduced (contract_fix_use_function f fix,stack') + | _ -> NotReducible) + +let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) = + let nbodies = Array.length bodies in + let make_Fi j = match f j with + | None -> mkCoFix(j,typedbodies) + | Some c -> c in +(* match List.nth names j with Name id -> f id | _ -> assert false in*) + let subbodies = list_tabulate make_Fi nbodies in + substl subbodies bodies.(bodynum) + +let reduce_mind_case_use_function func env mia = + match kind_of_term mia.mconstr with + | Construct(ind_sp,i as cstr_sp) -> + let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in + applist (mia.mlf.(i-1), real_cargs) + | CoFix (_,(names,_,_) as cofix) -> + let build_fix_name i = + match names.(i) with + | Name id -> + if isConst func then + let (mp,dp,_) = repr_kn (destConst func) in + let kn = make_kn mp dp (label_of_id id) in + (match constant_opt_value env kn with + | None -> None + | Some _ -> Some (mkConst kn)) + else None + | Anonymous -> None in + let cofix_def = contract_cofix_use_function build_fix_name cofix in + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + | _ -> assert false + +let special_red_case sigma env whfun (ci, p, c, lf) = + let rec redrec s = + let (constr, cargs) = whfun s in + if isEvalRef env constr then + let ref = destEvalRef constr in + match reference_opt_value sigma env ref with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case gvalue then + reduce_mind_case_use_function constr env + {mP=p; mconstr=gvalue; mcargs=list_of_stack cargs; + mci=ci; mlf=lf} + else + redrec (gvalue, cargs) + else + if reducible_mind_case constr then + reduce_mind_case + {mP=p; mconstr=constr; mcargs=list_of_stack cargs; + mci=ci; mlf=lf} + else + raise Redelimination + in + redrec (c, empty_stack) + + +let rec red_elim_const env sigma ref largs = + match reference_eval sigma env ref with + | EliminationCases n when stack_args_size largs >= n -> + let c = reference_value sigma env ref in + let c', lrest = whd_betadelta_state env sigma (c,largs) in + (special_red_case sigma env (construct_const env sigma) (destCase c'), + lrest) + | EliminationFix (min,infos) when stack_args_size largs >=min -> + let c = reference_value sigma env ref in + let d, lrest = whd_betadelta_state env sigma (c,largs) in + let f = make_elim_fun ([|Some ref|],infos) largs in + let co = construct_const env sigma in + (match reduce_fix_use_function f co (destFix d) lrest with + | NotReducible -> raise Redelimination + | Reduced (c,rest) -> (nf_beta c, rest)) + | EliminationMutualFix (min,refgoal,refinfos) + when stack_args_size largs >= min -> + let rec descend ref args = + let c = reference_value sigma env ref in + if ref = refgoal then + (c,args) + else + let c', lrest = whd_betalet_state (c,args) in + descend (destEvalRef c') lrest in + let (_, midargs as s) = descend ref largs in + let d, lrest = whd_betadelta_state env sigma s in + let f = make_elim_fun refinfos midargs in + let co = construct_const env sigma in + (match reduce_fix_use_function f co (destFix d) lrest with + | NotReducible -> raise Redelimination + | Reduced (c,rest) -> (nf_beta c, rest)) + | _ -> raise Redelimination + +and construct_const env sigma = + let rec hnfstack (x, stack as s) = + match kind_of_term x with + | Cast (c,_) -> hnfstack (c, stack) + | App (f,cl) -> hnfstack (f, append_stack cl stack) + | Lambda (id,t,c) -> + (match decomp_stack stack with + | None -> assert false + | Some (c',rest) -> + stacklam hnfstack [c'] c rest) + | LetIn (n,b,t,c) -> stacklam hnfstack [b] c stack + | Case (ci,p,c,lf) -> + hnfstack + (special_red_case sigma env + (construct_const env sigma) (ci,p,c,lf), stack) + | Construct _ -> s + | CoFix _ -> s + | Fix fix -> + (match reduce_fix hnfstack fix stack with + | Reduced s' -> hnfstack s' + | NotReducible -> raise Redelimination) + | _ when isEvalRef env x -> + let ref = destEvalRef x in + (try + hnfstack (red_elim_const env sigma ref stack) + with Redelimination -> + (match reference_opt_value sigma env ref with + | Some cval -> + (match kind_of_term cval with + | CoFix _ -> s + | _ -> hnfstack (cval, stack)) + | None -> + raise Redelimination)) + | _ -> raise Redelimination + in + hnfstack + +(************************************************************************) +(* Special Purpose Reduction Strategies *) + +(* Red reduction tactic: reduction to a product *) + +let internal_red_product env sigma c = + let simpfun = clos_norm_flags betaiotazeta env sigma in + let rec redrec env x = + match kind_of_term x with + | App (f,l) -> + (match kind_of_term f with + | Fix fix -> + let stack = append_stack l empty_stack in + (match fix_recarg fix stack with + | None -> raise Redelimination + | Some (recargnum,recarg) -> + let recarg' = redrec env recarg in + let stack' = stack_assign stack recargnum recarg' in + simpfun (app_stack (f,stack'))) + | _ -> simpfun (appvect (redrec env f, l))) + | Cast (c,_) -> redrec env c + | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) + | LetIn (x,a,b,t) -> redrec env (subst1 a t) + | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) + | _ when isEvalRef env x -> + (* TO DO: re-fold fixpoints after expansion *) + (* to get true one-step reductions *) + let ref = destEvalRef x in + (match reference_opt_value sigma env ref with + | None -> raise Redelimination + | Some c -> c) + | _ -> raise Redelimination + in redrec env c + +let red_product env sigma c = + try internal_red_product env sigma c + with Redelimination -> error "Not reducible" + +(* Hnf reduction tactic: *) + +let hnf_constr env sigma c = + let rec redrec (x, largs as s) = + match kind_of_term x with + | Lambda (n,t,c) -> + (match decomp_stack largs with + | None -> app_stack s + | Some (a,rest) -> + stacklam redrec [a] c rest) + | LetIn (n,b,t,c) -> stacklam redrec [b] c largs + | App (f,cl) -> redrec (f, append_stack cl largs) + | Cast (c,_) -> redrec (c, largs) + | Case (ci,p,c,lf) -> + (try + redrec + (special_red_case sigma env (whd_betadeltaiota_state env sigma) + (ci, p, c, lf), largs) + with Redelimination -> + app_stack s) + | Fix fix -> + (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with + | Reduced s' -> redrec s' + | NotReducible -> app_stack s) + | _ when isEvalRef env x -> + let ref = destEvalRef x in + (try + let (c',lrest) = red_elim_const env sigma ref largs in + redrec (c', lrest) + with Redelimination -> + match reference_opt_value sigma env ref with + | Some c -> + (match kind_of_term (snd (decompose_lam c)) with + | CoFix _ | Fix _ -> app_stack (x,largs) + | _ -> redrec (c, largs)) + | None -> app_stack s) + | _ -> app_stack s + in + redrec (c, empty_stack) + +(* Simpl reduction tactic: same as simplify, but also reduces + elimination constants *) + +let whd_nf env sigma c = + let rec nf_app (c, stack as s) = + match kind_of_term c with + | Lambda (name,c1,c2) -> + (match decomp_stack stack with + | None -> (c,empty_stack) + | Some (a1,rest) -> + stacklam nf_app [a1] c2 rest) + | LetIn (n,b,t,c) -> stacklam nf_app [b] c stack + | App (f,cl) -> nf_app (f, append_stack cl stack) + | Cast (c,_) -> nf_app (c, stack) + | Case (ci,p,d,lf) -> + (try + nf_app (special_red_case sigma env nf_app (ci,p,d,lf), stack) + with Redelimination -> + s) + | Fix fix -> + (match reduce_fix nf_app fix stack with + | Reduced s' -> nf_app s' + | NotReducible -> s) + | _ when isEvalRef env c -> + (try + nf_app (red_elim_const env sigma (destEvalRef c) stack) + with Redelimination -> + s) + | _ -> s + in + app_stack (nf_app (c, empty_stack)) + +let nf env sigma c = strong whd_nf env sigma c + +let is_reference c = + try let r = reference_of_constr c in true with _ -> false + +let is_head c t = + match kind_of_term t with + | App (f,_) -> f = c + | _ -> false + +let contextually byhead (locs,c) f env sigma t = + let maxocc = List.fold_right max locs 0 in + let pos = ref 1 in + let check = ref true in + let except = List.exists (fun n -> n<0) locs in + if except & (List.exists (fun n -> n>=0) locs) + then error "mixing of positive and negative occurences" + else + let rec traverse (env,c as envc) t = + if locs <> [] & (not except) & (!pos > maxocc) then t + else + if (not byhead & eq_constr c t) or (byhead & is_head c t) then + let ok = + if except then not (List.mem (- !pos) locs) + else (locs = [] or List.mem !pos locs) in + incr pos; + if ok then + f env sigma t + else if byhead then + (* find other occurrences of c in t; TODO: ensure left-to-right *) + let (f,l) = destApplication t in + mkApp (f, array_map_left (traverse envc) l) + else + t + else + map_constr_with_binders_left_to_right + (fun d (env,c) -> (push_rel d env,lift 1 c)) + traverse envc t + in + let t' = traverse (env,c) t in + if locs <> [] & List.exists (fun o -> o >= !pos or o <= - !pos) locs then + errorlabstrm "contextually" (str "Too few occurences"); + t' + +(* linear bindings (following pretty-printer) of the value of name in c. + * n is the number of the next occurence of name. + * ol is the occurence list to find. *) +let rec substlin env name n ol c = + match kind_of_term c with + | Const kn when EvalConstRef kn = name -> + if List.hd ol = n then + try + (n+1, List.tl ol, constant_value env kn) + with + NotEvaluableConst _ -> + errorlabstrm "substlin" + (pr_kn kn ++ str " is not a defined constant") + else + ((n+1), ol, c) + + | Var id when EvalVarRef id = name -> + if List.hd ol = n then + match lookup_named id env with + | (_,Some c,_) -> (n+1, List.tl ol, c) + | _ -> + errorlabstrm "substlin" + (pr_id id ++ str " is not a defined constant") + else + ((n+1), ol, c) + + (* INEFFICIENT: OPTIMIZE *) + | App (c1,cl) -> + Array.fold_left + (fun (n1,ol1,c1') c2 -> + (match ol1 with + | [] -> (n1,[],applist(c1',[c2])) + | _ -> + let (n2,ol2,c2') = substlin env name n1 ol1 c2 in + (n2,ol2,applist(c1',[c2'])))) + (substlin env name n ol c1) cl + + | Lambda (na,c1,c2) -> + let (n1,ol1,c1') = substlin env name n ol c1 in + (match ol1 with + | [] -> (n1,[],mkLambda (na,c1',c2)) + | _ -> + let (n2,ol2,c2') = substlin env name n1 ol1 c2 in + (n2,ol2,mkLambda (na,c1',c2'))) + + | LetIn (na,c1,t,c2) -> + let (n1,ol1,c1') = substlin env name n ol c1 in + (match ol1 with + | [] -> (n1,[],mkLetIn (na,c1',t,c2)) + | _ -> + let (n2,ol2,c2') = substlin env name n1 ol1 c2 in + (n2,ol2,mkLetIn (na,c1',t,c2'))) + + | Prod (na,c1,c2) -> + let (n1,ol1,c1') = substlin env name n ol c1 in + (match ol1 with + | [] -> (n1,[],mkProd (na,c1',c2)) + | _ -> + let (n2,ol2,c2') = substlin env name n1 ol1 c2 in + (n2,ol2,mkProd (na,c1',c2'))) + + | Case (ci,p,d,llf) -> + let rec substlist nn oll = function + | [] -> (nn,oll,[]) + | f::lfe -> + let (nn1,oll1,f') = substlin env name nn oll f in + (match oll1 with + | [] -> (nn1,[],f'::lfe) + | _ -> + let (nn2,oll2,lfe') = substlist nn1 oll1 lfe in + (nn2,oll2,f'::lfe')) + in + let (n1,ol1,p') = substlin env name n ol p in (* ATTENTION ERREUR *) + (match ol1 with (* si P pas affiche *) + | [] -> (n1,[],mkCase (ci, p', d, llf)) + | _ -> + let (n2,ol2,d') = substlin env name n1 ol1 d in + (match ol2 with + | [] -> (n2,[],mkCase (ci, p', d', llf)) + | _ -> + let (n3,ol3,lf') = substlist n2 ol2 (Array.to_list llf) + in (n3,ol3,mkCase (ci, p', d', Array.of_list lf')))) + + | Cast (c1,c2) -> + let (n1,ol1,c1') = substlin env name n ol c1 in + (match ol1 with + | [] -> (n1,[],mkCast (c1',c2)) + | _ -> + let (n2,ol2,c2') = substlin env name n1 ol1 c2 in + (n2,ol2,mkCast (c1',c2'))) + + | Fix _ -> + (warning "do not consider occurrences inside fixpoints"; (n,ol,c)) + + | CoFix _ -> + (warning "do not consider occurrences inside cofixpoints"; (n,ol,c)) + + | (Rel _|Meta _|Var _|Sort _ + |Evar _|Const _|Ind _|Construct _) -> (n,ol,c) + +let string_of_evaluable_ref env = function + | EvalVarRef id -> string_of_id id + | EvalConstRef kn -> + string_of_qualid + (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) + +let unfold env sigma name = + if is_evaluable env name then + clos_norm_flags (unfold_red name) env sigma + else + error (string_of_evaluable_ref env name^" is opaque") + +(* [unfoldoccs : (readable_constraints -> (int list * section_path) -> constr -> constr)] + * Unfolds the constant name in a term c following a list of occurrences occl. + * at the occurrences of occ_list. If occ_list is empty, unfold all occurences. + * Performs a betaiota reduction after unfolding. *) +let unfoldoccs env sigma (occl,name) c = + match occl with + | [] -> unfold env sigma name c + | l -> + match substlin env name 1 (Sort.list (<) l) c with + | (_,[],uc) -> nf_betaiota uc + | (1,_,_) -> + error ((string_of_evaluable_ref env name)^" does not occur") + | _ -> error ("bad occurrence numbers of " + ^(string_of_evaluable_ref env name)) + +(* Unfold reduction tactic: *) +let unfoldn loccname env sigma c = + List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname + +(* Re-folding constants tactics: refold com in term c *) +let fold_one_com com env sigma c = + let rcom = + try red_product env sigma com + with Redelimination -> error "Not reducible" in + subst1 com (subst_term rcom c) + +let fold_commands cl env sigma c = + List.fold_right (fun com -> fold_one_com com env sigma) (List.rev cl) c + + +(* call by value reduction functions *) +let cbv_norm_flags flags env sigma t = + cbv_norm (create_cbv_infos flags env) (nf_evar sigma t) + +let cbv_beta = cbv_norm_flags beta empty_env Evd.empty +let cbv_betaiota = cbv_norm_flags betaiota empty_env Evd.empty +let cbv_betadeltaiota env sigma = cbv_norm_flags betadeltaiota env sigma + +let compute = cbv_betadeltaiota + +(* Pattern *) + +(* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only + * the specified occurrences. *) + +let abstract_scheme env sigma (locc,a) t = + let ta = Retyping.get_type_of env sigma a in + let na = named_hd env ta Anonymous in + if occur_meta ta then error "cannot find a type for the generalisation"; + if occur_meta a then + mkLambda (na,ta,t) + else + mkLambda (na, ta,subst_term_occ locc a t) + + +let pattern_occs loccs_trm env sigma c = + let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in + applist(abstr_trm, List.map snd loccs_trm) + +(* Generic reduction: reduction functions used in reduction tactics *) + +type red_expr = (constr, evaluable_global_reference) red_expr_gen + +open RedFlags + +let make_flag_constant = function + | EvalVarRef id -> fVAR id + | EvalConstRef sp -> fCONST sp + +let make_flag f = + let red = no_red in + let red = if f.rBeta then red_add red fBETA else red in + let red = if f.rIota then red_add red fIOTA else red in + let red = if f.rZeta then red_add red fZETA else red in + let red = + if f.rDelta then (* All but rConst *) + let red = red_add red fDELTA in + let red = red_add_transparent red (Conv_oracle.freeze ()) in + List.fold_right + (fun v red -> red_sub red (make_flag_constant v)) + f.rConst red + else (* Only rConst *) + let red = red_add_transparent (red_add red fDELTA) all_opaque in + List.fold_right + (fun v red -> red_add red (make_flag_constant v)) + f.rConst red + in red + +let red_expr_tab = ref Stringmap.empty + +let declare_red_expr s f = + try + let _ = Stringmap.find s !red_expr_tab in + error ("There is already a reduction expression of name "^s) + with Not_found -> + red_expr_tab := Stringmap.add s f !red_expr_tab + +let reduction_of_redexp = function + | Red internal -> if internal then internal_red_product else red_product + | Hnf -> hnf_constr + | Simpl (Some (_,c as lp)) -> contextually (is_reference c) lp nf + | Simpl None -> nf + | Cbv f -> cbv_norm_flags (make_flag f) + | Lazy f -> clos_norm_flags (make_flag f) + | Unfold ubinds -> unfoldn ubinds + | Fold cl -> fold_commands cl + | Pattern lp -> pattern_occs lp + | ExtraRedExpr (s,c) -> + (try Stringmap.find s !red_expr_tab + with Not_found -> error("unknown user-defined reduction \""^s^"\"")) +(* Used in several tactics. *) + +exception NotStepReducible + +let one_step_reduce env sigma c = + let rec redrec (x, largs as s) = + match kind_of_term x with + | Lambda (n,t,c) -> + (match decomp_stack largs with + | None -> raise NotStepReducible + | Some (a,rest) -> (subst1 a c, rest)) + | App (f,cl) -> redrec (f, append_stack cl largs) + | LetIn (_,f,_,cl) -> (subst1 f cl,largs) + | Case (ci,p,c,lf) -> + (try + (special_red_case sigma env (whd_betadeltaiota_state env sigma) + (ci,p,c,lf), largs) + with Redelimination -> raise NotStepReducible) + | Fix fix -> + (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with + | Reduced s' -> s' + | NotReducible -> raise NotStepReducible) + | Cast (c,_) -> redrec (c,largs) + | _ when isEvalRef env x -> + let ref = + try destEvalRef x + with Redelimination -> raise NotStepReducible in + (try + red_elim_const env sigma ref largs + with Redelimination -> + match reference_opt_value sigma env ref with + | Some d -> d, largs + | None -> raise NotStepReducible) + + | _ -> raise NotStepReducible + in + app_stack (redrec (c, empty_stack)) + +(* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name + return name, B and t' *) + +let reduce_to_ind_gen allow_product env sigma t = + let rec elimrec env t l = + let c, _ = Reductionops.whd_stack t in + match kind_of_term c with + | Ind (mind,args) -> ((mind,args),it_mkProd_or_LetIn t l) + | Prod (n,ty,t') -> + if allow_product then + elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) + else + errorlabstrm "tactics__reduce_to_mind" + (str"Not an inductive definition") + | _ -> + (try + let t' = nf_betaiota (one_step_reduce env sigma t) in + elimrec env t' l + with NotStepReducible -> + errorlabstrm "tactics__reduce_to_mind" + (str"Not an inductive product")) + in + elimrec env t [] + +let reduce_to_quantified_ind x = reduce_to_ind_gen true x +let reduce_to_atomic_ind x = reduce_to_ind_gen false x + +let reduce_to_ref_gen allow_product env sigma ref t = + let rec elimrec env t l = + let c, _ = Reductionops.whd_stack t in + match kind_of_term c with + | Prod (n,ty,t') -> + if allow_product then + elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) + else + errorlabstrm "Tactics.reduce_to_ref_gen" + (str"Not an induction object of atomic type") + | _ -> + try + if reference_of_constr c = ref + then it_mkProd_or_LetIn t l + else raise Not_found + with Not_found -> + try + let t' = nf_betaiota (one_step_reduce env sigma t) in + elimrec env t' l + with NotStepReducible -> raise Not_found + in + elimrec env t [] + +let reduce_to_quantified_ref = reduce_to_ref_gen true +let reduce_to_atomic_ref = reduce_to_ref_gen false diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli new file mode 100644 index 00000000..162275d5 --- /dev/null +++ b/pretyping/tacred.mli @@ -0,0 +1,85 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evaluable_global_reference -> bool + +exception Redelimination + +(* Red (raise Redelimination if nothing reducible) *) +val red_product : reduction_function + +(* Hnf *) +val hnf_constr : reduction_function + +(* Simpl *) +val nf : reduction_function + +(* Unfold *) +val unfoldn : + (int list * evaluable_global_reference) list -> reduction_function + +(* Fold *) +val fold_commands : constr list -> reduction_function + +(* Pattern *) +val pattern_occs : (int list * constr) list -> reduction_function +(* Rem: Lazy strategies are defined in Reduction *) + +(* Call by value strategy (uses Closures) *) +val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function + val cbv_beta : local_reduction_function + val cbv_betaiota : local_reduction_function + val cbv_betadeltaiota : reduction_function + val compute : reduction_function (* = [cbv_betadeltaiota] *) + +(* [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] + with [I] an inductive definition; + returns [I] and [t'] or fails with a user error *) +val reduce_to_atomic_ind : env -> evar_map -> types -> inductive * types + +(* [reduce_to_quantified_ind env sigma t] puts [t] in the form + [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; + returns [I] and [t'] or fails with a user error *) +val reduce_to_quantified_ind : env -> evar_map -> types -> inductive * types + +(* [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form + [t'=(x1:A1)..(xn:An)(ref args)] and raise Not_found if not possible *) +val reduce_to_quantified_ref : + env -> evar_map -> Libnames.global_reference -> types -> types + +val reduce_to_atomic_ref : + env -> evar_map -> Libnames.global_reference -> types -> types + +type red_expr = (constr, evaluable_global_reference) red_expr_gen + +val contextually : bool -> constr occurrences -> reduction_function + -> reduction_function +val reduction_of_redexp : red_expr -> reduction_function + +val declare_red_expr : string -> reduction_function -> unit + +(* Opaque and Transparent commands. *) +val set_opaque_const : constant -> unit +val set_transparent_const : constant -> unit + +val set_opaque_var : identifier -> unit +val set_transparent_var : identifier -> unit diff --git a/pretyping/termops.ml b/pretyping/termops.ml new file mode 100644 index 00000000..8f12ca62 --- /dev/null +++ b/pretyping/termops.ml @@ -0,0 +1,938 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (str "Set") + | Prop Null -> (str "Prop") + | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") + +let print_sort_family = function + | InSet -> (str "Set") + | InProp -> (str "Prop") + | InType -> (str "Type") + +let pr_name = function + | Name id -> pr_id id + | Anonymous -> str "_" + +let pr_sp sp = str(string_of_kn sp) + +let rec print_constr c = match kind_of_term c with + | Rel n -> str "#"++int n + | Meta n -> str "Meta(" ++ int n ++ str ")" + | Var id -> pr_id id + | Sort s -> print_sort s + | Cast (c,t) -> hov 1 + (str"(" ++ print_constr c ++ cut() ++ + str":" ++ print_constr t ++ str")") + | Prod (Name(id),t,c) -> hov 1 + (str"forall " ++ pr_id id ++ str":" ++ print_constr t ++ str"," ++ + spc() ++ print_constr c) + | Prod (Anonymous,t,c) -> hov 0 + (str"(" ++ print_constr t ++ str " ->" ++ spc() ++ + print_constr c ++ str")") + | Lambda (na,t,c) -> hov 1 + (str"fun " ++ pr_name na ++ str":" ++ + print_constr t ++ str" =>" ++ spc() ++ print_constr c) + | LetIn (na,b,t,c) -> hov 0 + (str"let " ++ pr_name na ++ str":=" ++ print_constr b ++ + str":" ++ brk(1,2) ++ print_constr t ++ cut() ++ + print_constr c) + | App (c,l) -> hov 1 + (str"(" ++ print_constr c ++ spc() ++ + prlist_with_sep spc print_constr (Array.to_list l) ++ str")") + | Evar (e,l) -> hov 1 + (str"Evar#" ++ int e ++ str"{" ++ + prlist_with_sep spc print_constr (Array.to_list l) ++str"}") + | Const c -> str"Cst(" ++ pr_sp c ++ str")" + | Ind (sp,i) -> str"Ind(" ++ pr_sp sp ++ str"," ++ int i ++ str")" + | Construct ((sp,i),j) -> + str"Constr(" ++ pr_sp sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" + | Case (ci,p,c,bl) -> v 0 + (hv 0 (str"<"++print_constr p++str">"++ cut() ++ str"Case " ++ + print_constr c ++ str"of") ++ cut() ++ + prlist_with_sep (fun _ -> brk(1,2)) print_constr (Array.to_list bl) ++ + cut() ++ str"end") + | Fix ((t,i),(lna,tl,bl)) -> + let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in + hov 1 + (str"fix " ++ int i ++ spc() ++ str"{" ++ + v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> + pr_name na ++ str"/" ++ int i ++ str":" ++ print_constr ty ++ + cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++ + str"}") + | CoFix(i,(lna,tl,bl)) -> + let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in + hov 1 + (str"cofix " ++ int i ++ spc() ++ str"{" ++ + v 0 (prlist_with_sep spc (fun (na,ty,bd) -> + pr_name na ++ str":" ++ print_constr ty ++ + cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++ + str"}") + +(*let current_module = ref empty_dirpath + +let set_module m = current_module := m*) + +let new_univ = + let univ_gen = ref 0 in + (fun sp -> + incr univ_gen; + Univ.make_univ (Lib.library_dp(),!univ_gen)) + +let new_sort_in_family = function + | InProp -> mk_Prop + | InSet -> mk_Set + | InType -> Type (new_univ ()) + + + +(* prod_it b [xn:Tn;..;x1:T1] = (x1:T1)..(xn:Tn)b *) +let prod_it ~init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init + +(* lam_it b [xn:Tn;..;x1:T1] = [x1:T1]..[xn:Tn]b *) +let lam_it ~init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init + +(* [Rel (n+m);...;Rel(n+1)] *) +let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) + +let rel_list n m = + let rec reln l p = + if p>m then l else reln (mkRel(n+p)::l) (p+1) + in + reln [] 1 + +(* Same as [rel_list] but takes a context as argument and skips let-ins *) +let extended_rel_list n hyps = + let rec reln l p = function + | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps + | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 hyps + +let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) + + + +let push_rel_assum (x,t) env = push_rel (x,None,t) env + +let push_rels_assum assums = + push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums) + +let push_named_rec_types (lna,typarray,_) env = + let ctxt = + array_map2_i + (fun i na t -> + match na with + | Name id -> (id, None, type_app (lift i) t) + | Anonymous -> anomaly "Fix declarations must be named") + lna typarray in + Array.fold_left + (fun e assum -> push_named assum e) env ctxt + +let rec lookup_rel_id id sign = + let rec lookrec = function + | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l) + | (n, (Name id',_,t)::l) -> if id' = id then (n,t) else lookrec (n+1,l) + | (_, []) -> raise Not_found + in + lookrec (1,sign) + +(* Constructs either [(x:t)c] or [[x=b:t]c] *) +let mkProd_or_LetIn (na,body,t) c = + match body with + | None -> mkProd (na, t, c) + | Some b -> mkLetIn (na, b, t, c) + +(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) +let mkProd_wo_LetIn (na,body,t) c = + match body with + | None -> mkProd (na, t, c) + | Some b -> subst1 b c + +let it_mkProd_wo_LetIn ~init = + List.fold_left (fun c d -> mkProd_wo_LetIn d c) init + +let it_mkProd_or_LetIn ~init = + List.fold_left (fun c d -> mkProd_or_LetIn d c) init + +let it_mkLambda_or_LetIn ~init = + List.fold_left (fun c d -> mkLambda_or_LetIn d c) init + +let it_named_context_quantifier f ~init = + List.fold_left (fun c d -> f d c) init + +let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn +let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn + +(* *) + +(* strips head casts and flattens head applications *) +let rec strip_head_cast c = match kind_of_term c with + | App (f,cl) -> + let rec collapse_rec f cl2 = match kind_of_term f with + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_) -> collapse_rec c cl2 + | _ -> if cl2 = [||] then f else mkApp (f,cl2) + in + collapse_rec f cl + | Cast (c,t) -> strip_head_cast c + | _ -> c + +(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate + subterms of [c]; it carries an extra data [l] (typically a name + list) which is processed by [g na] (which typically cons [na] to + [l]) at each binder traversal (with name [na]); it is not recursive + and the order with which subterms are processed is not specified *) + +let map_constr_with_named_binders g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f l c, f l t) + | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c) + | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) + | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) + | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Evar (e,al) -> mkEvar (e, Array.map (f l) al) + | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) + | Fix (ln,(lna,tl,bl)) -> + let l' = Array.fold_left (fun l na -> g na l) l lna in + mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + | CoFix(ln,(lna,tl,bl)) -> + let l' = Array.fold_left (fun l na -> g na l) l lna in + mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + +(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the + immediate subterms of [c]; it carries an extra data [n] (typically + a lift index) which is processed by [g] (which typically add 1 to + [n]) at each binder traversal; the subterms are processed from left + to right according to the usual representation of the constructions + (this may matter if [f] does a side-effect); it is not recursive; + in fact, the usual representation of the constructions is at the + time being almost those of the ML representation (except for + (co-)fixpoint) *) + +let fold_rec_types g (lna,typarray,_) e = + let ctxt = + array_map2_i + (fun i na t -> (na, None, type_app (lift i) t)) lna typarray in + Array.fold_left + (fun e assum -> g assum e) e ctxt + + +let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> let c' = f l c in mkCast (c', f l t) + | Prod (na,t,c) -> + let t' = f l t in + mkProd (na, t', f (g (na,None,t) l) c) + | Lambda (na,t,c) -> + let t' = f l t in + mkLambda (na, t', f (g (na,None,t) l) c) + | LetIn (na,b,t,c) -> + let b' = f l b in + let t' = f l t in + let c' = f (g (na,Some b,t) l) c in + mkLetIn (na, b', t', c') + | App (c,[||]) -> assert false + | App (c,al) -> + (*Special treatment to be able to recognize partially applied subterms*) + let a = al.(Array.length al - 1) in + let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in + mkApp (hd, [| f l a |]) + | Evar (e,al) -> mkEvar (e, array_map_left (f l) al) + | Case (ci,p,c,bl) -> + let p' = f l p in let c' = f l c in + mkCase (ci, p', c', array_map_left (f l) bl) + | Fix (ln,(lna,tl,bl as fx)) -> + let l' = fold_rec_types g fx l in + let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in + mkFix (ln,(lna,tl',bl')) + | CoFix(ln,(lna,tl,bl as fx)) -> + let l' = fold_rec_types g fx l in + let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in + mkCoFix (ln,(lna,tl',bl')) + +(* strong *) +let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> cstr + | Cast (c,t) -> + let c' = f l c in + let t' = f l t in + if c==c' && t==t' then cstr else mkCast (c', t') + | Prod (na,t,c) -> + let t' = f l t in + let c' = f (g (na,None,t) l) c in + if t==t' && c==c' then cstr else mkProd (na, t', c') + | Lambda (na,t,c) -> + let t' = f l t in + let c' = f (g (na,None,t) l) c in + if t==t' && c==c' then cstr else mkLambda (na, t', c') + | LetIn (na,b,t,c) -> + let b' = f l b in + let t' = f l t in + let c' = f (g (na,Some b,t) l) c in + if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c') + | App (c,al) -> + let c' = f l c in + let al' = Array.map (f l) al in + if c==c' && array_for_all2 (==) al al' then cstr else mkApp (c', al') + | Evar (e,al) -> + let al' = Array.map (f l) al in + if array_for_all2 (==) al al' then cstr else mkEvar (e, al') + | Case (ci,p,c,bl) -> + let p' = f l p in + let c' = f l c in + let bl' = Array.map (f l) bl in + if p==p' && c==c' && array_for_all2 (==) bl bl' then cstr else + mkCase (ci, p', c', bl') + | Fix (ln,(lna,tl,bl)) -> + let tl' = Array.map (f l) tl in + let l' = + array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + let bl' = Array.map (f l') bl in + if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl' + then cstr + else mkFix (ln,(lna,tl',bl')) + | CoFix(ln,(lna,tl,bl)) -> + let tl' = Array.map (f l) tl in + let l' = + array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + let bl' = Array.map (f l') bl in + if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl' + then cstr + else mkCoFix (ln,(lna,tl',bl')) + +(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate + subterms of [c] starting from [acc] and proceeding from left to + right according to the usual representation of the constructions as + [fold_constr] but it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive *) + +let fold_constr_with_binders g f n acc c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> acc + | Cast (c,t) -> f n (f n acc c) t + | Prod (_,t,c) -> f (g n) (f n acc t) c + | Lambda (_,t,c) -> f (g n) (f n acc t) c + | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = iterate g (Array.length tl) n in + let fd = array_map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = iterate g (Array.length tl) n in + let fd = array_map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd + +(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate + subterms of [c]; it carries an extra data [acc] which is processed by [g] at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) + +let iter_constr_with_full_binders g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> () + | Cast (c,t) -> f l c; f l t + | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c + | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c + | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c + | App (c,args) -> f l c; Array.iter (f l) args + | Evar (_,args) -> Array.iter (f l) args + | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl + | Fix (_,(lna,tl,bl)) -> + let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + Array.iter (f l) tl; + Array.iter (f l') bl + | CoFix (_,(lna,tl,bl)) -> + let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + Array.iter (f l) tl; + Array.iter (f l') bl + +(***************************) +(* occurs check functions *) +(***************************) + +exception Occur + +let occur_meta c = + let rec occrec c = match kind_of_term c with + | Meta _ -> raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + +let occur_existential c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + +let occur_const s c = + let rec occur_rec c = match kind_of_term c with + | Const sp when sp=s -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +let occur_evar n c = + let rec occur_rec c = match kind_of_term c with + | Evar (sp,_) when sp=n -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +let occur_in_global env id constr = + let vars = vars_of_global env constr in + if List.mem id vars then raise Occur + +let occur_var env s c = + let rec occur_rec c = + occur_in_global env s c; + iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +let occur_var_in_decl env hyp (_,c,typ) = + match c with + | None -> occur_var env hyp typ + | Some body -> + occur_var env hyp typ || + occur_var env hyp body + +(* Tests that t is a subterm of c *) +let occur_term t c = + let eq_constr_fail c = if eq_constr t c then raise Occur + in let rec occur_rec c = eq_constr_fail c; iter_constr occur_rec c + in try occur_rec c; false with Occur -> true + +(* returns the list of free debruijn indices in a term *) + +let free_rels m = + let rec frec depth acc c = match kind_of_term c with + | Rel n -> if n >= depth then Intset.add (n-depth+1) acc else acc + | _ -> fold_constr_with_binders succ frec depth acc c + in + frec 1 Intset.empty m + + +(* (dependent M N) is true iff M is eq_term with a subterm of N + M is appropriately lifted through abstractions of N *) + +let dependent m t = + let rec deprec m t = + if eq_constr m t then + raise Occur + else + match kind_of_term m, kind_of_term t with + | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> + deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); + Array.iter (deprec m) + (Array.sub lt + (Array.length lm) ((Array.length lt) - (Array.length lm))) + | _ -> iter_constr_with_binders (lift 1) deprec m t + in + try deprec m t; false with Occur -> true + +let pop t = lift (-1) t + +(***************************) +(* bindings functions *) +(***************************) + +type metamap = (metavariable * constr) list + +let rec subst_meta bl c = + match kind_of_term c with + | Meta i -> (try List.assoc i bl with Not_found -> c) + | _ -> map_constr (subst_meta bl) c + +(* First utilities for avoiding telescope computation for subst_term *) + +let prefix_application eq_fun (k,c) (t : constr) = + let c' = collapse_appl c and t' = collapse_appl t in + match kind_of_term c', kind_of_term t' with + | App (f1,cl1), App (f2,cl2) -> + let l1 = Array.length cl1 + and l2 = Array.length cl2 in + if l1 <= l2 + && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then + Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) + else + None + | _ -> None + +let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = + let c' = collapse_appl c and t' = collapse_appl t in + match kind_of_term c', kind_of_term t' with + | App (f1,cl1), App (f2,cl2) -> + let l1 = Array.length cl1 + and l2 = Array.length cl2 in + if l1 <= l2 + && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then + Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1))) + else + None + | _ -> None + +(* Recognizing occurrences of a given (closed) subterm in a term for Pattern : + [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed) + term [c] in a term [t] *) +(*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*) + +let subst_term_gen eq_fun c t = + let rec substrec (k,c as kc) t = + match prefix_application eq_fun kc t with + | Some x -> x + | None -> + if eq_fun c t then mkRel k + else + map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t + in + substrec (1,c) t + +(* Recognizing occurrences of a given (closed) subterm in a term : + [replace_term c1 c2 t] substitutes [c2] for all occurrences of (closed) + term [c1] in a term [t] *) +(*i Meme remarque : a priori [c] n'est pas forcement clos i*) + +let replace_term_gen eq_fun c by_c in_t = + let rec substrec (k,c as kc) t = + match my_prefix_application eq_fun kc by_c t with + | Some x -> x + | None -> + (if eq_fun c t then (lift k by_c) else + map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) + substrec kc t) + in + substrec (0,c) in_t + +let subst_term = subst_term_gen eq_constr + +let replace_term = replace_term_gen eq_constr + +(* Substitute only a list of locations locs, the empty list is + interpreted as substitute all, if 0 is in the list then no + bindings is done. The list may contain only negative occurrences + that will not be substituted. *) + +let subst_term_occ_gen locs occ c t = + let maxocc = List.fold_right max locs 0 in + let pos = ref occ in + let check = ref true in + let except = List.exists (fun n -> n<0) locs in + if except & (List.exists (fun n -> n>=0) locs) + then error "mixing of positive and negative occurences" + else + let rec substrec (k,c as kc) t = + if (not except) & (!pos > maxocc) then t + else + if eq_constr c t then + let r = + if except then + if List.mem (- !pos) locs then t else (mkRel k) + else + if List.mem !pos locs then (mkRel k) else t + in incr pos; r + else + map_constr_with_binders_left_to_right + (fun d (k,c) -> (k+1,lift 1 c)) + substrec kc t + in + let t' = substrec (1,c) t in + (!pos, t') + +let subst_term_occ locs c t = + if locs = [] then subst_term c t + else if List.mem 0 locs then + t + else + let (nbocc,t') = subst_term_occ_gen locs 1 c t in + if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then + errorlabstrm "subst_term_occ" (str "Too few occurences"); + t' + +let subst_term_occ_decl locs c (id,bodyopt,typ as d) = + match bodyopt with + | None -> (id,None,subst_term_occ locs c typ) + | Some body -> + if locs = [] then + (id,Some (subst_term c body),type_app (subst_term c) typ) + else if List.mem 0 locs then + d + else + let (nbocc,body') = subst_term_occ_gen locs 1 c body in + let (nbocc',t') = subst_term_occ_gen locs nbocc c typ in + if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then + errorlabstrm "subst_term_occ_decl" (str "Too few occurences"); + (id,Some body',t') + + +(* First character of a constr *) + +let first_char id = + let id = string_of_id id in + assert (id <> ""); + String.make 1 id.[0] + +let lowercase_first_char id = String.lowercase (first_char id) + +let vars_of_env env = + let s = + Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s) + (named_context env) ~init:Idset.empty in + Sign.fold_rel_context + (fun (na,_,_) s -> match na with Name id -> Idset.add id s | _ -> s) + (rel_context env) ~init:s + +let add_vname vars = function + Name id -> Idset.add id vars + | _ -> vars + +let id_of_global = Nametab.id_of_global + +let sort_hdchar = function + | Prop(_) -> "P" + | Type(_) -> "T" + +let hdchar env c = + let rec hdrec k c = + match kind_of_term c with + | Prod (_,_,c) -> hdrec (k+1) c + | Lambda (_,_,c) -> hdrec (k+1) c + | LetIn (_,_,_,c) -> hdrec (k+1) c + | Cast (c,_) -> hdrec k c + | App (f,l) -> hdrec k f + | Const kn -> + let c = lowercase_first_char (id_of_label (label kn)) in + if c = "?" then "y" else c + | Ind ((kn,i) as x) -> + if i=0 then + lowercase_first_char (id_of_label (label kn)) + else + lowercase_first_char (id_of_global (IndRef x)) + | Construct ((sp,i) as x) -> + lowercase_first_char (id_of_global (ConstructRef x)) + | Var id -> lowercase_first_char id + | Sort s -> sort_hdchar s + | Rel n -> + (if n<=k then "p" (* the initial term is flexible product/function *) + else + try match Environ.lookup_rel (n-k) env with + | (Name id,_,_) -> lowercase_first_char id + | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) + with Not_found -> "y") + | Fix ((_,i),(lna,_,_)) -> + let id = match lna.(i) with Name id -> id | _ -> assert false in + lowercase_first_char id + | CoFix (i,(lna,_,_)) -> + let id = match lna.(i) with Name id -> id | _ -> assert false in + lowercase_first_char id + | Meta _|Evar _|Case (_, _, _, _) -> "y" + in + hdrec 0 c + +let id_of_name_using_hdchar env a = function + | Anonymous -> id_of_string (hdchar env a) + | Name id -> id + +let named_hd env a = function + | Anonymous -> Name (id_of_string (hdchar env a)) + | x -> x + +let named_hd_type env a = named_hd env (body_of_type a) + +let prod_name env (n,a,b) = mkProd (named_hd_type env a n, a, b) +let lambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b) + +let prod_create env (a,b) = mkProd (named_hd_type env a Anonymous, a, b) +let lambda_create env (a,b) = mkLambda (named_hd_type env a Anonymous, a, b) + +let name_assumption env (na,c,t) = + match c with + | None -> (named_hd_type env t na, None, t) + | Some body -> (named_hd env body na, c, t) + +let name_context env hyps = + snd + (List.fold_left + (fun (env,hyps) d -> + let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) + (env,[]) (List.rev hyps)) + +let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b +let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b + +let it_mkProd_or_LetIn_name env b hyps = + it_mkProd_or_LetIn b (name_context env hyps) +let it_mkLambda_or_LetIn_name env b hyps = + it_mkLambda_or_LetIn b (name_context env hyps) + +(*************************) +(* Names environments *) +(*************************) +type names_context = name list +let add_name n nl = n::nl +let lookup_name_of_rel p names = + try List.nth names (p-1) + with Invalid_argument _ | Failure _ -> raise Not_found +let rec lookup_rel_of_name id names = + let rec lookrec n = function + | Anonymous :: l -> lookrec (n+1) l + | (Name id') :: l -> if id' = id then n else lookrec (n+1) l + | [] -> raise Not_found + in + lookrec 1 names +let empty_names_context = [] + +let ids_of_rel_context sign = + Sign.fold_rel_context + (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) + sign ~init:[] +let ids_of_named_context sign = + Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[] + +let ids_of_context env = + (ids_of_rel_context (rel_context env)) + @ (ids_of_named_context (named_context env)) + +let names_of_rel_context env = + List.map (fun (na,_,_) -> na) (rel_context env) + +(**** Globality of identifiers *) + +(* TODO temporary hack!!! *) +let rec is_imported_modpath = function + | MPfile dp -> dp <> (Lib.library_dp ()) +(* | MPdot (mp,_) -> is_imported_modpath mp *) + | _ -> false + +let is_imported_ref = function + | VarRef _ -> false + | ConstRef kn + | IndRef (kn,_) + | ConstructRef ((kn,_),_) +(* | ModTypeRef ln *) -> + let (mp,_,_) = repr_kn kn in is_imported_modpath mp +(* | ModRef mp -> + is_imported_modpath mp +*) + +let is_global id = + try + let ref = locate (make_short_qualid id) in + not (is_imported_ref ref) + with Not_found -> + false + +let is_section_variable id = + try let _ = Sign.lookup_named id (Global.named_context()) in true + with Not_found -> false + +let next_global_ident_from allow_secvar id avoid = + let rec next_rec id = + let id = next_ident_away_from id avoid in + if (allow_secvar && is_section_variable id) || not (is_global id) then + id + else + next_rec (lift_ident id) + in + next_rec id + +let next_global_ident_away allow_secvar id avoid = + let id = next_ident_away id avoid in + if (allow_secvar && is_section_variable id) || not (is_global id) then + id + else + next_global_ident_from allow_secvar (lift_ident id) avoid + +(* Nouvelle version de renommage des variables (DEC 98) *) +(* This is the algorithm to display distinct bound variables + + - Règle 1 : un nom non anonyme, même non affiché, contribue à la liste + des noms à éviter + - Règle 2 : c'est la dépendance qui décide si on affiche ou pas + + Exemple : + si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors + il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b) + mais f et f0 contribue à la liste des variables à éviter (en supposant + que les noms f et f0 ne sont pas déjà pris) + Intérêt : noms homogènes dans un but avant et après Intro +*) + +type used_idents = identifier list + +let occur_rel p env id = + try lookup_name_of_rel p env = Name id + with Not_found -> false (* Unbound indice : may happen in debug *) + +let occur_id nenv id0 c = + let rec occur n c = match kind_of_term c with + | Var id when id=id0 -> raise Occur + | Const kn when id_of_global (ConstRef kn) = id0 -> raise Occur + | Ind ind_sp + when id_of_global (IndRef ind_sp) = id0 -> + raise Occur + | Construct cstr_sp + when id_of_global (ConstructRef cstr_sp) = id0 -> + raise Occur + | Rel p when p>n & occur_rel (p-n) nenv id0 -> raise Occur + | _ -> iter_constr_with_binders succ occur n c + in + try occur 1 c; false + with Occur -> true + | Not_found -> false (* Case when a global is not in the env *) + +let next_name_not_occuring is_goal_ccl name l env_names t = + let rec next id = + if List.mem id l or occur_id env_names id t or + (* To be consistent with intro mechanism *) + (is_goal_ccl & is_global id & not (is_section_variable id)) + then next (lift_ident id) + else id + in + match name with + | Name id -> next id + | Anonymous -> + (* Normally, an anonymous name is not dependent and will not be *) + (* taken into account by the function concrete_name; just in case *) + (* invent a valid name *) + id_of_string "H" + +(* On reduit une serie d'eta-redex de tete ou rien du tout *) +(* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *) +(* Remplace 2 versions précédentes buggées *) + +let rec eta_reduce_head c = + match kind_of_term c with + | Lambda (_,c1,c') -> + (match kind_of_term (eta_reduce_head c') with + | App (f,cl) -> + let lastn = (Array.length cl) - 1 in + if lastn < 1 then anomaly "application without arguments" + else + (match kind_of_term cl.(lastn) with + | Rel 1 -> + let c' = + if lastn = 1 then f + else mkApp (f, Array.sub cl 0 lastn) + in + if noccurn 1 c' + then lift (-1) c' + else c + | _ -> c) + | _ -> c) + | _ -> c + +(* alpha-eta conversion : ignore print names and casts *) +let eta_eq_constr = + let rec aux t1 t2 = + let t1 = eta_reduce_head (strip_head_cast t1) + and t2 = eta_reduce_head (strip_head_cast t2) in + t1=t2 or compare_constr aux t1 t2 + in aux + + +(* iterator on rel context *) +let process_rel_context f env = + let sign = named_context env in + let rels = rel_context env in + let env0 = reset_with_named_context sign env in + Sign.fold_rel_context f rels ~init:env0 + +let assums_of_rel_context sign = + Sign.fold_rel_context + (fun (na,c,t) l -> + match c with + Some _ -> l + | None -> (na, t)::l) + sign ~init:[] + +let lift_rel_context n sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,option_app (liftn n k) c,type_app (liftn n k) t) + ::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (rel_context_length sign) sign + +let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init + +let rec mem_named_context id = function + | (id',_,_) :: _ when id=id' -> true + | _ :: sign -> mem_named_context id sign + | [] -> false + +let make_all_name_different env = + let avoid = ref (ids_of_named_context (named_context env)) in + process_rel_context + (fun (na,c,t) newenv -> + let id = next_name_away na !avoid in + avoid := id::!avoid; + push_rel (Name id,c,t) newenv) + env + +let global_vars env ids = Idset.elements (global_vars_set env ids) + +let global_vars_set_of_decl env = function + | (_,None,t) -> global_vars_set env t + | (_,Some c,t) -> + Idset.union (global_vars_set env t) + (global_vars_set env c) + +(* Remark: Anonymous var may be dependent in Evar's contexts *) +let concrete_name is_goal_ccl l env_names n c = + if n = Anonymous & noccurn 1 c then + (Anonymous,l) + else + let fresh_id = next_name_not_occuring is_goal_ccl n l env_names c in + let idopt = if noccurn 1 c then Anonymous else Name fresh_id in + (idopt, fresh_id::l) + +let concrete_let_name is_goal_ccl l env_names n c = + let fresh_id = next_name_not_occuring is_goal_ccl n l env_names c in + (Name fresh_id, fresh_id::l) + +let rec rename_bound_var env l c = + match kind_of_term c with + | Prod (Name s,c1,c2) -> + if noccurn 1 c2 then + let env' = push_rel (Name s,None,c1) env in + mkProd (Name s, c1, rename_bound_var env' l c2) + else + let s' = next_ident_away s (global_vars env c2@l) in + let env' = push_rel (Name s',None,c1) env in + mkProd (Name s', c1, rename_bound_var env' (s'::l) c2) + | Prod (Anonymous,c1,c2) -> + let env' = push_rel (Anonymous,None,c1) env in + mkProd (Anonymous, c1, rename_bound_var env' l c2) + | Cast (c,t) -> mkCast (rename_bound_var env l c, t) + | x -> c + diff --git a/pretyping/termops.mli b/pretyping/termops.mli new file mode 100644 index 00000000..dd9742ea --- /dev/null +++ b/pretyping/termops.mli @@ -0,0 +1,186 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit*) +val new_univ : unit -> Univ.universe +val new_sort_in_family : sorts_family -> sorts + +(* iterators on terms *) +val print_sort : sorts -> std_ppcmds +val print_sort_family : sorts_family -> std_ppcmds +val print_constr : constr -> std_ppcmds +val prod_it : init:types -> (name * types) list -> types +val lam_it : init:constr -> (name * types) list -> constr +val rel_vect : int -> int -> constr array +val rel_list : int -> int -> constr list +val extended_rel_list : int -> rel_context -> constr list +val extended_rel_vect : int -> rel_context -> constr array +val push_rel_assum : name * types -> env -> env +val push_rels_assum : (name * types) list -> env -> env +val push_named_rec_types : name array * types array * 'a -> env -> env +val lookup_rel_id : identifier -> rel_context -> int * types +val mkProd_or_LetIn : rel_declaration -> types -> types +val mkProd_wo_LetIn : rel_declaration -> types -> types +val it_mkProd_wo_LetIn : init:types -> rel_context -> types +val it_mkProd_or_LetIn : init:types -> rel_context -> types +val it_mkLambda_or_LetIn : init:constr -> rel_context -> constr +val it_named_context_quantifier : + (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a +val it_mkNamedProd_or_LetIn : init:types -> named_context -> types +val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr + +(**********************************************************************) +(* Generic iterators on constr *) + +val map_constr_with_named_binders : + (name -> 'a -> 'a) -> + ('a -> constr -> constr) -> 'a -> constr -> constr +val map_constr_with_binders_left_to_right : + (rel_declaration -> 'a -> 'a) -> + ('a -> constr -> constr) -> + 'a -> constr -> constr +val map_constr_with_full_binders : + (rel_declaration -> 'a -> 'a) -> + ('a -> constr -> constr) -> 'a -> constr -> constr + +(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate + subterms of [c] starting from [acc] and proceeding from left to + right according to the usual representation of the constructions as + [fold_constr] but it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive *) + +val fold_constr_with_binders : + ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b + +val iter_constr_with_full_binders : + (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> + constr -> unit + +(**********************************************************************) + +val strip_head_cast : constr -> constr + +(* occur checks *) +exception Occur +val occur_meta : types -> bool +val occur_existential : types -> bool +val occur_const : constant -> types -> bool +val occur_evar : existential_key -> types -> bool +val occur_in_global : env -> identifier -> constr -> unit +val occur_var : env -> identifier -> types -> bool +val occur_var_in_decl : + env -> + identifier -> 'a * types option * types -> bool +val occur_term : constr -> constr -> bool +val free_rels : constr -> Intset.t + +(* Substitution of metavariables *) +type metamap = (metavariable * constr) list +val subst_meta : metamap -> constr -> constr + +(* [pop c] lifts by -1 the positive indexes in [c] *) +val pop : constr -> constr + +(* bindings of an arbitrary large term. Uses equality modulo + reduction of let *) +val dependent : constr -> constr -> bool +val subst_term_gen : + (constr -> constr -> bool) -> constr -> constr -> constr +val replace_term_gen : + (constr -> constr -> bool) -> + constr -> constr -> constr -> constr +val subst_term : constr -> constr -> constr +val replace_term : constr -> constr -> constr -> constr +val subst_term_occ_gen : + int list -> int -> constr -> types -> int * types +val subst_term_occ : int list -> constr -> types -> types +val subst_term_occ_decl : + int list -> constr -> named_declaration -> named_declaration + +(* Alternative term equalities *) +val eta_reduce_head : constr -> constr +val eta_eq_constr : constr -> constr -> bool + +(* finding "intuitive" names to hypotheses *) +val first_char : identifier -> string +val lowercase_first_char : identifier -> string +val sort_hdchar : sorts -> string +val hdchar : env -> types -> string +val id_of_name_using_hdchar : + env -> types -> name -> identifier +val named_hd : env -> types -> name -> name +val named_hd_type : env -> types -> name -> name +val prod_name : env -> name * types * types -> constr +val lambda_name : env -> name * types * constr -> constr +val prod_create : env -> types * types -> constr +val lambda_create : env -> types * constr -> constr +val name_assumption : env -> rel_declaration -> rel_declaration +val name_context : env -> rel_context -> rel_context + +val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types +val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr +val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types +val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr + +(* name contexts *) +type names_context = name list +val add_name : name -> names_context -> names_context +val lookup_name_of_rel : int -> names_context -> name +val lookup_rel_of_name : identifier -> names_context -> int +val empty_names_context : names_context +val ids_of_rel_context : rel_context -> identifier list +val ids_of_named_context : named_context -> identifier list +val ids_of_context : env -> identifier list +val names_of_rel_context : env -> names_context + +(* Set of local names *) +val vars_of_env: env -> Idset.t +val add_vname : Idset.t -> name -> Idset.t + +(* sets of free identifiers *) +type used_idents = identifier list +val occur_rel : int -> name list -> identifier -> bool +val occur_id : name list -> identifier -> constr -> bool + +val next_global_ident_away : + (*allow section vars:*) bool -> identifier -> identifier list -> identifier +val next_name_not_occuring : + bool -> name -> identifier list -> name list -> constr -> identifier +val concrete_name : + bool -> identifier list -> name list -> name -> constr -> + name * identifier list +val concrete_let_name : + bool -> identifier list -> name list -> name -> constr -> name * identifier list +val rename_bound_var : env -> identifier list -> types -> types + +(* other signature iterators *) +val process_rel_context : (rel_declaration -> env -> env) -> env -> env +val assums_of_rel_context : rel_context -> (name * constr) list +val lift_rel_context : int -> rel_context -> rel_context +val fold_named_context_both_sides : + ('a -> named_declaration -> named_declaration list -> 'a) -> + named_context -> init:'a -> 'a +val mem_named_context : identifier -> named_context -> bool +val make_all_name_different : env -> env + +val global_vars : env -> constr -> identifier list +val global_vars_set_of_decl : env -> named_declaration -> Idset.t + +(* Test if an identifier is the basename of a global reference *) +val is_section_variable : identifier -> bool diff --git a/pretyping/typing.ml b/pretyping/typing.ml new file mode 100644 index 00000000..a84cd612 --- /dev/null +++ b/pretyping/typing.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* type_app (lift i) t) + +type 'a mach_flags = { + fix : bool; + nocheck : bool } + +(* The typing machine without information, without universes but with + existential variables. *) + +let assumption_of_judgment env sigma j = + assumption_of_judgment env (j_nf_evar sigma j) + +let type_judgment env sigma j = + type_judgment env (j_nf_evar sigma j) + + +let rec execute mf env sigma cstr = + match kind_of_term cstr with + | Meta n -> + error "execute: found a non-instanciated goal" + + | Evar ev -> + let ty = Instantiate.existential_type sigma ev in + let jty = execute mf env sigma ty in + let jty = assumption_of_judgment env sigma jty in + { uj_val = cstr; uj_type = jty } + + | Rel n -> + judge_of_relative env n + + | Var id -> + judge_of_variable env id + + | Const c -> + make_judge cstr (constant_type env c) + + | Ind ind -> + make_judge cstr (type_of_inductive env ind) + + | Construct cstruct -> + make_judge cstr (type_of_constructor env cstruct) + + | Case (ci,p,c,lf) -> + let cj = execute mf env sigma c in + let pj = execute mf env sigma p in + let lfj = execute_array mf env sigma lf in + let (j,_) = judge_of_case env ci pj cj lfj in + j + + | Fix ((vn,i as vni),recdef) -> + if (not mf.fix) && array_exists (fun n -> n < 0) vn then + error "General Fixpoints not allowed"; + let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in + let fix = (vni,recdef') in + check_fix env fix; + make_judge (mkFix fix) tys.(i) + + | CoFix (i,recdef) -> + let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in + let cofix = (i,recdef') in + check_cofix env cofix; + make_judge (mkCoFix cofix) tys.(i) + + | Sort (Prop c) -> + judge_of_prop_contents c + + | Sort (Type u) -> + judge_of_type u + + | App (f,args) -> + let j = execute mf env sigma f in + let jl = execute_array mf env sigma args in + let (j,_) = judge_of_apply env j jl in + j + + | Lambda (name,c1,c2) -> + let j = execute mf env sigma c1 in + let var = type_judgment env sigma j in + let env1 = push_rel (name,None,var.utj_val) env in + let j' = execute mf env1 sigma c2 in + judge_of_abstraction env1 name var j' + + | Prod (name,c1,c2) -> + let j = execute mf env sigma c1 in + let varj = type_judgment env sigma j in + let env1 = push_rel (name,None,varj.utj_val) env in + let j' = execute mf env1 sigma c2 in + let varj' = type_judgment env1 sigma j' in + judge_of_product env name varj varj' + + | LetIn (name,c1,c2,c3) -> + let j1 = execute mf env sigma c1 in + let j2 = execute mf env sigma c2 in + let j2 = type_judgment env sigma j2 in + let _ = judge_of_cast env j1 j2 in + let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let j3 = execute mf env1 sigma c3 in + judge_of_letin env name j1 j2 j3 + + | Cast (c,t) -> + let cj = execute mf env sigma c in + let tj = execute mf env sigma t in + let tj = type_judgment env sigma tj in + let j, _ = judge_of_cast env cj tj in + j + +and execute_recdef mf env sigma (names,lar,vdef) = + let larj = execute_array mf env sigma lar in + let lara = Array.map (assumption_of_judgment env sigma) larj in + let env1 = push_rec_types (names,lara,vdef) env in + let vdefj = execute_array mf env1 sigma vdef in + let vdefv = Array.map j_val vdefj in + let _ = type_fixpoint env1 names lara vdefj in + (names,lara,vdefv) + +and execute_array mf env sigma v = + let jl = execute_list mf env sigma (Array.to_list v) in + Array.of_list jl + +and execute_list mf env sigma = function + | [] -> + [] + | c::r -> + let j = execute mf env sigma c in + let jr = execute_list mf env sigma r in + j::jr + + +let safe_machine env sigma constr = + let mf = { fix = false; nocheck = false } in + execute mf env sigma constr + +let unsafe_machine env sigma constr = + let mf = { fix = false; nocheck = true } in + execute mf env sigma constr + +(* Type of a constr *) + +let type_of env sigma c = + let j = safe_machine env sigma c in + (* No normalization: it breaks Pattern! *) + (*nf_betaiota*) (body_of_type j.uj_type) + +(* The typed type of a judgment. *) + +let execute_type env sigma constr = + let j = execute { fix=false; nocheck=true } env sigma constr in + assumption_of_judgment env sigma j + +let execute_rec_type env sigma constr = + let j = execute { fix=false; nocheck=false } env sigma constr in + assumption_of_judgment env sigma j + diff --git a/pretyping/typing.mli b/pretyping/typing.mli new file mode 100644 index 00000000..4ea74dcd --- /dev/null +++ b/pretyping/typing.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evar_map -> constr -> unsafe_judgment + +val type_of : env -> evar_map -> constr -> constr + +val execute_type : env -> evar_map -> constr -> types + +val execute_rec_type : env -> evar_map -> constr -> types + -- cgit v1.2.3