diff options
Diffstat (limited to 'pretyping')
73 files changed, 25757 insertions, 0 deletions
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml new file mode 100644 index 0000000000..3b3de33d8e --- /dev/null +++ b/pretyping/arguments_renaming.ml @@ -0,0 +1,113 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Names +open Globnames +open Term +open Constr +open Context +open Environ +open Util +open Libobject + +module NamedDecl = Context.Named.Declaration +(*i*) + +let name_table = + Summary.ref (GlobRef.Map.empty : Name.t list GlobRef.Map.t) + ~name:"rename-arguments" + +type req = + | ReqLocal + | ReqGlobal of GlobRef.t * Name.t list + +let load_rename_args _ (_, (_, (r, names))) = + name_table := GlobRef.Map.add r names !name_table + +let cache_rename_args o = load_rename_args 1 o + +let classify_rename_args = function + | ReqLocal, _ -> Dispose + | ReqGlobal _, _ as o -> Substitute o + +let subst_rename_args (subst, (_, (r, names as orig))) = + ReqLocal, + let r' = fst (subst_global subst r) in + if r==r' then orig else (r', names) + +let discharge_rename_args = function + | _, (ReqGlobal (c, names), _ as req) when not (isVarRef c && Lib.is_in_section c) -> + (try + let vars = Lib.variable_section_segment_of_reference c in + let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in + let names' = var_names @ names in + Some (ReqGlobal (c, names), (c, names')) + with Not_found -> Some req) + | _ -> None + +let rebuild_rename_args x = x + +let inRenameArgs = declare_object { (default_object "RENAME-ARGUMENTS" ) with + load_function = load_rename_args; + cache_function = cache_rename_args; + classify_function = classify_rename_args; + subst_function = subst_rename_args; + discharge_function = discharge_rename_args; + rebuild_function = rebuild_rename_args; +} + +let rename_arguments local r names = + let req = if local then ReqLocal else ReqGlobal (r, names) in + Lib.add_anonymous_leaf (inRenameArgs (req, (r, names))) + +let arguments_names r = GlobRef.Map.find r !name_table + +let rename_type ty ref = + let name_override old_name override = + match override with + | Name _ as x -> {old_name with binder_name=x} + | Anonymous -> old_name in + let rec rename_type_aux c = function + | [] -> c + | rename :: rest as renamings -> + match kind_of_type c with + | ProdType (old, s, t) -> + mkProd (name_override old rename, s, rename_type_aux t rest) + | LetInType(old, s, b, t) -> + mkLetIn (old ,s, b, rename_type_aux t renamings) + | CastType (t,_) -> rename_type_aux t renamings + | SortType _ -> c + | AtomicType _ -> c in + try rename_type_aux ty (arguments_names ref) + with Not_found -> ty + +let rename_type_of_constant env c = + let ty = Typeops.type_of_constant_in env c in + rename_type ty (ConstRef (fst c)) + +let rename_type_of_inductive env ind = + let ty = Inductiveops.type_of_inductive env ind in + rename_type ty (IndRef (fst ind)) + +let rename_type_of_constructor env cstruct = + let ty = Inductiveops.type_of_constructor env cstruct in + rename_type ty (ConstructRef (fst cstruct)) + +let rename_typing env c = + let j = Typeops.infer env c in + let j' = + match kind c with + | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) } + | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) } + | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } + | _ -> j + in j' + diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli new file mode 100644 index 0000000000..6d1b6eefd4 --- /dev/null +++ b/pretyping/arguments_renaming.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open Constr + +val rename_arguments : bool -> GlobRef.t -> Name.t list -> unit + +(** [Not_found] is raised if no names are defined for [r] *) +val arguments_names : GlobRef.t -> Name.t list + +val rename_type : types -> GlobRef.t -> types + +val rename_type_of_constant : env -> pconstant -> types +val rename_type_of_inductive : env -> pinductive -> types +val rename_type_of_constructor : env -> pconstructor -> types +val rename_typing : env -> constr -> unsafe_judgment diff --git a/pretyping/cases.ml b/pretyping/cases.ml new file mode 100644 index 0000000000..d7a6c4c832 --- /dev/null +++ b/pretyping/cases.ml @@ -0,0 +1,2725 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module CVars = Vars + +open Pp +open CErrors +open Util +open Names +open Nameops +open Constr +open Context +open Termops +open Environ +open EConstr +open Vars +open Namegen +open Declarations +open Inductiveops +open Reductionops +open Type_errors +open Glob_term +open Glob_ops +open Retyping +open Pretype_errors +open Evarutil +open Evardefine +open Evarsolve +open Evarconv +open Evd +open Context.Rel.Declaration +open GlobEnv + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* Pattern-matching errors *) + +type pattern_matching_error = + | BadPattern of constructor * constr + | BadConstructor of constructor * inductive + | WrongNumargConstructor of constructor * int + | WrongNumargInductive of inductive * int + | UnusedClause of cases_pattern list + | NonExhaustive of cases_pattern list + | CannotInferPredicate of (constr * types) array + +exception PatternMatchingError of env * evar_map * pattern_matching_error + +let raise_pattern_matching_error ?loc (env,sigma,te) = + Loc.raise ?loc (PatternMatchingError(env,sigma,te)) + +let error_bad_pattern ?loc env sigma cstr ind = + raise_pattern_matching_error ?loc + (env, sigma, BadPattern (cstr,ind)) + +let error_bad_constructor ?loc env cstr ind = + raise_pattern_matching_error ?loc + (env, Evd.empty, BadConstructor (cstr,ind)) + +let error_wrong_numarg_constructor ?loc env c n = + raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargConstructor(c,n)) + +let error_wrong_numarg_inductive ?loc env c n = + raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargInductive(c,n)) + +let list_try_compile f l = + let rec aux errors = function + | [] -> if errors = [] then anomaly (str "try_find_f.") else iraise (List.last errors) + | h::t -> + try f h + with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e -> + let e = CErrors.push e in + aux (e::errors) t in + aux [] l + +let force_name = + let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na + +(************************************************************************) +(* Pattern-matching compilation (Cases) *) +(************************************************************************) + +(************************************************************************) +(* Configuration, errors and warnings *) + +open Pp + +let msg_may_need_inversion () = + strbrk "Found a matching with no clauses on a term unknown to have an empty inductive type." + +(* Utils *) +let make_anonymous_patvars n = + List.make n (DAst.make @@ PatVar Anonymous) + +(* 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 relocate_rel n1 n2 k j = if Int.equal j (n1 + k) then n2+k else j + +let rec relocate_index sigma n1 n2 k t = + match EConstr.kind sigma t with + | Rel j when Int.equal j (n1 + k) -> mkRel (n2+k) + | Rel j when j < n1+k -> t + | Rel j when j > n1+k -> t + | _ -> EConstr.map_with_binders sigma succ (relocate_index sigma n1 n2) k t + +(**********************************************************************) +(* Structures used in compiling pattern-matching *) + +let (!!) env = GlobEnv.env env + +type 'a rhs = + { rhs_env : GlobEnv.t; + rhs_vars : Id.Set.t; + avoid_ids : Id.Set.t; + it : 'a option} + +type 'a equation = + { patterns : cases_pattern list; + rhs : 'a rhs; + alias_stack : Name.t list; + eqn_loc : Loc.t option; + used : bool ref } + +type 'a matrix = 'a equation list + +(* 1st argument of IsInd is the original ind before extracting the summary *) +type tomatch_type = + | IsInd of types * inductive_type * Name.t list + | NotInd of constr option * types + +(* spiwack: The first argument of [Pushed] is [true] for initial + Pushed and [false] otherwise. Used to decide whether the term being + matched on must be aliased in the variable case (only initial + Pushed need to be aliased). The first argument of [Alias] is [true] + if the alias was introduced by an initial pushed and [false] + otherwise.*) +type tomatch_status = + | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) + | Alias of (bool*(Name.t * constr * (constr * types))) + | NonDepAlias + | Abstract of int * rel_declaration + +type tomatch_stack = tomatch_status list + +(* We keep a constr for aliases and a cases_pattern for error message *) + +type pattern_history = + | Top + | MakeConstructor of constructor * 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 feed_history arg = function + | Continuation (n, l, h) when n>=1 -> + Continuation (n-1, arg :: l, h) + | Continuation (n, _, _) -> + anomaly (str "Bad number of expected remaining patterns: " ++ int n ++ str ".") + | Result _ -> + anomaly (Pp.str "Exhausted pattern history.") + +(* This is for non exhaustive error message *) + +let rec glob_pattern_of_partial_history args2 = function + | Continuation (n, args1, h) -> + let args3 = make_anonymous_patvars (n - (List.length args2)) in + build_glob_pattern (List.rev_append args1 (args2@args3)) h + | Result pl -> pl + +and build_glob_pattern args = function + | Top -> args + | MakeConstructor (pci, rh) -> + glob_pattern_of_partial_history + [DAst.make @@ PatCstr (pci, args, Anonymous)] rh + +let complete_history = glob_pattern_of_partial_history [] + +(* This is to build glued pattern-matching history and alias bodies *) + +let pop_history_pattern = function + | Continuation (0, l, Top) -> + Result (List.rev l) + | Continuation (0, l, MakeConstructor (pci, rh)) -> + feed_history (DAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh + | _ -> + anomaly (Pp.str "Constructor not yet filled with its arguments.") + +let pop_history h = + feed_history (DAst.make @@ PatVar Anonymous) h + +(* Builds a continuation expecting [n] arguments and building [ci] applied + to this [n] arguments *) + +let push_history_pattern n pci cont = + Continuation (n, [], MakeConstructor (pci, cont)) + +(* A pattern-matching problem has the following form: + + env, evd |- match terms_to_tomatch return pred with mat end + + where terms_to_match is some sequence of "instructions" (t1 ... tp) + + 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; in Pushed ((c,tm),deps,na), + [c] is the reference to the term (which is a Rel or an initial term), [tm] is + its type (telling whether we know if it is an inductive type or not), + [deps] is the list of terms to abstract before matching on [c] (these are + rels too) + - "Abstract" instructions mean that an abstraction has to be inserted in the + current branch to build (this means a pattern has been detected dependent + in another one and a generalization is necessary to ensure well-typing) + Abstract instructions extend the [env] in which the other instructions + are typed + - "Alias" instructions mean 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) + - "NonDepAlias" instructions mean the completion of a matching over + a term to match as for Alias but without inserting this alias + because there is no dependency in it + + 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 'a pattern_matching_problem = + { env : GlobEnv.t; + pred : constr; + tomatch : tomatch_stack; + history : pattern_continuation; + mat : 'a matrix; + caseloc : Loc.t option; + casestyle : case_style; + typing_function: type_constraint -> GlobEnv.t -> evar_map -> 'a option -> evar_map * 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 * + * match n with O => true | _ => false end * + * match x in I with C => true | _ => false end * + *--------------------------------------------------------------------------*) + +(* Computing the inductive type from the matrix of patterns *) + +(* We use the "in I" clause to coerce the terms to match and otherwise + use the constructor to know in which type is the matching problem + + Note that insertion of coercions inside nested patterns is done + each time the matrix is expanded *) + +let rec find_row_ind = function + [] -> None + | p :: l -> + match DAst.get p with + | PatVar _ -> find_row_ind l + | PatCstr(c,_,_) -> Some (p.CAst.loc,c) + +let inductive_template env sigma tmloc ind = + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + let arsign = inductive_alldecls env indu in + let indu = on_snd EInstance.make indu in + let hole_source i = match tmloc with + | Some loc -> Loc.tag ~loc @@ Evar_kinds.TomatchTypeParameter (ind,i) + | None -> Loc.tag @@ Evar_kinds.TomatchTypeParameter (ind,i) in + let (sigma, _, evarl, _) = + List.fold_right + (fun decl (sigma, subst, evarl, n) -> + match decl with + | LocalAssum (na,ty) -> + let ty = EConstr.of_constr ty in + let ty' = substl subst ty in + let sigma, e = + Evarutil.new_evar env ~src:(hole_source n) ~typeclass_candidate:false sigma ty' + in + (sigma, e::subst,e::evarl,n+1) + | LocalDef (na,b,ty) -> + let b = EConstr.of_constr b in + (sigma, substl subst b::subst,evarl,n+1)) + arsign (sigma, [], [], 1) in + sigma, applist (mkIndU indu,List.rev evarl) + +let try_find_ind env sigma typ realnames = + let (IndType(indf,realargs) as ind) = find_rectype env sigma typ in + let names = + match realnames with + | Some names -> names + | None -> + let ind = fst (fst (dest_ind_family indf)) in + List.make (inductive_nrealdecls env ind) Anonymous in + IsInd (typ,ind,names) + +let inh_coerce_to_ind env sigma0 loc ty tyi = + let sigma, expected_typ = inductive_template env sigma0 loc tyi in + (* Try to refine the type with inductive information coming from the + constructor and renounce if not able to give more information *) + (* devrait être indifférent d'exiger leq ou pas puisque pour + un inductif cela doit être égal *) + match Evarconv.unify_leq_delay env sigma expected_typ ty with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> sigma0 + +let binding_vars_of_inductive sigma = function + | NotInd _ -> [] + | IsInd (_,IndType(_,realargs),_) -> List.filter (isRel sigma) realargs + +let set_tomatch_realnames names = function + | NotInd _ as t -> t + | IsInd (typ,ind,_) -> IsInd (typ,ind,names) + +let extract_inductive_data env sigma decl = + match decl with + | LocalAssum (_,t) -> + let tmtyp = + try try_find_ind env sigma t None + with Not_found -> NotInd (None,t) in + let tmtypvars = binding_vars_of_inductive sigma tmtyp in + (tmtyp,tmtypvars) + | LocalDef (_,_,t) -> + (NotInd (None, t), []) + +let unify_tomatch_with_patterns env sigma loc typ pats realnames = + match find_row_ind pats with + | None -> sigma, NotInd (None,typ) + | Some (_,(ind,_)) -> + let sigma = inh_coerce_to_ind env sigma loc typ ind in + try sigma, try_find_ind env sigma typ realnames + with Not_found -> sigma, NotInd (None,typ) + +let find_tomatch_tycon env sigma loc = function + (* Try if some 'in I ...' is present and can be used as a constraint *) + | Some {CAst.v=(ind,realnal)} -> + let sigma, tycon = inductive_template env sigma loc ind in + sigma, mk_tycon tycon, Some (List.rev realnal) + | None -> + sigma, empty_tycon, None + +let make_return_predicate_ltac_lvar env sigma na tm c = + (* If we have an [x as x return ...] clause and [x] expands to [c], + we have to update the status of [x] in the substitution: + - if [c] is a variable [id'], then [x] should now become [id'] + - otherwise, [x] should be hidden *) + match na, DAst.get tm with + | Name id, (GVar id' | GRef (Globnames.VarRef id', _)) when Id.equal id id' -> + let expansion = match kind sigma c with + | Var id' -> Name id' + | _ -> Anonymous in + GlobEnv.hide_variable env expansion id + | _ -> env + +let is_patvar pat = + match DAst.get pat with + | PatVar _ -> true + | _ -> false + +let coerce_row ~program_mode typing_fun env sigma pats (tomatch,(na,indopt)) = + let loc = loc_of_glob_constr tomatch in + let sigma, tycon, realnames = find_tomatch_tycon !!env sigma loc indopt in + let sigma, j = typing_fun tycon env sigma tomatch in + let sigma, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) ~program_mode !!env sigma j in + let typ = nf_evar sigma j.uj_type in + let env = make_return_predicate_ltac_lvar env sigma na tomatch j.uj_val in + let sigma, t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then + sigma, NotInd (None,typ) + else + try sigma, try_find_ind !!env sigma typ realnames + with Not_found -> + unify_tomatch_with_patterns !!env sigma loc typ pats realnames + in + ((env, sigma), (j.uj_val,t)) + +let coerce_to_indtype ~program_mode typing_fun env sigma matx tomatchl = + let pats = List.map (fun r -> r.patterns) matx in + let matx' = match matrix_transpose pats with + | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) + | m -> m in + let (env, sigma), tms = List.fold_left2_map (fun (env, sigma) -> coerce_row ~program_mode typing_fun env sigma) (env, sigma) matx' tomatchl in + env, sigma, tms + +(************************************************************************) +(* Utils *) + +let mkExistential ?(src=(Loc.tag Evar_kinds.InternalHole)) env sigma = + let sigma, (e, u) = Evarutil.new_type_evar env sigma ~src:src univ_flexible_alg in + sigma, e + +let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = + (* Ideally, we could find a common inductive type to which both the + term to match and the patterns coerce *) + (* In practice, we coerce the term to match if it is not already an + inductive type and it is not dependent; moreover, we use only + the first pattern type and forget about the others *) + let typ,names = + match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in + let tmtyp = + try try_find_ind !!(pb.env) sigma typ names + with Not_found -> NotInd (None,typ) in + match tmtyp with + | NotInd (None,typ) -> + let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in + (match find_row_ind tm1 with + | None -> sigma, (current, tmtyp) + | Some (loc,(ind,_)) -> + let sigma, indt = inductive_template !!(pb.env) sigma None ind in + let sigma, current = + if List.is_empty deps && isEvar sigma typ then + (* Don't insert coercions if dependent; only solve evars *) + match Evarconv.unify_leq_delay !!(pb.env) sigma indt typ with + | exception Evarconv.UnableToUnify _ -> sigma, current + | sigma -> sigma, current + else + let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in + sigma, j.uj_val + in + sigma, (current, try_find_ind !!(pb.env) sigma indt names)) + | _ -> sigma, (current, tmtyp) + +let type_of_tomatch = function + | IsInd (t,_,_) -> t + | NotInd (_,t) -> t + +let map_tomatch_type f = function + | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type f ind,names) + | NotInd (c,t) -> NotInd (Option.map f c, f t) + +let liftn_tomatch_type n depth = map_tomatch_type (Vars.liftn n depth) +let lift_tomatch_type n = liftn_tomatch_type n 1 + +(**********************************************************************) +(* Utilities on patterns *) + +let current_pattern eqn = + match eqn.patterns with + | pat::_ -> pat + | [] -> anomaly (Pp.str "Empty list of patterns.") + +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 (Pp.str "Empty list of patterns.") + +let push_current_pattern ~program_mode sigma (cur,ty) eqn = + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + match eqn.patterns with + | pat::pats -> + let r = Sorts.Relevant in (* TODO relevance *) + let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (make_annot (alias_of_pat pat) r,cur,ty)) eqn.rhs.rhs_env in + { eqn with + rhs = { eqn.rhs with rhs_env = rhs_env }; + patterns = pats } + | [] -> anomaly (Pp.str "Empty list of patterns.") + +(* spiwack: like [push_current_pattern] but does not introduce an + alias in rhs_env. Aliasing binders are only useful for variables at + the root of a pattern matching problem (initial push), so we + distinguish the cases. *) +let push_noalias_current_pattern eqn = + match eqn.patterns with + | _::pats -> + { eqn with patterns = pats } + | [] -> anomaly (Pp.str "push_noalias_current_pattern: Empty list of patterns.") + + + +let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } + +(**********************************************************************) +(* Well-formedness tests *) +(* Partial check on patterns *) + +exception NotAdjustable + +let rec adjust_local_defs ?loc = function + | (pat :: pats, LocalAssum _ :: decls) -> + pat :: adjust_local_defs ?loc (pats,decls) + | (pats, LocalDef _ :: decls) -> + (DAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls) + | [], [] -> [] + | _ -> raise NotAdjustable + +let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with + | PatVar _ -> pat + | PatCstr (((_,i) as cstr),args,alias) -> + let loc = pat.CAst.loc in + (* Check it is constructor of the right type *) + let ind' = inductive_of_constructor cstr in + if eq_ind 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 Int.equal (List.length args) nb_args_constr then pat + else + try + let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) + in DAst.make ?loc @@ PatCstr (cstr, args', alias) + with NotAdjustable -> + error_wrong_numarg_constructor ?loc env cstr nb_args_constr + else + (* Try to insert a coercion *) + try + Coercion.inh_pattern_coerce_to ?loc env pat ind' ind + with Not_found -> + error_bad_constructor ?loc env cstr ind + +let check_all_variables env sigma typ mat = + List.iter + (fun eqn -> + let pat = current_pattern eqn in + match DAst.get pat with + | PatVar id -> () + | PatCstr (cstr_sp,_,_) -> + let loc = pat.CAst.loc in + error_bad_pattern ?loc env sigma cstr_sp typ) + mat + +let check_unused_pattern env eqn = + if not !(eqn.used) then + raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) + +let set_used_pattern eqn = eqn.used := true + +let extract_rhs pb = + match pb.mat with + | [] -> user_err ~hdr:"build_leaf" (msg_may_need_inversion()) + | eqn::_ -> + set_used_pattern eqn; + eqn.rhs + +(**********************************************************************) +(* Functions to deal with matrix factorization *) + +let occur_in_rhs na rhs = + match na with + | Anonymous -> false + | Name id -> Id.Set.mem id rhs.rhs_vars + +let is_dep_patt_in eqn pat = match DAst.get pat with + | PatVar name -> occur_in_rhs name eqn.rhs + | PatCstr _ -> true + +let mk_dep_patt_row ~program_mode (pats,_,eqn) = + if program_mode then List.map (fun _ -> true) pats + else List.map (is_dep_patt_in eqn) pats + +let dependencies_in_pure_rhs ~program_mode nargs eqns = + if List.is_empty eqns then + List.make nargs (not program_mode) (* Only "_" patts *) else + let deps_rows = List.map (mk_dep_patt_row ~program_mode) eqns in + let deps_columns = matrix_transpose deps_rows in + List.map (List.exists (fun x -> x)) deps_columns + +let dependent_decl sigma a = + function + | LocalAssum (na,t) -> dependent sigma a t + | LocalDef (na,c,t) -> dependent sigma a t || dependent sigma a c + +let rec dep_in_tomatch sigma n = function + | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch sigma n l + | Abstract (_,d) :: l -> RelDecl.exists (fun c -> not (noccurn sigma n c)) d || dep_in_tomatch sigma (n+1) l + | [] -> false + +let dependencies_in_rhs ~program_mode sigma nargs current tms eqns = + match EConstr.kind sigma current with + | Rel n when dep_in_tomatch sigma n tms -> List.make nargs true + | _ -> dependencies_in_pure_rhs ~program_mode nargs eqns + +(* Computing the matrix of dependencies *) + +(* [find_dependency_list tmi [d(i+1);...;dn]] computes in which + declarations [d(i+1);...;dn] the term [tmi] is dependent in. + + [find_dependencies_signature (used1,...,usedn) ((tm1,d1),...,(tmn,dn))] + returns [(deps1,...,depsn)] where [depsi] is a subset of tm(i+1),..,tmn + denoting in which of the d(i+1)...dn, the term tmi is dependent. +*) + +let rec find_dependency_list sigma tmblock = function + | [] -> [] + | (used,tdeps,tm,d)::rest -> + let deps = find_dependency_list sigma tmblock rest in + if used && List.exists (fun x -> dependent_decl sigma x d) tmblock + then + match EConstr.kind sigma tm with + | Rel n -> List.add_set Int.equal n (List.union Int.equal deps tdeps) + | _ -> List.union Int.equal deps tdeps + else deps + +let find_dependencies sigma is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist = + let deps = find_dependency_list sigma (tm::tmtypleaves) nextlist in + if is_dep_or_cstr_in_rhs || not (List.is_empty deps) + then ((true ,deps,tm,d)::nextlist) + else ((false,[] ,tm,d)::nextlist) + +let find_dependencies_signature sigma deps_in_rhs typs = + let l = List.fold_right2 (find_dependencies sigma) deps_in_rhs typs [] in + List.map (fun (_,deps,_,_) -> deps) l + +(* Assume we had terms t1..tq to match in a context xp:Tp,...,x1:T1 |- + and xn:Tn has just been regeneralized into x:Tn so that the terms + to match are now to be considered in the context xp:Tp,...,x1:T1,x:Tn |-. + + [relocate_index_tomatch n 1 tomatch] updates t1..tq so that + former references to xn1 are now references to x. Note that t1..tq + are already adjusted to the context xp:Tp,...,x1:T1,x:Tn |-. + + [relocate_index_tomatch 1 n tomatch] will go the way back. + *) + +let relocate_index_tomatch sigma n1 n2 = + let rec genrec depth = function + | [] -> + [] + | Pushed (b,((c,tm),l,na)) :: rest -> + let c = relocate_index sigma n1 n2 depth c in + let tm = map_tomatch_type (relocate_index sigma n1 n2 depth) tm in + let l = List.map (relocate_rel n1 n2 depth) l in + Pushed (b,((c,tm),l,na)) :: genrec depth rest + | Alias (initial,(na,c,d)) :: rest -> + (* [c] is out of relocation scope *) + Alias (initial,(na,c,map_pair (relocate_index sigma n1 n2 depth) d)) :: genrec depth rest + | NonDepAlias :: rest -> + NonDepAlias :: genrec depth rest + | Abstract (i,d) :: rest -> + let i = relocate_rel n1 n2 depth i in + Abstract (i, RelDecl.map_constr (fun c -> relocate_index sigma n1 n2 depth c) d) + :: genrec (depth+1) rest in + genrec 0 + +(* [replace_tomatch n c tomatch] replaces [Rel n] by [c] in [tomatch] *) + +let rec replace_term sigma n c k t = + if isRel sigma t && Int.equal (destRel sigma t) (n + k) then Vars.lift k c + else EConstr.map_with_binders sigma succ (replace_term sigma n c) k t + +let length_of_tomatch_type_sign na t = + let l = match na with + | Anonymous -> 0 + | Name _ -> 1 + in + match t with + | NotInd _ -> l + | IsInd (_, _, names) -> List.length names + l + +let replace_tomatch sigma n c = + let rec replrec depth = function + | [] -> [] + | Pushed (initial,((b,tm),l,na)) :: rest -> + let b = replace_term sigma n c depth b in + let tm = map_tomatch_type (replace_term sigma n c depth) tm in + List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch.")) l; + Pushed (initial,((b,tm),l,na)) :: replrec depth rest + | Alias (initial,(na,b,d)) :: rest -> + (* [b] is out of replacement scope *) + Alias (initial,(na,b,map_pair (replace_term sigma n c depth) d)) :: replrec depth rest + | NonDepAlias :: rest -> + NonDepAlias :: replrec depth rest + | Abstract (i,d) :: rest -> + Abstract (i, RelDecl.map_constr (fun t -> replace_term sigma n c depth t) d) + :: replrec (depth+1) rest in + replrec 0 + +(* [liftn_tomatch_stack]: a 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 pushed terms to match must be lifted by n + (knowing that [Abstract] introduces a binder in the list of pushed + terms to match). +*) + +let rec liftn_tomatch_stack n depth = function + | [] -> [] + | Pushed (initial,((c,tm),l,na))::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<depth then i else i+n) l in + Pushed (initial,((c,tm),l,na))::(liftn_tomatch_stack n depth rest) + | Alias (initial,(na,c,d))::rest -> + Alias (initial,(na,liftn n depth c,map_pair (liftn n depth) d)) + ::(liftn_tomatch_stack n depth rest) + | NonDepAlias :: rest -> + NonDepAlias :: liftn_tomatch_stack n depth rest + | Abstract (i,d)::rest -> + let i = if i<depth then i else i+n in + Abstract (i, RelDecl.map_constr (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: + + [match y with (S (S x)) => x | x => x end] should be compiled into + [match y with O => y | (S n) => match n with O => y | (S x) => x end end] + + and [match y with (S (S n)) => n | n => n end] into + [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] + + i.e. user names should be preserved and created names should not + interfere with user names + + The exact names here are not important for typing (because they are + put in pb.env and not in the rhs.rhs_env of branches. However, + whether a name is Anonymous or not may have an effect on whether a + generalization is done or not. + *) + +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 avoid env sigma sign eqns = + let names1 = List.make (Context.Rel.length sign) Anonymous in + (* If any, we prefer names used in pats, from top to bottom *) + let names2,aliasname = + List.fold_right + (fun (pats,pat_alias,eqn) (names,aliasname) -> + (merge_names alias_of_pat pats names, + merge_name (fun x -> x) pat_alias aliasname)) + eqns (names1,Anonymous) 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) -> Id.Set.union l eqn.rhs.avoid_ids) + avoid eqns in + let names3,_ = + List.fold_left2 + (fun (l,avoid) d na -> + let na = + merge_name + (fun decl -> + let na = get_name decl in + let t = get_type decl in + Name (next_name_away (named_hd env sigma t na) avoid)) + d na + in + (na::l,Id.Set.add (Name.get_id na) avoid)) + ([],allvars) (List.rev sign) names2 in + names3,aliasname + +(*****************************************************************) +(* Recovering names for variables pushed to the rhs' environment *) +(* We just factorized a match over a matrix of equations *) +(* "C xi1 .. xin as xi" as a single match over "C y1 .. yn as y" *) +(* We now replace the names y1 .. yn y by the actual names *) +(* xi1 .. xin xi to be found in the i-th clause of the matrix *) + +let recover_initial_subpattern_names = List.map2 RelDecl.set_name + +let recover_and_adjust_alias_names (_,avoid) names sign = + let rec aux = function + | [],[] -> + [] + | x::names, LocalAssum (x',t)::sign -> + (x, LocalAssum ({x' with binder_name=alias_of_pat x},t)) :: aux (names,sign) + | names, (LocalDef (na,_,_) as decl)::sign -> + (DAst.make @@ PatVar na.binder_name, decl) :: aux (names,sign) + | _ -> assert false + in + List.split (aux (names,sign)) + +let push_rels_eqn ~hypnaming sigma sign eqn = + {eqn with + rhs = {eqn.rhs with rhs_env = snd (push_rel_context ~hypnaming sigma sign eqn.rhs.rhs_env) } } + +let push_rels_eqn_with_names sigma sign eqn = + let subpats = List.rev (List.firstn (List.length sign) eqn.patterns) in + let subpatnames = List.map alias_of_pat subpats in + let sign = recover_initial_subpattern_names subpatnames sign in + push_rels_eqn sigma sign eqn + +let push_generalized_decl_eqn ~hypnaming env sigma n decl eqn = + match RelDecl.get_name decl with + | Anonymous -> + push_rels_eqn ~hypnaming sigma [decl] eqn + | Name _ -> + push_rels_eqn ~hypnaming sigma [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n !!(eqn.rhs.rhs_env))) decl] eqn + +let drop_alias_eqn eqn = + { eqn with alias_stack = List.tl eqn.alias_stack } + +let push_alias_eqn sigma alias eqn = + let aliasname = List.hd eqn.alias_stack in + let eqn = drop_alias_eqn eqn in + let alias = RelDecl.set_name aliasname alias in + push_rels_eqn sigma [alias] eqn + +(**********************************************************************) +(* Functions to deal with elimination predicate *) + +(* 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)]psi and it has to +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 "match z with (Ci xi1..xipi) + => ... end" or a "psi(yk)", with psi extracting xij from uik, should be + inserted somewhere in Ti. + +- If T is undefined, an easy solution is to insert a "match z with + (Ci xi1..xipi) => ... end" 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 + +*) + +(* Propagation of user-provided predicate through compilation steps *) + +let rec map_predicate f k ccl = function + | [] -> f k ccl + | Pushed (_,((_,tm),_,na)) :: rest -> + let k' = length_of_tomatch_type_sign na tm in + map_predicate f (k+k') ccl rest + | (Alias _ | NonDepAlias) :: rest -> + map_predicate f k ccl rest + | Abstract _ :: rest -> + map_predicate f (k+1) ccl rest + +let noccur_predicate_between sigma n = map_predicate (noccur_between sigma n) + +let liftn_predicate n = map_predicate (liftn n) + +let lift_predicate n = liftn_predicate n 1 + +let regeneralize_index_predicate sigma n = map_predicate (relocate_index sigma n 1) 0 + +let substnl_predicate sigma = map_predicate (substnl sigma) + +(* This is parallel bindings *) +let subst_predicate (subst,copt) ccl tms = + let sigma = match copt with + | None -> subst + | Some c -> c::subst in + substnl_predicate sigma 0 ccl tms + +let specialize_predicate_var (cur,typ,dep) env tms ccl = + let c = match dep with + | Anonymous -> None + | Name _ -> Some cur + in + let l = + match typ with + | IsInd (_, IndType (_, _), []) -> [] + | IsInd (_, IndType (indf, realargs), names) -> + let arsign,_ = get_arity env indf in + let arsign = List.map EConstr.of_rel_decl arsign in + subst_of_rel_context_instance arsign realargs + | NotInd _ -> [] in + subst_predicate (l,c) ccl tms + +(*****************************************************************************) +(* 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 sigma (names,na) ny d tms ccl = + let () = match na with + | Anonymous -> anomaly (Pp.str "Undetected dependency.") + | _ -> () in + let p = List.length names + 1 in + let ccl = lift_predicate 1 ccl tms in + regeneralize_index_predicate sigma (ny+p+1) ccl tms + +(*****************************************************************************) +(* We just matched over cur:ind(realargs) in the following matching problem *) +(* *) +(* env |- match cur tms return ccl with ... end *) +(* *) +(* and we want to build the predicate corresponding to the individual *) +(* matching over cur *) +(* *) +(* pred = fun X:realargstyps x:ind(X)] PI tms.ccl *) +(* *) +(* where pred is computed by abstract_predicate and PI tms.ccl by *) +(* extract_predicate *) +(*****************************************************************************) +let rec extract_predicate ccl = function + | (Alias _ | NonDepAlias)::tms -> + (* substitution already done in build_branch *) + extract_predicate ccl tms + | Abstract (i,d)::tms -> + mkProd_wo_LetIn d (extract_predicate ccl tms) + | Pushed (_,((cur,NotInd _),_,na))::tms -> + begin match na with + | Anonymous -> extract_predicate ccl tms + | Name _ -> + let tms = lift_tomatch_stack 1 tms in + let pred = extract_predicate ccl tms in + subst1 cur pred + end + | Pushed (_,((cur,IsInd (_,IndType(_,realargs),_)),_,na))::tms -> + let realargs = List.rev realargs in + let k, nrealargs = match na with + | Anonymous -> 0, realargs + | Name _ -> 1, (cur :: realargs) + in + let tms = lift_tomatch_stack (List.length realargs + k) tms in + let pred = extract_predicate ccl tms in + substl nrealargs pred + | [] -> + ccl + +let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = + let sign = make_arity_signature !!env sigma true indf in + (* n is the number of real args + 1 (+ possible let-ins in sign) *) + let n = List.length sign in + (* Before abstracting we generalize over cur and on those realargs *) + (* that are rels, consistently with the specialization made in *) + (* build_branch *) + let tms = List.fold_right2 (fun par arg tomatch -> + match EConstr.kind sigma par with + | Rel i -> relocate_index_tomatch sigma (i+n) (destRel sigma arg) tomatch + | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list EConstr.mkRel 0 sign) + (lift_tomatch_stack n tms) in + (* Pred is already dependent in the current term to match (if *) + (* (na<>Anonymous) and its realargs; we just need to adjust it to *) + (* full sign if dep in cur is not taken into account *) + let ccl = match na with + | Anonymous -> lift_predicate 1 ccl tms + | Name _ -> ccl + in + let pred = extract_predicate ccl tms in + (* Build the predicate properly speaking *) + let sign = List.map2 set_name (na::names) sign in + it_mkLambda_or_LetIn_name !!env sigma pred sign + +(* [expand_arg] is used by [specialize_predicate] + if Yk denotes [Xk;xk] or [Xk], + it replaces gamma, x1...xn, x1...xk Yk+1...Yn |- pred + by gamma, x1...xn, x1...xk-1 [Xk;xk] Yk+1...Yn |- pred (if dep) or + by gamma, x1...xn, x1...xk-1 [Xk] Yk+1...Yn |- pred (if not dep) *) + +let expand_arg tms (p,ccl) ((_,t),_,na) = + let k = length_of_tomatch_type_sign na t in + (p+k,liftn_predicate (k-1) (p+1) ccl tms) + +let use_unit_judge env evd = + let j, ctx = coq_unit_judge !!env in + let evd' = Evd.merge_context_set Evd.univ_flexible evd ctx in + evd', j + +let add_assert_false_case pb tomatch = + let pats = List.map (fun _ -> DAst.make @@ PatVar Anonymous) tomatch in + let aliasnames = + List.map_filter (function Alias _ | NonDepAlias -> Some Anonymous | _ -> None) tomatch + in + [ { patterns = pats; + rhs = { rhs_env = pb.env; + rhs_vars = Id.Set.empty; + avoid_ids = Id.Set.empty; + it = None }; + alias_stack = Anonymous::aliasnames; + eqn_loc = None; + used = ref false } ] + +let adjust_impossible_cases sigma pb pred tomatch submat = + match submat with + | [] -> + (* FIXME: This breaks if using evar-insensitive primitives. In particular, + this means that the Evd.define below may redefine an already defined + evar. See e.g. first definition of test for bug #3388. *) + let pred = EConstr.Unsafe.to_constr pred in + begin match Constr.kind pred with + | Evar (evk,_) when snd (evar_source evk sigma) == Evar_kinds.ImpossibleCase -> + let sigma = + if not (Evd.is_defined sigma evk) then + let sigma, default = use_unit_judge pb.env sigma in + let sigma = Evd.define evk default.uj_type sigma in + sigma + else sigma + in + sigma, add_assert_false_case pb tomatch + | _ -> + sigma, submat + end + | _ -> + sigma, submat + +(*****************************************************************************) +(* Let pred = PI [X;x:I(X)]. PI tms. P be a typing predicate for the *) +(* following pattern-matching problem: *) +(* *) +(* Gamma |- match Pushed(c:I(V)) as x in I(X), tms return pred with...end *) +(* *) +(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) +(* is considered. Assume each Ti is some Ii(argsi) with Ti:PI Ui. sort_i *) +(* We let subst = X:=realargsi;x:=Ci(x1,...,xn) and replace pred by *) +(* *) +(* pred' = PI [X1:Ui;x1:I1(X1)]...[Xn:Un;xn:In(Xn)]. (PI tms. P)[subst] *) +(* *) +(* s.t. the following well-typed sub-pattern-matching problem is obtained *) +(* *) +(* Gamma,x'1..x'n |- *) +(* match *) +(* Pushed(x'1) as x1 in I(X1), *) +(* .., *) +(* Pushed(x'n) as xn in I(Xn), *) +(* tms *) +(* return pred' *) +(* with .. end *) +(* *) +(*****************************************************************************) +let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = + (* Assume some gamma st: gamma |- PI [X,x:I(X)]. PI tms. ccl *) + let nrealargs = List.length names in + let l = match depna with Anonymous -> 0 | Name _ -> 1 in + let k = nrealargs + l in + (* We adjust pred st: gamma, x1..xn |- PI [X,x:I(X)]. PI tms. ccl' *) + (* so that x can later be instantiated by Ci(x1..xn) *) + (* and X by the realargs for Ci *) + let n = cs.cs_nargs in + let ccl' = liftn_predicate n (k+1) ccl tms in + (* We prepare the substitution of X and x:I(X) *) + let realargsi = + if not (Int.equal nrealargs 0) then + CVars.subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs) + else + [] in + let realargsi = List.map EConstr.of_constr realargsi in + let copti = match depna with + | Anonymous -> None + | Name _ -> Some (EConstr.of_constr (build_dependent_constructor cs)) + in + (* The substituends realargsi, copti are all defined in gamma, x1...xn *) + (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *) + (* Note: applying the substitution in tms is not important (is it sure?) *) + let ccl'' = + whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in + (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *) + let ccl''' = liftn_predicate n (n+1) ccl'' tms in + (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) + snd (List.fold_left (expand_arg tms) (1,ccl''') newtomatchs) + +let find_predicate loc env sigma p current (IndType (indf,realargs)) dep tms = + let pred = abstract_predicate env sigma indf current realargs dep tms p in + (pred, whd_betaiota sigma + (applist (pred, realargs@[current]))) + +(* Take into account that a type has been discovered to be inductive, leading + to more dependencies in the predicate if the type has indices *) +let adjust_predicate_from_tomatch tomatch (current,typ as ct) pb = + let ((_,oldtyp),deps,na) = tomatch in + match typ, oldtyp with + | IsInd (_,_,names), NotInd _ -> + let k = match na with + | Anonymous -> 1 + | Name _ -> 2 + in + let n = List.length names in + { pb with pred = liftn_predicate n k pb.pred pb.tomatch }, + (ct,List.map (fun i -> if i >= k then i+n else i) deps,na) + | _ -> + pb, (ct,deps,na) + +(* Remove commutative cuts that turn out to be non-dependent after + some evars have been instantiated *) + +let rec ungeneralize sigma n ng body = + match EConstr.kind sigma body with + | Lambda (_,_,c) when Int.equal ng 0 -> + subst1 (mkRel n) c + | Lambda (na,t,c) -> + (* We traverse an inner generalization *) + mkLambda (na,t,ungeneralize sigma (n+1) (ng-1) c) + | LetIn (na,b,t,c) -> + (* We traverse an alias *) + mkLetIn (na,b,t,ungeneralize sigma (n+1) ng c) + | Case (ci,p,c,brs) -> + (* We traverse a split *) + let p = + let sign,p = decompose_lam_assum sigma p in + let sign2,p = decompose_prod_n_assum sigma ng p in + let p = prod_applist sigma p [mkRel (n+List.length sign+ng)] in + it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in + mkCase (ci,p,c,Array.map2 (fun q c -> + let sign,b = decompose_lam_n_decls sigma q c in + it_mkLambda_or_LetIn (ungeneralize sigma (n+q) ng b) sign) + ci.ci_cstr_ndecls brs) + | App (f,args) -> + (* We traverse an inner generalization *) + assert (isCase sigma f); + mkApp (ungeneralize sigma n (ng+Array.length args) f,args) + | _ -> assert false + +let ungeneralize_branch sigma n k (sign,body) cs = + (sign,ungeneralize sigma (n+cs.cs_nargs) k body) + +let rec is_dependent_generalization sigma ng body = + match EConstr.kind sigma body with + | Lambda (_,_,c) when Int.equal ng 0 -> + not (noccurn sigma 1 c) + | Lambda (na,t,c) -> + (* We traverse an inner generalization *) + is_dependent_generalization sigma (ng-1) c + | LetIn (na,b,t,c) -> + (* We traverse an alias *) + is_dependent_generalization sigma ng c + | Case (ci,p,c,brs) -> + (* We traverse a split *) + Array.exists2 (fun q c -> + let _,b = decompose_lam_n_decls sigma q c in + is_dependent_generalization sigma ng b) + ci.ci_cstr_ndecls brs + | App (g,args) -> + (* We traverse an inner generalization *) + assert (isCase sigma g); + is_dependent_generalization sigma (ng+Array.length args) g + | _ -> assert false + +let is_dependent_branch sigma k (_,br) = + is_dependent_generalization sigma k br + +let postprocess_dependencies evd tocheck brs tomatch pred deps cs = + let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with + | [], _ -> brs,tomatch,pred,[] + | n::deps, Abstract (i,d) :: tomatch -> + let d = map_constr (fun c -> nf_evar evd c) d in + let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in + if is_d || List.exists (fun c -> dependent_decl evd (lift k c) d) tocheck + && Array.exists (is_dependent_branch evd k) brs then + (* Dependency in the current term to match and its dependencies is real *) + let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in + let inst = match d with + | LocalAssum _ -> mkRel n :: inst + | _ -> inst + in + brs, Abstract (i,d) :: tomatch, pred, inst + else + (* Finally, no dependency remains, so, we can replace the generalized *) + (* terms by its actual value in both the remaining terms to match and *) + (* the bodies of the Case *) + let pred = lift_predicate (-1) pred tomatch in + let tomatch = relocate_index_tomatch evd 1 (n+1) tomatch in + let tomatch = lift_tomatch_stack (-1) tomatch in + let brs = Array.map2 (ungeneralize_branch evd n k) brs cs in + aux k brs tomatch pred tocheck deps + | _ -> assert false + in aux 0 brs tomatch pred tocheck deps + +(************************************************************************) +(* Sorting equations by constructor *) + +let rec irrefutable env pat = match DAst.get pat with + | 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 = Int.equal (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 ind current cstrs mat = + let mat = + if first_clause_irrefutable !!(pb.env) mat then [List.hd mat] else mat in + let brs = Array.make (Array.length cstrs) [] in + let only_default = ref None 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 DAst.get (check_and_adjust_constructor !!(pb.env) ind 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 + brs.(i-1) <- (args, name, rest) :: brs.(i-1) + done; + if !only_default == None then only_default := Some true + | PatCstr (((_,i)),args,name) -> + (* This is a regular clause *) + only_default := Some false; + brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in + (brs,Option.default false !only_default) + +(************************************************************************) +(* Here starts the pattern-matching compilation algorithm *) + +(* Abstracting over dependent subterms to match *) +let rec generalize_problem names sigma pb = function + | [] -> pb, [] + | i::l -> + let pb',deps = generalize_problem names sigma pb l in + let d = map_constr (lift i) (lookup_rel i !!(pb.env)) in + begin match d with + | LocalDef ({binder_name=Anonymous},_,_) -> pb', deps + | _ -> + (* for better rendering *) + let d = RelDecl.map_type (fun c -> whd_betaiota sigma c) d in + let tomatch = lift_tomatch_stack 1 pb'.tomatch in + let tomatch = relocate_index_tomatch sigma (i+1) 1 tomatch in + { pb' with + tomatch = Abstract (i,d) :: tomatch; + pred = generalize_predicate sigma names i d pb'.tomatch pb'.pred }, + i::deps + end + +(* No more patterns: typing the right-hand side of equations *) +let build_leaf sigma pb = + let rhs = extract_rhs pb in + let sigma, j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env sigma rhs.it in + sigma, j_nf_evar sigma j + +(* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *) +(* spiwack: the [initial] argument keeps track whether the branch is a + toplevel branch ([true]) or a deep one ([false]). *) +let build_branch ~program_mode initial current realargs deps (realnames,curname) sigma pb arsign eqns const_info = + (* We remember that we descend through constructor C *) + let history = + push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in + + (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *) + (* build the name x1..xn from the names present in the equations *) + (* that had matched constructor C *) + let cs_args = const_info.cs_args in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs_args in + let names,aliasname = get_names (GlobEnv.vars_of_env pb.env) !!(pb.env) sigma cs_args eqns in + let typs = List.map2 RelDecl.set_name names cs_args + in + + (* Beta-iota-normalize types to better compatibility of refine with 8.4 behavior *) + (* This is a bit too strong I think, in the sense that what we would *) + (* really like is to have beta-iota reduction only at the positions where *) + (* parameters are substituted *) + let typs = List.map (map_type (nf_betaiota !!(pb.env) sigma)) typs in + + (* We build the matrix obtained by expanding the matching on *) + (* "C x1..xn as x" followed by a residual matching on eqn into *) + (* a matching on "x1 .. xn eqn" *) + let submat = List.map (fun (tms,_,eqn) -> prepend_pattern tms eqn) eqns in + + (* We adjust the terms to match in the context they will be once the *) + (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) + let typs' = + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in + + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let typs,extenv = push_rel_context ~hypnaming sigma typs pb.env in + + let typs' = + List.map (fun (c,d) -> + (c,extract_inductive_data !!extenv sigma d,d)) typs' in + + (* We compute over which of x(i+1)..xn and x matching on xi will need a *) + (* generalization *) + let dep_sign = + find_dependencies_signature sigma + (dependencies_in_rhs ~program_mode sigma const_info.cs_nargs current pb.tomatch 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 = EConstr.of_constr (build_dependent_constructor const_info) in + + (* Current context Gamma has the form Gamma1;cur:I(realargs);Gamma2 *) + (* We go from Gamma |- PI tms. pred to *) + (* Gamma;x1..xn;curalias:I(x1..xn) |- PI tms'. pred' *) + (* where, in tms and pred, those realargs that are vars are *) + (* replaced by the corresponding xi and cur replaced by curalias *) + let cirealargs = Array.map_to_list EConstr.of_constr const_info.cs_concl_realargs in + + (* Do the specialization for terms to match *) + let tomatch = List.fold_right2 (fun par arg tomatch -> + match EConstr.kind sigma par with + | Rel i -> replace_tomatch sigma (i+const_info.cs_nargs) arg tomatch + | _ -> tomatch) (current::realargs) (ci::cirealargs) + (lift_tomatch_stack const_info.cs_nargs pb.tomatch) in + + let pred_is_not_dep = + noccur_predicate_between sigma 1 (List.length realnames + 1) pb.pred tomatch in + + let typs' = + List.map2 + (fun (tm, (tmtyp,_), decl) deps -> + let na = RelDecl.get_name decl in + let na = match curname, na with + | Name _, Anonymous -> curname + | Name _, Name _ -> na + | Anonymous, _ -> + if List.is_empty deps && pred_is_not_dep then Anonymous else force_name na in + ((tm,tmtyp),deps,na)) + typs' (List.rev dep_sign) in + + (* Do the specialization for the predicate *) + let pred = + specialize_predicate typs' (realnames,curname) arsign const_info tomatch pb.pred in + + let currents = List.map (fun x -> Pushed (false,x)) typs' in + + let alias = match aliasname with + | Anonymous -> + NonDepAlias + | Name _ -> + let cur_alias = lift const_info.cs_nargs current in + let ind = + mkApp ( + applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), EInstance.make (snd const_info.cs_cstr)), + List.map (EConstr.of_constr %> lift const_info.cs_nargs) const_info.cs_params), + Array.map EConstr.of_constr const_info.cs_concl_realargs) in + Alias (initial,(aliasname,cur_alias,(ci,ind))) in + + let tomatch = List.rev_append (alias :: currents) tomatch in + + let sigma, submat = adjust_impossible_cases sigma pb pred tomatch submat in + let () = match submat with + | [] -> + raise_pattern_matching_error (!!(pb.env), Evd.empty, NonExhaustive (complete_history history)) + | _ -> () + in + + sigma, typs, + { pb with + env = extenv; + tomatch = tomatch; + pred = pred; + history = history; + mat = List.map (push_rels_eqn_with_names ~hypnaming sigma typs) submat } + +(********************************************************************** + INVARIANT: + + pb = { env, pred, tomatch, mat, ...} + tomatch = list of Pushed (c:T), Abstract (na:T), Alias (c:T) or NonDepAlias + + all terms and types in Pushed, Abstract and Alias are relative to env + enriched by the Abstract coming before + +*) + +(**********************************************************************) +(* Main compiling descent *) +let compile ~program_mode sigma pb = + let rec compile sigma pb = + match pb.tomatch with + | Pushed cur :: rest -> match_current sigma { pb with tomatch = rest } cur + | Alias (initial,x) :: rest -> compile_alias initial sigma pb x rest + | NonDepAlias :: rest -> compile_non_dep_alias sigma pb rest + | Abstract (i,d) :: rest -> compile_generalization sigma pb i d rest + | [] -> build_leaf sigma pb + +(* Case splitting *) + and match_current sigma pb (initial,tomatch) = + let sigma, tm = adjust_tomatch_to_pattern ~program_mode sigma pb tomatch in + let pb,tomatch = adjust_predicate_from_tomatch tomatch tm pb in + let ((current,typ),deps,dep) = tomatch in + match typ with + | NotInd (_,typ) -> + check_all_variables !!(pb.env) sigma typ pb.mat; + compile_all_variables initial tomatch sigma pb + | IsInd (_,(IndType(indf,realargs) as indt),names) -> + let mind,_ = dest_ind_family indf in + let mind = Tacred.check_privacy !!(pb.env) mind in + let cstrs = get_constructors !!(pb.env) indf in + let arsign, _ = get_arity !!(pb.env) indf in + let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in + let no_cstr = Int.equal (Array.length cstrs) 0 in + if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then + compile_all_variables initial tomatch sigma pb + else + (* We generalize over terms depending on current term to match *) + let pb,deps = generalize_problem (names,dep) sigma pb deps in + + (* We compile branches *) + let fold_br sigma eqn cstr = + compile_branch initial current realargs (names,dep) deps sigma pb arsign eqn cstr + in + let sigma, brvals = Array.fold_left2_map fold_br sigma eqns cstrs in + (* We build the (elementary) case analysis *) + let depstocheck = current::binding_vars_of_inductive sigma typ in + let brvals,tomatch,pred,inst = + postprocess_dependencies sigma depstocheck + brvals pb.tomatch pb.pred deps cstrs in + let brvals = Array.map (fun (sign,body) -> + it_mkLambda_or_LetIn body sign) brvals in + let (pred,typ) = + find_predicate pb.caseloc pb.env sigma + pred current indt (names,dep) tomatch + in + let rci = Typing.check_allowed_sort !!(pb.env) sigma mind current pred in + let ci = make_case_info !!(pb.env) (fst mind) rci pb.casestyle in + let pred = nf_betaiota !!(pb.env) sigma pred in + let case = make_case_or_project !!(pb.env) sigma indf ci pred current brvals in + let sigma, _ = Typing.type_of !!(pb.env) sigma pred in + sigma, { uj_val = applist (case, inst); + uj_type = prod_applist sigma typ inst } + + + (* Building the sub-problem when all patterns are variables. Case + where [current] is an intially pushed term. *) + and shift_problem ((current,t),_,na) sigma pb = + let ty = type_of_tomatch t in + let tomatch = lift_tomatch_stack 1 pb.tomatch in + let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in + let env = Name.fold_left (fun env id -> hide_variable env Anonymous id) pb.env na in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let pb = + { pb with + env = snd (push_rel ~hypnaming sigma (LocalDef (annotR na,current,ty)) env); + tomatch = tomatch; + pred = lift_predicate 1 pred tomatch; + history = pop_history pb.history; + mat = List.map (push_current_pattern ~program_mode sigma (current,ty)) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = subst1 current j.uj_val; + uj_type = subst1 current j.uj_type } + + (* Building the sub-problem when all patterns are variables, + non-initial case. Variables which appear as subterms of constructor + are already introduced in the context, we avoid creating aliases to + themselves by treating this case specially. *) + and pop_problem ((current,t),_,na) sigma pb = + let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in + let pb = + { pb with + pred = pred; + history = pop_history pb.history; + mat = List.map push_noalias_current_pattern pb.mat } in + compile sigma pb + + (* Building the sub-problem when all patterns are variables. *) + and compile_all_variables initial cur sigma pb = + if initial then shift_problem cur sigma pb + else pop_problem cur sigma pb + + (* Building the sub-problem when all patterns are variables *) + and compile_branch initial current realargs names deps sigma pb arsign eqns cstr = + let sigma, sign, pb = build_branch ~program_mode initial current realargs deps names sigma pb arsign eqns cstr in + let sigma, j = compile sigma pb in + sigma, (sign, j.uj_val) + + (* Abstract over a declaration before continuing splitting *) + and compile_generalization sigma pb i d rest = + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let pb = + { pb with + env = snd (push_rel ~hypnaming sigma d pb.env); + tomatch = rest; + mat = List.map (push_generalized_decl_eqn ~hypnaming pb.env sigma i d) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = mkLambda_or_LetIn d j.uj_val; + uj_type = mkProd_wo_LetIn d j.uj_type } + + (* spiwack: the [initial] argument keeps track whether the alias has + been introduced by a toplevel branch ([true]) or a deep one + ([false]). *) + and compile_alias initial sigma pb (na,orig,(expanded,expanded_typ)) rest = + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let f c t = + let r = Retyping.relevance_of_type !!(pb.env) sigma t in + let alias = LocalDef (make_annot na r,c,t) in + let pb = + { pb with + env = snd (push_rel ~hypnaming sigma alias pb.env); + tomatch = lift_tomatch_stack 1 rest; + pred = lift_predicate 1 pb.pred pb.tomatch; + history = pop_history_pattern pb.history; + mat = List.map (push_alias_eqn ~hypnaming sigma alias) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = + if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then + subst1 c j.uj_val + else + mkLetIn (make_annot na r,c,t,j.uj_val); + uj_type = subst1 c j.uj_type } in + (* spiwack: when an alias appears on a deep branch, its non-expanded + form is automatically a variable of the same name. We avoid + introducing such superfluous aliases so that refines are elegant. *) + let just_pop sigma = + let pb = + { pb with + tomatch = rest; + history = pop_history_pattern pb.history; + mat = List.map drop_alias_eqn pb.mat } in + compile sigma pb + in + (* If the "match" was orginally over a variable, as in "match x with + O => true | n => n end", we give preference to non-expansion in + the default clause (i.e. "match x with O => true | n => n end" + rather than "match x with O => true | S p => S p end"; + computationally, this avoids reallocating constructors in cbv + evaluation; the drawback is that it might duplicate the instances + of the term to match when the corresponding variable is + substituted by a non-evaluated expression *) + if not program_mode && (isRel sigma orig || isVar sigma orig) then + (* Try to compile first using non expanded alias *) + try + if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) + else just_pop sigma + with e when precatchable_exception e -> + (* Try then to compile using expanded alias *) + (* Could be needed in case of dependent return clause *) + f expanded expanded_typ + else + (* Try to compile first using expanded alias *) + try f expanded expanded_typ + with e when precatchable_exception e -> + (* Try then to compile using non expanded alias *) + (* Could be needed in case of a recursive call which requires to + be on a variable for size reasons *) + if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) + else just_pop sigma + + + (* Remember that a non-trivial pattern has been consumed *) + and compile_non_dep_alias sigma pb rest = + let pb = + { pb with + tomatch = rest; + history = pop_history_pattern pb.history; + mat = List.map drop_alias_eqn pb.mat } in + compile sigma pb + in + compile sigma pb + +(* 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 *) + +(* builds the matrix of equations testing that each eqn has n patterns + * and linearizing the _ patterns. + * Syntactic correctness has already been done in constrintern *) +let matx_of_eqns env eqns = + let build_eqn {CAst.loc;v=(ids,initial_lpat,initial_rhs)} = + let avoid = ids_of_named_context_val (named_context_val !!env) in + let avoid = List.fold_left (fun accu id -> Id.Set.add id accu) avoid ids in + let rhs = + { rhs_env = env; + rhs_vars = free_glob_vars initial_rhs; + avoid_ids = avoid; + it = Some initial_rhs } in + { patterns = initial_lpat; + alias_stack = []; + eqn_loc = loc; + used = ref false; + rhs = rhs } + in List.map build_eqn eqns + +(***************** Building an inversion predicate ************************) + +(* Let "match t1 in I1 u11..u1n_1 ... tm in Im um1..umn_m with ... end : T" + be a pattern-matching problem. We assume that each uij can be + decomposed under the form pij(vij1..vijq_ij) where pij(aij1..aijq_ij) + is a pattern depending on some variables aijk and the vijk are + instances of these variables. We also assume that each ti has the + form of a pattern qi(wi1..wiq_i) where qi(bi1..biq_i) is a pattern + depending on some variables bik and the wik are instances of these + variables (in practice, there is no reason that ti is already + constructed and the qi will be degenerated). + + We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that + T = U(..v1jk..t1 .. ..vmjk..tm). This a higher-order matching + problem with a priori different solutions (one of them if T itself!). + + We finally invert the uij and the ti and build the return clause + + phi(x11..x1n_1y1..xm1..xmn_mym) = + match x11..x1n_1 y1 .. xm1..xmn_m ym with + | p11..p1n_1 q1 .. pm1..pmn_m qm => U(..a1jk..b1 .. ..amjk..bm) + | _ .. _ _ .. _ .. _ _ => True + end + + so that "phi(u11..u1n_1t1..um1..umn_mtm) = T" (note that the clause + returning True never happens and any inhabited type can be put instead). +*) + +let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = + let n = Context.Rel.length (rel_context !!env) in + let n' = Context.Rel.length (rel_context !!extenv) in + (* We first remove the bindings that are dependently typed (they are + difficult to manage and it is not sure these are so useful in practice); + Notes: + - [subst] is made of pairs [(id,u)] where id is a name in [extenv] and + [u] a term typed in [env]; + - [subst0] is made of items [(p,u,(u,ty))] where [ty] is the type of [u] + and both are adjusted to [extenv] while [p] is the index of [id] in + [extenv] (after expansion of the aliases) *) + let map (x, u) = + (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *) + (* \--env-/ (= x:ty) *) + (* \--------------extenv------------/ *) + let (p, _, _) = lookup_rel_id x (rel_context !!extenv) in + let rec traverse_local_defs p = + match lookup_rel p !!extenv with + | LocalDef (_,c,_) -> assert (isRel sigma c); traverse_local_defs (p + destRel sigma c) + | LocalAssum _ -> p in + let p = traverse_local_defs p in + let u = lift (n' - n) u in + try Some (p, u, expand_vars_in_term !!extenv sigma u) + (* pedrot: does this really happen to raise [Failure _]? *) + with Failure _ -> None in + let subst0 = List.map_filter map subst in + let t0 = lift (n' - n) t in + (subst0, t0) + +let push_binder sigma d (k,env,subst) = + (k+1,snd (push_rel ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma d env),List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) + +let rec list_assoc_in_triple x = function + [] -> raise Not_found + | (a, b, _)::l -> if Int.equal a x then b else list_assoc_in_triple x l + +(* Let vijk and ti be a set of dependent terms and T a type, all + * defined in some environment env. The vijk and ti are supposed to be + * instances for variables aijk and bi. + * + * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm) + * defined in some extended context + * "Gamma0, ..a1jk:V1jk.. b1:W1 .. ..amjk:Vmjk.. bm:Wm" + * such that env |- T = U(..v1jk..t1 .. ..vmjk..tm). To not commit to + * a particular solution, we replace each subterm t in T that unifies with + * a subset u1..ul of the vijk and ti by a special evar + * ?id(x=t;c1:=c1,..,cl=cl) defined in context Gamma0,x,c1,...,cl |- ?id + * (where the c1..cl are the aijk and bi matching the u1..ul), and + * similarly for each ti. +*) + +let abstract_tycon ?loc env sigma subst tycon extenv t = + let t = nf_betaiota !!env sigma t in (* it helps in some cases to remove K-redex*) + let src = match EConstr.kind sigma t with + | Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar (None,evk)) + | _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in + let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv sigma subst t in + (* We traverse the type T of the original problem Xi looking for subterms + that match the non-constructor part of the constraints (this part + is in subst); these subterms are the "good" subterms and we replace them + by an evar that may depend (and only depend) on the corresponding + convertible subterms of the substitution *) + let evdref = ref sigma in + let rec aux (k,env,subst as x) t = + (* Use a reference because the [map_constr_with_full_binders] does not + allow threading a state. *) + let sigma = !evdref in + match EConstr.kind sigma t with + | Rel n when is_local_def (lookup_rel n !!env) -> t + | Evar ev -> + let ty = get_type_of !!env sigma t in + let sigma, ty = refresh_universes (Some false) !!env sigma ty in + let inst = + List.map_i + (fun i _ -> + try list_assoc_in_triple i subst0 with Not_found -> mkRel i) + 1 (rel_context !!env) in + let sigma, ev' = Evarutil.new_evar ~src ~typeclass_candidate:false !!env sigma ty in + begin + let flags = (default_flags_of TransparentState.full) in + match solve_simple_eqn evar_unify flags !!env sigma (None,ev,substl inst ev') with + | Success evd -> evdref := evd + | UnifFailure _ -> assert false + end; + ev' + | _ -> + let good = List.filter (fun (_,u,_) -> is_conv_leq !!env sigma t u) subst in + match good with + | [] -> + map_constr_with_full_binders sigma (push_binder sigma) aux x t + | (_, _, u) :: _ -> (* u is in extenv *) + let vl = List.map pi1 good in + let ty = + let ty = get_type_of !!env sigma t in + let sigma, res = refresh_universes (Some false) !!env !evdref ty in + evdref := sigma; res + in + let dummy_subst = List.init k (fun _ -> mkProp) in + let ty = substl dummy_subst (aux x ty) in + let sigma = !evdref in + let depvl = free_rels sigma ty in + let inst = + List.map_i + (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 + (rel_context !!extenv) in + let map a = match EConstr.kind sigma a with + | Rel n -> not (noccurn sigma n u) || Int.Set.mem n depvl + | _ -> true + in + let rel_filter = List.map map inst in + let named_filter = + List.map (fun d -> local_occur_var sigma (NamedDecl.get_id d) u) + (named_context !!extenv) in + let filter = Filter.make (rel_filter @ named_filter) in + let candidates = List.rev (u :: List.map mkRel vl) in + let sigma, ev = Evarutil.new_evar !!extenv ~src ~filter ~candidates ~typeclass_candidate:false sigma ty in + let () = evdref := sigma in + lift k ev + in + let ans = aux (0,extenv,subst0) t0 in + !evdref, ans + +let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = + let sigma, t, tt = match t with + | None -> + (* This is the situation we are building a return predicate and + we are in an impossible branch *) + let n = Context.Rel.length (rel_context !!env) in + let n' = Context.Rel.length (rel_context !!tycon_env) in + let sigma, (impossible_case_type, u) = + Evarutil.new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) + sigma univ_flexible_alg + in + (sigma, lift (n'-n) impossible_case_type, mkSort u) + | Some t -> + let sigma, t = abstract_tycon ?loc tycon_env sigma subst tycon extenv t in + let sigma, tt = Typing.type_of !!extenv sigma t in + (sigma, t, tt) in + match unify_leq_delay !!env sigma tt (mkSort s) with + | exception Evarconv.UnableToUnify _ -> anomaly (Pp.str "Build_tycon: should be a type."); + | sigma -> + sigma, { uj_val = t; uj_type = tt } + +(* For a multiple pattern-matching problem Xi on t1..tn with return + * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return + * predicate for Xi that is itself made by an auxiliary + * pattern-matching problem of which the first clause reveals the + * pattern structure of the constraints on the inductive types of the t1..tn, + * and the second clause is a wildcard clause for catching the + * impossible cases. See above "Building an inversion predicate" for + * further explanations + *) + +let build_inversion_problem ~program_mode loc env sigma tms t = + let make_patvar t (subst,avoid) = + let id = next_name_away (named_hd !!env sigma t Anonymous) avoid in + DAst.make @@ PatVar (Name id), ((id,t)::subst, Id.Set.add id avoid) in + let rec reveal_pattern t (subst,avoid as acc) = + match EConstr.kind sigma (whd_all !!env sigma t) with + | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc + | App (f,v) when isConstruct sigma f -> + let cstr,u = destConstruct sigma f in + let n = constructor_nrealargs !!env cstr in + let l = List.lastn n (Array.to_list v) in + let l,acc = List.fold_right_map reveal_pattern l acc in + DAst.make (PatCstr (cstr,l,Anonymous)), acc + | _ -> make_patvar t acc in + let rec aux n env acc_sign tms acc = + match tms with + | [] -> [], acc_sign, acc + | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> + let patl,acc = List.fold_right_map reveal_pattern realargs acc in + let pat,acc = make_patvar t acc in + let indf' = lift_inductive_family n indf in + let sign = make_arity_signature !!env sigma true indf' in + let patl = pat :: List.rev patl in + let patl,sign = recover_and_adjust_alias_names acc patl sign in + let p = List.length patl in + let _,env' = push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma sign env in + let patl',acc_sign,acc = aux (n+p) env' (sign@acc_sign) tms acc in + List.rev_append patl patl',acc_sign,acc + | (t, NotInd (bo,typ)) :: tms -> + let pat,acc = make_patvar t acc in + let d = LocalAssum (annotR (alias_of_pat pat),typ) in + let patl,acc_sign,acc = aux (n+1) (snd (push_rel ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma d env)) (d::acc_sign) tms acc in + pat::patl,acc_sign,acc in + let avoid0 = GlobEnv.vars_of_env env in + (* [patl] is a list of patterns revealing the substructure of + constructors present in the constraints on the type of the + multiple terms t1..tn that are matched in the original problem; + [subst] is the substitution of the free pattern variables in + [patl] that returns the non-constructor parts of the constraints. + Especially, if the ti has type I ui1..uin_i, and the patterns associated + to ti are pi1..pin_i, then subst(pij) is uij; the substitution is + useful to recognize which subterms of the whole type T of the original + problem have to be abstracted *) + let patl,sign,(subst,avoid) = aux 0 env [] tms ([],avoid0) in + let n = List.length sign in + + let decls = + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in + + let _,pb_env = push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma sign env in + let decls = + List.map (fun (c,d) -> (c,extract_inductive_data !!(pb_env) sigma d,d)) decls in + + let decls = List.rev decls in + let dep_sign = find_dependencies_signature sigma (List.make n true) decls in + + let sub_tms = + List.map2 (fun deps (tm, (tmtyp,_), decl) -> + let na = if List.is_empty deps then Anonymous else force_name (RelDecl.get_name decl) in + Pushed (true,((tm,tmtyp),deps,na))) + dep_sign decls in + let subst = List.map (fun (na,t) -> (na,lift n t)) subst in + (* [main_eqn] is the main clause of the auxiliary pattern-matching that + serves as skeleton for the return type: [patl] is the + substructure of constructors extracted from the list of + constraints on the inductive types of the multiple terms matched + in the original pattern-matching problem Xi *) + let main_eqn = + { patterns = patl; + alias_stack = []; + eqn_loc = None; + used = ref false; + rhs = { rhs_env = pb_env; + (* we assume all vars are used; in practice we discard dependent + vars so that the field rhs_vars is normally not used *) + rhs_vars = List.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty subst; + avoid_ids = avoid; + it = Some (lift n t) } } in + (* [catch_all] is a catch-all default clause of the auxiliary + pattern-matching, if needed: it will catch the clauses + of the original pattern-matching problem Xi whose type + constraints are incompatible with the constraints on the + inductive types of the multiple terms matched in Xi *) + let catch_all_eqn = + if List.for_all (irrefutable !!env) patl then + (* No need for a catch all clause *) + [] + else + [ { patterns = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl; + alias_stack = []; + eqn_loc = None; + used = ref false; + rhs = { rhs_env = pb_env; + rhs_vars = Id.Set.empty; + avoid_ids = avoid0; + it = None } } ] in + (* [pb] is the auxiliary pattern-matching serving as skeleton for the + return type of the original problem Xi *) + let s' = Retyping.get_sort_of !!env sigma t in + let sigma, s = Evd.new_sort_variable univ_flexible sigma in + let sigma = Evd.set_leq_sort !!env sigma s' s in + let pb = + { env = pb_env; + pred = (*ty *) mkSort s; + tomatch = sub_tms; + history = start_history n; + mat = main_eqn :: catch_all_eqn; + caseloc = loc; + casestyle = RegularStyle; + typing_function = build_tycon ?loc env pb_env s subst} in + let sigma, j = compile ~program_mode sigma pb in + (sigma, j.uj_val) + +(* Here, [pred] is assumed to be in the context built from all *) +(* realargs and terms to match *) +let build_initial_predicate arsign pred = + let rec buildrec pred tmnames = function + | [] -> List.rev tmnames,pred + | (decl::realdecls)::lnames -> + let na = RelDecl.get_name decl in + let realnames = List.map RelDecl.get_name realdecls in + buildrec pred ((force_name na,realnames)::tmnames) lnames + | _ -> assert false + in buildrec pred [] (List.rev arsign) + +let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = + let lift = if dolift then lift else fun n t -> t in + let get_one_sign n tm (na,t) = + match tm with + | NotInd (bo,typ) -> + (match t with + | None -> + let r = Sorts.Relevant in (* TODO relevance *) + let sign = match bo with + | None -> [LocalAssum (make_annot na r, lift n typ)] + | Some b -> [LocalDef (make_annot na r, lift n b, lift n typ)] in sign + | Some {CAst.loc} -> + user_err ?loc + (str"Unexpected type annotation for a term of non inductive type.")) + | IsInd (term,IndType(indf,realargs),_) -> + let indf' = if dolift then lift_inductive_family n indf else indf in + let ((ind,u),_) = dest_ind_family indf' in + let nrealargs_ctxt = inductive_nrealdecls env0 ind in + let arsign, inds = get_arity env0 indf' in + let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in + let realnal = + match t with + | Some {CAst.loc;v=(ind',realnal)} -> + if not (eq_ind ind ind') then + user_err ?loc (str "Wrong inductive type."); + if not (Int.equal nrealargs_ctxt (List.length realnal)) then + anomaly (Pp.str "Ill-formed 'in' clause in cases."); + List.rev realnal + | None -> + List.make nrealargs_ctxt Anonymous in + let r = Sorts.relevance_of_sort_family inds in + let t = EConstr.of_constr (build_dependent_inductive env0 indf') in + LocalAssum (make_annot na r, t) :: List.map2 RelDecl.set_name realnal arsign in + let rec buildrec n = function + | [],[] -> [] + | (_,tm)::ltm, (_,x)::tmsign -> + let l = get_one_sign n tm x in + l :: buildrec (n + List.length l) (ltm,tmsign) + | _ -> assert false + in List.rev (buildrec 0 (tomatchl,tmsign)) + +let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon = + match tycon with + | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma + ~flags:(default_flags_of TransparentState.full) j p + | None -> sigma, j + +(* We put the tycon inside the arity signature, possibly discovering dependencies. *) + +let add_subst sigma c len (rel_subst,var_subst) = + match EConstr.kind sigma c with + | Rel n -> (n,len) :: rel_subst, var_subst + | Var id -> rel_subst, (id,len) :: var_subst + | _ -> assert false + +let dependent_rel_or_var sigma tm c = + match EConstr.kind sigma tm with + | Rel n -> not (noccurn sigma n c) + | Var id -> Termops.local_occur_var sigma id c + | _ -> assert false + +let prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs arsign c = + let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in + let (rel_subst,var_subst), len = + List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> + let signlen = List.length sign in + match EConstr.kind sigma tm with + | Rel _ | Var _ when Int.equal signlen 1 && dependent_rel_or_var sigma tm c + (* The term to match is not of a dependent type itself *) -> + (add_subst sigma tm len subst, len - signlen) + | Rel _ | Var _ when signlen > 1 (* The term is of a dependent type, + maybe some variable in its type appears in the tycon. *) -> + (match tmtype with + NotInd _ -> (subst, len - signlen) + | IsInd (_, IndType(indf,realargs),_) -> + let subst, len = + List.fold_left + (fun (subst, len) arg -> + match EConstr.kind sigma arg with + | Rel _ | Var _ when dependent_rel_or_var sigma arg c -> + (add_subst sigma arg len subst, pred len) + | _ -> (subst, pred len)) + (subst, len) realargs + in + let subst = + if dependent_rel_or_var sigma tm c && List.for_all (fun c -> isRel sigma c || isVar sigma c) realargs + then add_subst sigma tm len subst else subst + in (subst, pred len)) + | _ -> (subst, len - signlen)) + (List.rev tomatchs) arsign (([],[]), nar) + in + let rec predicate lift c = + match EConstr.kind sigma c with + | Rel n when n > lift -> + (try + (* Make the predicate dependent on the matched variable *) + let idx = Int.List.assoc (n - lift) rel_subst in + mkRel (idx + lift) + with Not_found -> + (* A variable that is not matched, lift over the arsign *) + mkRel (n + nar)) + | Var id -> + (try + (* Make the predicate dependent on the matched variable *) + let idx = Id.List.assoc id var_subst in + mkRel (idx + lift) + with Not_found -> + (* A variable that is not matched *) + c) + | _ -> + EConstr.map_with_binders sigma succ predicate lift c + in + assert (len == 0); + let p = predicate 0 c in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let arsign,env' = List.fold_right_map (push_rel_context ~hypnaming sigma) arsign env in + try let sigma' = fst (Typing.type_of !!env' sigma p) in + Some (sigma', p, arsign) + with e when precatchable_exception e -> None + +(* 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. + + * Each matched term is independently considered dependent or not. + *) + +let prepare_predicate ?loc ~program_mode typing_fun env sigma tomatchs arsign tycon pred = + let refresh_tycon sigma t = + (* If we put the typing constraint in the term, it has to be + refreshed to preserve the invariant that no algebraic universe + can appear in the term. *) + refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true) + !!env sigma t + in + let preds = + match pred with + (* No return clause *) + | None -> + let sigma,t = + match tycon with + | Some t -> refresh_tycon sigma t + | None -> + (* No type constraint: we first create a generic evar type constraint *) + let src = (loc, Evar_kinds.CasesType false) in + let sigma, (t, _) = Evarutil.new_type_evar !!env sigma univ_flexible ~src in + sigma, t in + (* First strategy: we build an "inversion" predicate, also replacing the *) + (* dependencies with existential variables *) + let sigma1,pred1 = build_inversion_problem loc ~program_mode env sigma tomatchs t in + (* Optional second strategy: we abstract the tycon wrt to the dependencies *) + let p2 = + prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs arsign t in + (* Third strategy: we take the type constraint as it is; of course we could *) + (* need something inbetween, abstracting some but not all of the dependencies *) + (* the "inversion" strategy deals with that but unification may not be *) + (* powerful enough so strategy 2 and 3 helps; moreover, inverting does not *) + (* work (yet) when a constructor has a type not precise enough for the inversion *) + (* see log message for details *) + let pred3 = lift (List.length (List.flatten arsign)) t in + (match p2 with + | Some (sigma2,pred2,arsign) when not (EConstr.eq_constr sigma pred2 pred3) -> + [sigma1, pred1, arsign; sigma2, pred2, arsign; sigma, pred3, arsign] + | _ -> + [sigma1, pred1, arsign; sigma, pred3, arsign]) + (* Some type annotation *) + | Some rtntyp -> + (* We extract the signature of the arity *) + let building_arsign,envar = List.fold_right_map (push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma) arsign env in + let sigma, newt = new_sort_variable univ_flexible sigma in + let sigma, predcclj = typing_fun (mk_tycon (mkSort newt)) envar sigma rtntyp in + let predccl = nf_evar sigma predcclj.uj_val in + [sigma, predccl, building_arsign] + in + List.map + (fun (sigma,pred,arsign) -> + let (nal,pred) = build_initial_predicate arsign pred in + sigma,nal,pred) + preds + +(** Program cases *) + +open Program + +let ($) f x = f x + +let string_of_name name = + match name with + | Anonymous -> "anonymous" + | Name n -> Id.to_string n + +let make_prime_id name = + let str = string_of_name name in + Id.of_string str, Id.of_string (str ^ "'") + +let prime avoid name = + let previd, id = make_prime_id name in + previd, next_ident_away id avoid + +let make_prime avoid prevname = + let previd, id = prime !avoid prevname in + avoid := Id.Set.add id !avoid; + previd, id + +let eq_id avoid id = + let hid = Id.of_string ("Heq_" ^ Id.to_string id) in + let hid' = next_ident_away hid avoid in + hid' + +let papp sigma gr args = + let evdref = ref sigma in + let ans = papp evdref gr args in + !evdref, ans + +let mk_eq sigma typ x y = papp sigma coq_eq_ind [| typ; x ; y |] +let mk_eq_refl sigma typ x = papp sigma coq_eq_refl [| typ; x |] +let mk_JMeq sigma typ x typ' y = + papp sigma coq_JMeq_ind [| typ; x ; typ'; y |] +let mk_JMeq_refl sigma typ x = + papp sigma coq_JMeq_refl [| typ; x |] + +let hole na = DAst.make @@ + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation= Evar_kinds.Define false; + Evar_kinds.qm_name=na; + Evar_kinds.qm_record_field=None}, + IntroAnonymous, None) + +let constr_of_pat env sigma arsign pat avoid = + let rec typ env sigma (ty, realargs) pat avoid = + let loc = pat.CAst.loc in + match DAst.get pat with + | PatVar name -> + let name, avoid = match name with + Name n -> name, avoid + | Anonymous -> + let previd, id = prime avoid (Name (Id.of_string "wildcard")) in + Name id, Id.Set.add id avoid + in + let r = Sorts.Relevant in (* TODO relevance *) + (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (make_annot name r, ty)] @ realargs, mkRel 1, ty, + (List.map (fun x -> mkRel 1) realargs), 1, avoid) + | PatCstr (((_, i) as cstr),args,alias) -> + let cind = inductive_of_constructor cstr in + let IndType (indf, _) = + try find_rectype env sigma (lift (-(List.length realargs)) ty) + with Not_found -> error_case_not_inductive env sigma + {uj_val = ty; uj_type = Typing.unsafe_type_of env sigma ty} + in + let (ind,u), params = dest_ind_family indf in + let params = List.map EConstr.of_constr params in + if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind; + let cstrs = get_constructors env indf in + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + assert (Int.equal nb_args_constr (List.length args)); + let sigma, patargs, args, sign, env, n, m, avoid = + List.fold_right2 + (fun decl ua (sigma, patargs, args, sign, env, n, m, avoid) -> + let t = EConstr.of_constr (RelDecl.get_type decl) in + let sigma, pat', sign', arg', typ', argtypargs, n', avoid = + let liftt = liftn (List.length sign) (succ (List.length args)) t in + typ env sigma (substl args liftt, []) ua avoid + in + let args' = arg' :: List.map (lift n') args in + let env' = EConstr.push_rel_context sign' env in + (sigma, pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) + ci.cs_args (List.rev args) (sigma, [], [], [], env, 0, 0, avoid) + in + let args = List.rev args in + let patargs = List.rev patargs in + let pat' = DAst.make ?loc @@ PatCstr (cstr, patargs, alias) in + let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in + let app = applist (cstr, List.map (lift (List.length sign)) params) in + let app = applist (app, args) in + let apptype = Retyping.get_type_of env sigma app in + let IndType (indf, realargs) = find_rectype env sigma apptype in + match alias with + Anonymous -> + sigma, pat', sign, app, apptype, realargs, n, avoid + | Name id -> + let _, inds = get_arity env indf in + let r = Sorts.relevance_of_sort_family inds in + let sign = LocalAssum (make_annot alias r, lift m ty) :: sign in + let avoid = Id.Set.add id avoid in + let sigma, sign, i, avoid = + try + let env = EConstr.push_rel_context sign env in + let sigma = unify_leq_delay (EConstr.push_rel_context sign env) sigma + (lift (succ m) ty) (lift 1 apptype) in + let sigma, eq_t = mk_eq sigma (lift (succ m) ty) + (mkRel 1) (* alias *) + (lift 1 app) (* aliased term *) + in + let neq = eq_id avoid id in + (* if we ever allow using a SProp-typed coq_eq_ind this relevance will be wrong *) + sigma, LocalDef (nameR neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid + with Evarconv.UnableToUnify _ -> sigma, sign, 1, avoid + in + (* Mark the equality as a hole *) + sigma, pat', sign, lift i app, lift i apptype, realargs, n + i, avoid + in + let sigma, pat', sign, patc, patty, args, z, avoid = typ env sigma (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in + sigma, pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid + + +(* shadows functional version *) +let eq_id avoid id = + let hid = Id.of_string ("Heq_" ^ Id.to_string id) in + let hid' = next_ident_away hid !avoid in + avoid := Id.Set.add hid' !avoid; + hid' + +let is_topvar sigma t = +match EConstr.kind sigma t with +| Rel 0 -> true +| _ -> false + +let rels_of_patsign sigma = + List.map (fun decl -> + match decl with + | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) + | _ -> decl) + +let vars_of_ctx sigma ctx = + let _, y = + List.fold_right (fun decl (prev, vars) -> + match decl with + | LocalDef (na,t',t) when is_topvar sigma t' -> + prev, + (DAst.make @@ GApp ( + (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), + [hole na.binder_name; DAst.make @@ GVar prev])) :: vars + | _ -> + match RelDecl.get_name decl with + Anonymous -> invalid_arg "vars_of_ctx" + | Name n -> n, (DAst.make @@ GVar n) :: vars) + ctx (Id.of_string "vars_of_ctx_error", []) + in List.rev y + +let rec is_included x y = + match DAst.get x, DAst.get y with + | PatVar _, _ -> true + | _, PatVar _ -> true + | PatCstr ((_, i), args, alias), PatCstr ((_, i'), args', alias') -> + if Int.equal i i' then List.for_all2 is_included args args' + else false + +let lift_rel_context n l = + map_rel_context_with_binders (liftn n) l + +(* liftsign is the current pattern's complete signature length. + Hence pats is already typed in its + full signature. However prevpatterns are in the original one signature per pattern form. + *) +let build_ineqs sigma prevpatterns pats liftsign = + let sigma, diffs = + List.fold_left + (fun (sigma, c) eqnpats -> + let sigma, acc = List.fold_left2 + (* ppat is the pattern we are discriminating against, curpat is the current one. *) + (fun (sigma, acc) (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) + (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> + match acc with + None -> sigma, None + | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) + if is_included curpat ppat then + (* Length of previous pattern's signature *) + let lens = List.length ppat_sign in + (* Accumulated length of previous pattern's signatures *) + let len' = lens + len in + let sigma, c' = + papp sigma coq_eq_ind + [| lift (len' + liftsign) curpat_ty; + liftn (len + liftsign) (succ lens) ppat_c ; + lift len' curpat_c |] + in + let acc = + ((* Jump over previous prevpat signs *) + lift_rel_context len ppat_sign @ sign, + len', + succ n, (* nth pattern *) + c' :: List.map (lift lens (* Jump over this prevpat signature *)) c) + in sigma, Some acc + else sigma, None) + (sigma, Some ([], 0, 0, [])) eqnpats pats + in match acc with + None -> sigma, c + | Some (sign, len, _, c') -> + let sigma, conj = mk_coq_and sigma c' in + let sigma, neg = mk_coq_not sigma conj in + let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in + sigma, conj :: c) + (sigma, []) prevpatterns + in match diffs with [] -> sigma, None + | _ -> let sigma, conj = mk_coq_and sigma diffs in sigma, Some conj + +let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = + let i = ref 0 in + let (sigma, x, y, z) = + List.fold_left + (fun (sigma, branches, eqns, prevpatterns) eqn -> + let sigma, _, newpatterns, pats = + List.fold_left2 + (fun (sigma, idents, newpatterns, pats) pat arsign -> + let sigma, pat', cpat, idents = constr_of_pat !!env sigma arsign pat idents in + (sigma, idents, pat' :: newpatterns, cpat :: pats)) + (sigma, Id.Set.empty, [], []) eqn.patterns sign + in + let newpatterns = List.rev newpatterns and opats = List.rev pats in + let rhs_rels, pats, signlen = + List.fold_left + (fun (renv, pats, n) (sign,c, (s, args), p) -> + (* Recombine signatures and terms of all of the row's patterns *) + let sign' = lift_rel_context n sign in + let len = List.length sign' in + (sign' @ renv, + (* lift to get outside of previous pattern's signatures. *) + (sign', liftn n (succ len) c, + (s, List.map (liftn n (succ len)) args), p) :: pats, + len + n)) + ([], [], 0) opats in + let pats, _ = List.fold_left + (* lift to get outside of past patterns to get terms in the combined environment. *) + (fun (pats, n) (sign, c, (s, args), p) -> + let len = List.length sign in + ((rels_of_patsign sigma sign, lift n c, + (s, List.map (lift n) args), p) :: pats, len + n)) + ([], 0) pats + in + let sigma, ineqs = build_ineqs sigma prevpatterns pats signlen in + let rhs_rels' = rels_of_patsign sigma rhs_rels in + let _signenv,_ = push_rel_context ~hypnaming:ProgramNaming sigma rhs_rels' env in + let arity = + let args, nargs = + List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> + (args @ c :: allargs, List.length args + succ n)) + pats ([], 0) + in + let args = List.rev args in + substl args (liftn signlen (succ nargs) arity) + in + let r = Sorts.Relevant in (* TODO relevance *) + let rhs_rels', tycon = + let neqs_rels, arity = + match ineqs with + | None -> [], arity + | Some ineqs -> + [LocalAssum (make_annot Anonymous r, ineqs)], lift 1 arity + in + let eqs_rels, arity = decompose_prod_n_assum sigma neqs arity in + eqs_rels @ neqs_rels @ rhs_rels', arity + in + let _,rhs_env = push_rel_context ~hypnaming:ProgramNaming sigma rhs_rels' env in + let sigma, j = typing_fun (mk_tycon tycon) rhs_env sigma eqn.rhs.it in + let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' + and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in + let sigma, _btype = Typing.type_of !!env sigma bbody in + let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in + let branch_decl = LocalDef (make_annot (Name branch_name) r, lift !i bbody, lift !i btype) in + let branch = + let bref = DAst.make @@ GVar branch_name in + match vars_of_ctx sigma rhs_rels with + [] -> bref + | l -> DAst.make @@ GApp (bref, l) + in + let branch = match ineqs with + Some _ -> DAst.make @@ GApp (branch, [ hole Anonymous ]) + | None -> branch + in + incr i; + let rhs = { eqn.rhs with it = Some branch } in + (sigma, branch_decl :: branches, + { eqn with patterns = newpatterns; rhs = rhs } :: eqns, + opats :: prevpatterns)) + (sigma, [], [], []) eqns + in + sigma, x, y + +(* 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. + + * Each matched terms are independently considered dependent or not. + + * A type constraint but no annotation case: it is assumed non dependent. + *) + +let lift_ctx n ctx = + let ctx', _ = + List.fold_right (fun (c, t) (ctx, n') -> + (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') + ctx ([], 0) + in ctx' + +(* Turn matched terms into variables. *) +let abstract_tomatch env sigma tomatchs tycon = + let prev, ctx, names, tycon = + List.fold_left + (fun (prev, ctx, names, tycon) (c, t) -> + let lenctx = List.length ctx in + match EConstr.kind sigma c with + Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon + | _ -> + let tycon = Option.map + (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in + let name = next_ident_away (Id.of_string "filtered_var") names in + let r = Sorts.Relevant in (* TODO relevance *) + (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, + LocalDef (make_annot (Name name) r, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, + Id.Set.add name names, tycon) + ([], [], Id.Set.empty, tycon) tomatchs + in List.rev prev, ctx, tycon + +let build_dependent_signature env sigma avoid tomatchs arsign = + let avoid = ref avoid in + let arsign = List.rev arsign in + let allnames = List.rev_map (List.map RelDecl.get_name) arsign in + let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in + let sigma, eqs, neqs, refls, slift, arsign' = + List.fold_left2 + (fun (sigma, eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> + (* The accumulator: + previous eqs, + number of previous eqs, + lift to get outside eqs and in the introduced variables ('as' and 'in'), + new arity signatures + *) + match ty with + | IsInd (ty, IndType (indf, args), _) when List.length args > 0 -> + (* Build the arity signature following the names in matched terms + as much as possible *) + let argsign = List.tl arsign in (* arguments in inverse application order *) + let app_decl = List.hd arsign in (* The matched argument *) + let appn = RelDecl.get_name app_decl in + let appt = RelDecl.get_type app_decl in + let argsign = List.rev argsign in (* arguments in application order *) + let sigma, env', nargeqs, argeqs, refl_args, slift, argsign' = + List.fold_left2 + (fun (sigma, env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> + let name = RelDecl.get_name decl in + let t = RelDecl.get_type decl in + let argt = Retyping.get_type_of env sigma arg in + let sigma, eq, refl_arg = + if Reductionops.is_conv env sigma argt t then + let sigma, eq = + mk_eq sigma (lift (nargeqs + slift) argt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) arg) + in + let sigma, refl = mk_eq_refl sigma argt arg in + sigma, eq, refl + else + let sigma, eq = + mk_JMeq sigma (lift (nargeqs + slift) t) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) argt) + (lift (nargeqs + nar) arg) + in + let sigma, refl = mk_JMeq_refl sigma argt arg in + (sigma, eq, refl) + in + let previd, id = + let name = + match EConstr.kind sigma arg with + Rel n -> RelDecl.get_name (lookup_rel n env) + | _ -> name + in + make_prime avoid name + in + (sigma, env, succ nargeqs, + (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq)) :: argeqs, + refl_arg :: refl_args, + pred slift, + RelDecl.set_name (Name id) decl :: argsign')) + (sigma, env, neqs, [], [], slift, []) args argsign + in + let sigma, eq = + mk_JMeq sigma + (lift (nargeqs + slift) appt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) ty) + (lift (nargeqs + nar) tm) + in + let sigma, refl_eq = mk_JMeq_refl sigma ty tm in + let previd, id = make_prime avoid appn in + (sigma, (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq) :: argeqs) :: eqs, + succ nargeqs, + refl_eq :: refl_args, + pred slift, + ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) + + | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) + let decl = match arsign with [x] -> x | _ -> assert(false) in + let name = RelDecl.get_name decl in + let previd, id = make_prime avoid name in + let arsign' = RelDecl.set_name (Name id) decl in + let tomatch_ty = type_of_tomatch ty in + let sigma, eq = + mk_eq sigma (lift nar tomatch_ty) + (mkRel slift) (lift nar tm) + in + let sigma, refl = mk_eq_refl sigma tomatch_ty tm in + let na = make_annot (Name (eq_id avoid previd)) Sorts.Relevant in + (sigma, + [LocalAssum (na, eq)] :: eqs, succ neqs, + refl :: refl_args, + pred slift, (arsign' :: []) :: arsigns)) + (sigma, [], 0, [], nar, []) tomatchs arsign + in + let arsign'' = List.rev arsign' in + assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *) + sigma, arsign'', allnames, nar, eqs, neqs, refls + +let context_of_arsign l = + let (x, _) = List.fold_right + (fun c (x, n) -> + (lift_rel_context n c @ x, List.length c + n)) + l ([], 0) + in x + +let compile_program_cases ?loc style (typing_function, sigma) tycon env + (predopt, tomatchl, eqns) = + let typing_fun tycon env sigma = function + | Some t -> typing_function tycon env sigma t + | None -> use_unit_judge env sigma in + + (* We build the matrix of patterns and right-hand side *) + let matx = matx_of_eqns env eqns in + + (* We build the vector of terms to match consistently with the *) + (* constructors found in patterns *) + let env, sigma, tomatchs = coerce_to_indtype ~program_mode:true typing_function env sigma matx tomatchl in + let tycon = valcon_of_tycon tycon in + let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env sigma tomatchs tycon in + let _,env = push_rel_context ~hypnaming:ProgramNaming sigma tomatchs_lets env in + let len = List.length eqns in + let sigma, sign, allnames, signlen, eqs, neqs, args = + (* The arity signature *) + let arsign = extract_arity_signature ~dolift:false !!env tomatchs tomatchl in + (* Build the dependent arity signature, the equalities which makes + the first part of the predicate and their instantiations. *) + let avoid = Id.Set.empty in + build_dependent_signature !!env sigma avoid tomatchs arsign + + in + let sigma, tycon, arity = + let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in + match tycon' with + | None -> + let sigma, ev = mkExistential !!env sigma in + sigma, ev, lift nar ev + | Some t -> + let sigma, pred = + match prepare_predicate_from_arsign_tycon ~program_mode:true env sigma loc tomatchs sign t with + | Some (evd, pred, arsign) -> evd, pred + | None -> sigma, lift nar t + in + sigma, Option.get tycon, pred + in + let neqs, arity = + let ctx = context_of_arsign eqs in + let neqs = List.length ctx in + neqs, it_mkProd_or_LetIn (lift neqs arity) ctx + in + let sigma, lets, matx = + (* Type the rhs under the assumption of equations *) + constrs_of_pats typing_fun env sigma matx tomatchs sign neqs arity + in + let matx = List.rev matx in + let _ = assert (Int.equal len (List.length lets)) in + let _,env = push_rel_context ~hypnaming:ProgramNaming sigma lets env in + let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in + let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in + let args = List.rev_map (lift len) args in + let pred = liftn len (succ signlen) arity in + let nal, pred = build_initial_predicate sign pred 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) *) + + (* TODO relevance *) + let out_tmt na = function NotInd (None,t) -> LocalAssum (make_annot na Sorts.Relevant,t) + | NotInd (Some b, t) -> LocalDef (make_annot na Sorts.Relevant,b,t) + | IsInd (typ,_,_) -> LocalAssum (make_annot na Sorts.Relevant,typ) in + let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in + + let typs = + List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in + + let dep_sign = + find_dependencies_signature sigma + (List.make (List.length typs) true) + typs in + + let typs' = + List.map3 + (fun (tm,tmt) deps (na,realnames) -> + let deps = if not (isRel sigma tm) then [] else deps in + let tmt = set_tomatch_realnames realnames tmt in + ((tm,tmt),deps,na)) + tomatchs dep_sign nal in + + let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in + + let typing_function tycon env sigma = function + | Some t -> typing_function tycon env sigma t + | None -> use_unit_judge env sigma in + + let pb = + { env = env; + pred = pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + casestyle= style; + typing_function = typing_function } in + + let sigma, j = compile ~program_mode:true sigma pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern !!env) matx; + let body = it_mkLambda_or_LetIn (applist (j.uj_val, args)) lets in + let j = + { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; + (* XXX: is this normalization needed? *) + uj_type = Evarutil.nf_evar sigma tycon; } + in sigma, j + +(**************************************************************************) +(* Main entry of the matching compilation *) + +let compile_cases ?loc ~program_mode style (typing_fun, sigma) tycon env (predopt, tomatchl, eqns) = + if predopt == None && program_mode && Program.is_program_cases () then + compile_program_cases ?loc style (typing_fun, sigma) + tycon env (predopt, tomatchl, eqns) + else + + (* We build the matrix of patterns and right-hand side *) + let matx = matx_of_eqns env eqns in + + (* We build the vector of terms to match consistently with the *) + (* constructors found in patterns *) + let predenv, sigma, tomatchs = coerce_to_indtype ~program_mode typing_fun env sigma matx tomatchl in + + (* If an elimination predicate is provided, we check it is compatible + with the type of arguments to match; if none is provided, we + build alternative possible predicates *) + let arsign = extract_arity_signature !!env tomatchs tomatchl in + let preds = prepare_predicate ?loc ~program_mode typing_fun predenv sigma tomatchs arsign tycon predopt in + + let compile_for_one_predicate (sigma,nal,pred) = + (* 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) *) + + (* TODO relevance *) + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b,t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in + let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt (make_annot na Sorts.Relevant) tmt)) nal tomatchs in + + let typs = + List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in + + let dep_sign = + find_dependencies_signature sigma + (List.make (List.length typs) true) + typs in + + let typs' = + List.map3 + (fun (tm,tmt) deps (na,realnames) -> + let deps = if not (isRel sigma tm) then [] else deps in + let tmt = set_tomatch_realnames realnames tmt in + ((tm,tmt),deps,na)) + tomatchs dep_sign nal in + + let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in + + (* A typing function that provides with a canonical term for absurd cases*) + let typing_fun tycon env sigma = function + | Some t -> typing_fun tycon env sigma t + | None -> use_unit_judge env sigma in + + let pb = + { env = env; + pred = pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + casestyle = style; + typing_function = typing_fun } in + + let sigma, j = compile ~program_mode sigma pb in + + (* We coerce to the tycon (if an elim predicate was provided) *) + inh_conv_coerce_to_tycon ?loc ~program_mode !!env sigma j tycon + in + + (* Return the term compiled with the first possible elimination *) + (* predicate for which the compilation succeeds *) + let j = list_try_compile compile_for_one_predicate preds in + + (* We check for unused patterns *) + List.iter (check_unused_pattern !!env) matx; + + j diff --git a/pretyping/cases.mli b/pretyping/cases.mli new file mode 100644 index 0000000000..b0349a3d05 --- /dev/null +++ b/pretyping/cases.mli @@ -0,0 +1,127 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Evd +open Environ +open EConstr +open Inductiveops +open Glob_term +open Evardefine + +(** {5 Compilation of pattern-matching } *) + +(** {6 Pattern-matching errors } *) +type pattern_matching_error = + | BadPattern of constructor * constr + | BadConstructor of constructor * inductive + | WrongNumargConstructor of constructor * int + | WrongNumargInductive of inductive * int + | UnusedClause of cases_pattern list + | NonExhaustive of cases_pattern list + | CannotInferPredicate of (constr * types) array + +exception PatternMatchingError of env * evar_map * pattern_matching_error + +val error_wrong_numarg_constructor : ?loc:Loc.t -> env -> constructor -> int -> 'a + +val error_wrong_numarg_inductive : ?loc:Loc.t -> env -> inductive -> int -> 'a + +val irrefutable : env -> cases_pattern -> bool + +(** {6 Compilation primitive. } *) + +val compile_cases : + ?loc:Loc.t -> program_mode:bool -> case_style -> + (type_constraint -> GlobEnv.t -> evar_map -> glob_constr -> evar_map * unsafe_judgment) * evar_map -> + type_constraint -> + GlobEnv.t -> glob_constr option * tomatch_tuples * cases_clauses -> + evar_map * unsafe_judgment + +val constr_of_pat : + Environ.env -> + Evd.evar_map -> + rel_context -> + Glob_term.cases_pattern -> + Names.Id.Set.t -> + Evd.evar_map * Glob_term.cases_pattern * + (rel_context * constr * + (types * constr list) * Glob_term.cases_pattern) * + Names.Id.Set.t + +type 'a rhs = + { rhs_env : GlobEnv.t; + rhs_vars : Id.Set.t; + avoid_ids : Id.Set.t; + it : 'a option} + +type 'a equation = + { patterns : cases_pattern list; + rhs : 'a rhs; + alias_stack : Name.t list; + eqn_loc : Loc.t option; + used : bool ref } + +type 'a matrix = 'a equation list + +(* 1st argument of IsInd is the original ind before extracting the summary *) +type tomatch_type = + | IsInd of types * inductive_type * Name.t list + | NotInd of constr option * types + +(* spiwack: The first argument of [Pushed] is [true] for initial + Pushed and [false] otherwise. Used to decide whether the term being + matched on must be aliased in the variable case (only initial + Pushed need to be aliased). The first argument of [Alias] is [true] + if the alias was introduced by an initial pushed and [false] + otherwise.*) +type tomatch_status = + | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) + | Alias of (bool * (Name.t * constr * (constr * types))) + | NonDepAlias + | Abstract of int * rel_declaration + +type tomatch_stack = tomatch_status list + +(* We keep a constr for aliases and a cases_pattern for error message *) + +type pattern_history = + | Top + | MakeConstructor of constructor * pattern_continuation + +and pattern_continuation = + | Continuation of int * cases_pattern list * pattern_history + | Result of cases_pattern list + +type 'a pattern_matching_problem = + { env : GlobEnv.t; + pred : constr; + tomatch : tomatch_stack; + history : pattern_continuation; + mat : 'a matrix; + caseloc : Loc.t option; + casestyle : case_style; + typing_function: type_constraint -> GlobEnv.t -> evar_map -> 'a option -> evar_map * unsafe_judgment } + +val compile : program_mode:bool -> evar_map -> 'a pattern_matching_problem -> evar_map * unsafe_judgment + +val prepare_predicate : ?loc:Loc.t -> program_mode:bool -> + (type_constraint -> + GlobEnv.t -> Evd.evar_map -> glob_constr -> Evd.evar_map * unsafe_judgment) -> + GlobEnv.t -> + Evd.evar_map -> + (types * tomatch_type) list -> + rel_context list -> + constr option -> + glob_constr option -> (Evd.evar_map * (Name.t * Name.t list) list * constr) list + +val make_return_predicate_ltac_lvar : GlobEnv.t -> Evd.evar_map -> Name.t -> + Glob_term.glob_constr -> constr -> GlobEnv.t diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml new file mode 100644 index 0000000000..c9f18d89be --- /dev/null +++ b/pretyping/cbv.ml @@ -0,0 +1,577 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Constr +open Vars +open CClosure +open Esubst + +(**** Call by value reduction ****) + +(* The type of terms with closure. The meaning of the constructors and + * the invariants of this datatype are the following: + * VAL(k,c) represents the constr c with a delayed shift of k. c must be + * in normal form and neutral (i.e. not a lambda, a construct or a + * (co)fix, because they may produce redexes by applying them, + * or putting them in a case) + * STACK(k,v,stk) represents an irreductible value [v] in the stack [stk]. + * [k] is a delayed shift to be applied to both the value and + * the stack. + * CBN(t,S) is the term [S]t. It is used to delay evaluation. For + * instance products are evaluated only when actually needed + * (CBN strategy). + * LAM(n,a,b,S) is the term [S]([x:a]b) where [a] is a list of bindings and + * [n] is the length of [a]. the environment [S] is propagated + * only when the abstraction is applied, and then we use the rule + * ([S]([x:a]b) c) --> [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]. + * PRIMITIVE(cop,args) represent a particial application of + * a primitive, or a fully applied primitive + * which does not reduce. + * cop is the constr representing op. + * + *) +type cbv_value = + | VAL of int * constr + | STACK of int * cbv_value * cbv_stack + | CBN of constr * cbv_value subs + | LAM of int * (Name.t Context.binder_annot * constr) list * constr * cbv_value subs + | FIXP of fixpoint * cbv_value subs * cbv_value array + | COFIXP of cofixpoint * cbv_value subs * cbv_value array + | CONSTR of constructor Univ.puniverses * cbv_value array + | PRIMITIVE of CPrimitives.t * constr * cbv_value array + +(* type of terms with a hole. This hole can appear only under App or Case. + * TOP means the term is considered without context + * APP(v,stk) means the term is applied to v, and then the context stk + * (v.0 is the first argument). + * this corresponds to the application stack of the KAM. + * The members of l are values: we evaluate arguments before + calling 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) + * PROJ(p,pb,stk) means the term is in a primitive projection p, itself in stk. + * pb is the associated projection body + * + * Important remark: the APPs should be collapsed: + * (APP (l,(APP ...))) forbidden + *) +and cbv_stack = + | TOP + | APP of cbv_value array * cbv_stack + | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of Projection.t * cbv_stack + +(* 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,t) -> VAL (k+n,t) + | STACK(k,v,stk) -> STACK(k+n,v,stk) + | CBN (t,s) -> CBN(t,subs_shft(n,s)) + | LAM (nlams,ctxt,b,s) -> LAM (nlams,ctxt,b,subs_shft (n,s)) + | FIXP (fix,s,args) -> + FIXP (fix,subs_shft (n,s), Array.map (shift_value n) args) + | COFIXP (cofix,s,args) -> + COFIXP (cofix,subs_shft (n,s), Array.map (shift_value n) args) + | CONSTR (c,args) -> + CONSTR (c, Array.map (shift_value n) args) + | PRIMITIVE(op,c,args) -> + PRIMITIVE(op,c,Array.map (shift_value n) args) + +let shift_value n v = + if Int.equal n 0 then v else shift_value n v + +(* 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 + subs_cons(Array.init n make_body, 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 + subs_cons(Array.init n make_body, env), bds.(i) + +let make_constr_ref n k t = + match k with + | RelKey p -> mkRel (n+p) + | VarKey id -> t + | ConstKey cst -> t + +(* Adds an application list. Collapse APPs! *) +let stack_app appl stack = + if Int.equal (Array.length appl) 0 then stack else + match stack with + | APP(args,stk) -> APP(Array.append appl args,stk) + | _ -> APP(appl, stack) + +let rec stack_concat stk1 stk2 = + match stk1 with + TOP -> stk2 + | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) + | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) + | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) + +(* merge stacks when there is no shifts in between *) +let mkSTACK = function + v, TOP -> v + | STACK(0,v0,stk0), stk -> STACK(0,v0,stack_concat stk0 stk) + | v,stk -> STACK(0,v,stk) + +type cbv_infos = { + env : Environ.env; + tab : cbv_value Declarations.constant_def KeyTable.t; + reds : RedFlags.reds; + sigma : Evd.evar_map +} + +(* Change: zeta reduction cannot be avoided in CBV *) + +open RedFlags + +let red_set_ref flags = function + | RelKey _ -> 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. + * On the other hand, irreductible atoms absorb the full stack. + *) +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) + | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_app app stack) + | VAL _ | STACK _ | CBN _ | LAM _ -> (head, stack) + + +(* Tests if fixpoint reduction is possible. *) +let fixp_reducible flgs ((reci,i),_) stk = + if red_set flgs fFIX then + match stk with + | APP(appl,_) -> + Array.length appl > reci.(i) && + (match appl.(reci.(i)) with + CONSTR _ -> true + | _ -> false) + | _ -> false + else + false + +let cofixp_reducible flgs _ stk = + if red_set flgs fCOFIX then + match stk with + | (CASE _ | PROJ _ | APP(_,CASE _) | APP(_,PROJ _)) -> true + | _ -> false + else + false + +let get_debug_cbv = Goptions.declare_bool_option_and_ref + ~depr:false + ~value:false + ~name:"cbv visited constants display" + ~key:["Debug";"Cbv"] + +(* Reduction of primitives *) + +open Primred + +module VNativeEntries = + struct + + type elem = cbv_value + type args = cbv_value array + type evd = unit + + let get = Array.get + + let get_int () e = + match e with + | VAL(_, ci) -> + (match kind ci with + | Int i -> i + | _ -> raise Primred.NativeDestKO) + | _ -> raise Primred.NativeDestKO + + let mkInt env i = VAL(0, mkInt i) + + let mkBool env b = + let (ct,cf) = get_bool_constructors env in + CONSTR(Univ.in_punivs (if b then ct else cf), [||]) + + let int_ty env = VAL(0, mkConst @@ get_int_type env) + + let mkCarry env b e = + let (c0,c1) = get_carry_constructors env in + CONSTR(Univ.in_punivs (if b then c1 else c0), [|int_ty env;e|]) + + let mkIntPair env e1 e2 = + let int_ty = int_ty env in + let c = get_pair_constructor env in + CONSTR(Univ.in_punivs c, [|int_ty;int_ty;e1;e2|]) + + let mkLt env = + let (_eq,lt,_gt) = get_cmp_constructors env in + CONSTR(Univ.in_punivs lt, [||]) + + let mkEq env = + let (eq,_lt,_gt) = get_cmp_constructors env in + CONSTR(Univ.in_punivs eq, [||]) + + let mkGt env = + let (_eq,_lt,gt) = get_cmp_constructors env in + CONSTR(Univ.in_punivs gt, [||]) + + end + +module VredNative = RedNative(VNativeEntries) + +let debug_pr_key = function + | ConstKey (sp,_) -> Names.Constant.print sp + | VarKey id -> Names.Id.print id + | RelKey n -> Pp.(str "REL_" ++ int n) + +let rec reify_stack t = function + | TOP -> t + | APP (args,st) -> + reify_stack (mkApp(t,Array.map reify_value args)) st + | CASE (ty,br,ci,env,st) -> + reify_stack + (mkCase (ci, ty, t,br)) + st + | PROJ (p, st) -> + reify_stack (mkProj (p, t)) st + +and reify_value = function (* reduction under binders *) + | VAL (n,t) -> lift n t + | STACK (0,v,stk) -> + reify_stack (reify_value v) stk + | STACK (n,v,stk) -> + lift n (reify_stack (reify_value v) stk) + | CBN(t,env) -> + apply_env env t + | LAM (k,ctxt,b,env) -> + apply_env env @@ + List.fold_left (fun c (n,t) -> + mkLambda (n, t, c)) b ctxt + | FIXP ((lij,fix),env,args) -> + let fix = mkFix (lij, fix) in + mkApp (apply_env env fix, Array.map reify_value args) + | COFIXP ((j,cofix),env,args) -> + let cofix = mkCoFix (j, cofix) in + mkApp (apply_env env cofix, Array.map reify_value args) + | CONSTR (c,args) -> + mkApp(mkConstructU c, Array.map reify_value args) + | PRIMITIVE(op,c,args) -> + mkApp(c, Array.map reify_value args) + +and apply_env env t = + match kind t with + | Rel i -> + begin match expand_rel i env with + | Inl (k, v) -> + reify_value (shift_value k v) + | Inr (k,_) -> + mkRel k + end + | _ -> + map_with_binders subs_lift apply_env env t + +(* The main recursive functions + * + * Go under applications and cases/projections (pushed in the stack), + * expand head constants or substitued de Bruijn, and try to a make a + * constructor, a lambda or a fixp appear 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 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 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 + + | Proj (p, c) -> + let p' = + if red_set info.reds (fCONST (Projection.constant p)) + && red_set info.reds fBETA + then Projection.unfold p + else p + in + norm_head info env c (PROJ (p', 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 (RelKey p) t) + + | Var id -> norm_head_ref 0 info env stack (VarKey id) t + + | Const sp -> + Reductionops.reduction_effect_hook info.env info.sigma + (fst sp) (lazy (reify_stack t stack)); + norm_head_ref 0 info env stack (ConstKey sp) t + + | LetIn (_, b, _, c) -> + (* zeta means letin are contracted; delta without zeta means we *) + (* allow bindings but leave let's in place *) + if red_set info.reds fZETA then + (* New rule: for Cbv, Delta does not apply to locally bound variables + or red_set info.reds fDELTA + *) + let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in + norm_head info env' c stack + else + (CBN(t,env), stack) (* Should we consider a commutative cut ? *) + + | Evar ev -> + (match Reductionops.safe_evar_value info.sigma ev with + Some c -> norm_head info env c stack + | None -> + let e, xs = ev in + let xs' = Array.map (apply_env env) xs in + (VAL(0, mkEvar (e,xs')), stack)) + + (* non-neutral cases *) + | Lambda _ -> + let ctxt,b = Term.decompose_lam t in + (LAM(List.length ctxt, List.rev ctxt,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 _ | Int _) -> (VAL(0, t), stack) + | Prod _ -> (CBN(t,env), stack) + +and norm_head_ref k info env stack normt t = + if red_set_ref info.reds normt then + match cbv_value_cache info normt with + | Declarations.Def body -> + if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); + strip_appl (shift_value k body) stack + | Declarations.Primitive op -> (PRIMITIVE(op,t,[||]),stack) + | Declarations.OpaqueDef _ | Declarations.Undef _ -> + if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + (VAL(0,make_constr_ref k normt t),stack) + else + begin + if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + (VAL(0,make_constr_ref k normt t),stack) + end + +(* 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 = + cbv_stack_value info env (norm_head info env t stack) + +and cbv_stack_value info env = function + (* a lambda meets an application -> BETA *) + | (LAM (nlams,ctxt,b,env), APP (args, stk)) + when red_set info.reds fBETA -> + let nargs = Array.length args in + if nargs == nlams then + cbv_stack_term info stk (subs_cons(args,env)) b + else if nlams < nargs then + let env' = subs_cons(Array.sub args 0 nlams, env) in + let eargs = Array.sub args nlams (nargs-nlams) in + cbv_stack_term info (APP(eargs,stk)) env' b + else + let ctxt' = List.skipn nargs ctxt in + LAM(nlams-nargs,ctxt', b, subs_cons(args,env)) + + (* a Fix applied enough -> IOTA *) + | (FIXP(fix,env,[||]), stk) + when fixp_reducible info.reds 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.reds 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),u),[||]), APP(args,CASE(_,br,ci,env,stk))) + when red_set info.reds fMATCH -> + let cargs = + Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in + cbv_stack_term info (stack_app cargs stk) env br.(n-1) + + (* constructor of arity 0 in a Case -> IOTA *) + | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk)) + when red_set info.reds fMATCH -> + cbv_stack_term info stk env br.(n-1) + + (* constructor in a Projection -> IOTA *) + | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) + when red_set info.reds fMATCH && Projection.unfolded p -> + let arg = args.(Projection.npars p + Projection.arg p) in + cbv_stack_value info env (strip_appl arg stk) + + (* may be reduced later by application *) + | (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) + + (* primitive apply to arguments *) + | (PRIMITIVE(op,c,[||]), APP(appl,stk)) -> + let nargs = CPrimitives.arity op in + let len = Array.length appl in + if nargs <= len then + let args = + if len = nargs then appl + else Array.sub appl 0 nargs in + let stk = + if nargs < len then + stack_app (Array.sub appl nargs (len - nargs)) stk + else stk in + match VredNative.red_prim info.env () op args with + | Some (CONSTR (c, args)) -> + (* args must be moved to the stack to allow future reductions *) + cbv_stack_value info env (CONSTR(c, [||]), stack_app args stk) + | Some v -> cbv_stack_value info env (v,stk) + | None -> mkSTACK(PRIMITIVE(op,c,args), stk) + else (* partical application *) + (assert (stk = TOP); + PRIMITIVE(op,c,appl)) + + (* definitely a value *) + | (head,stk) -> mkSTACK(head, stk) + +and cbv_value_cache info ref = + try KeyTable.find info.tab ref with + Not_found -> + let v = + try + let body = match ref with + | RelKey n -> + let open Context.Rel.Declaration in + begin match Environ.lookup_rel n info.env with + | LocalDef (_, c, _) -> lift n c + | LocalAssum _ -> raise Not_found + end + | VarKey id -> + let open Context.Named.Declaration in + begin match Environ.lookup_named id info.env with + | LocalDef (_, c, _) -> c + | LocalAssum _ -> raise Not_found + end + | ConstKey cst -> Environ.constant_value_in info.env cst + in + let v = cbv_stack_term info TOP (subs_id 0) body in + Declarations.Def v + with + | Environ.NotEvaluableConst (Environ.IsPrimitive op) -> Declarations.Primitive op + | Not_found | Environ.NotEvaluableConst _ -> Declarations.Undef None + in + KeyTable.add info.tab ref v; v + +(* 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 + *) +let rec apply_stack info t = function + | TOP -> t + | APP (args,st) -> + apply_stack info (mkApp(t,Array.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 + | PROJ (p, st) -> + apply_stack info (mkProj (p, t)) 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,t) -> lift n t + | STACK (0,v,stk) -> + apply_stack info (cbv_norm_value info v) stk + | STACK (n,v,stk) -> + lift n (apply_stack info (cbv_norm_value info v) stk) + | CBN(t,env) -> + Constr.map_with_binders subs_lift (cbv_norm_term info) env t + | LAM (n,ctxt,b,env) -> + let nctxt = + List.map_i (fun i (x,ty) -> + (x,cbv_norm_term info (subs_liftn i env) ty)) 0 ctxt in + Term.compose_lam (List.rev nctxt) (cbv_norm_term info (subs_liftn n env) b) + | FIXP ((lij,(names,lty,bds)),env,args) -> + mkApp + (mkFix (lij, + (names, + Array.map (cbv_norm_term info env) lty, + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds)), + Array.map (cbv_norm_value info) args) + | COFIXP ((j,(names,lty,bds)),env,args) -> + mkApp + (mkCoFix (j, + (names,Array.map (cbv_norm_term info env) lty, + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds)), + Array.map (cbv_norm_value info) args) + | CONSTR (c,args) -> + mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) + | PRIMITIVE(op,c,args) -> + mkApp(c,Array.map (cbv_norm_value info) args) + +(* with profiling *) +let cbv_norm infos constr = + let constr = EConstr.Unsafe.to_constr constr in + EConstr.of_constr (with_stats (lazy (cbv_norm_term infos (subs_id 0) constr))) + +(* constant bodies are normalized at the first expansion *) +let create_cbv_infos reds env sigma = + { tab = KeyTable.create 91; reds; env; sigma } diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli new file mode 100644 index 0000000000..d6c2ad146e --- /dev/null +++ b/pretyping/cbv.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Environ +open CClosure +open Esubst + +(*********************************************************************** + s Call-by-value reduction *) + +(** Entry point for cbv normalization of a constr *) +type cbv_infos + +val create_cbv_infos : RedFlags.reds -> env -> Evd.evar_map -> cbv_infos +val cbv_norm : cbv_infos -> constr -> constr + +(*********************************************************************** + i This is for cbv debug *) + +open Constr + +type cbv_value = + | VAL of int * constr + | STACK of int * cbv_value * cbv_stack + | CBN of constr * cbv_value subs + | LAM of int * (Name.t Context.binder_annot * constr) list * constr * cbv_value subs + | FIXP of fixpoint * cbv_value subs * cbv_value array + | COFIXP of cofixpoint * cbv_value subs * cbv_value array + | CONSTR of constructor Univ.puniverses * cbv_value array + | PRIMITIVE of CPrimitives.t * Constr.t * cbv_value array + +and cbv_stack = + | TOP + | APP of cbv_value array * cbv_stack + | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of Projection.t * cbv_stack + +val shift_value : int -> cbv_value -> cbv_value + +val stack_app : cbv_value array -> 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 100644 index 0000000000..90ce1cc594 --- /dev/null +++ b/pretyping/classops.ml @@ -0,0 +1,461 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Util +open Pp +open Names +open Constr +open Libnames +open Globnames +open Mod_subst + +(* usage qque peu general: utilise aussi dans record *) + +(* A class is a type constructor, its type is an arity whose number of + arguments is cl_param (0 for CL_SORT and CL_FUN) *) + +type cl_typ = + | CL_SORT + | CL_FUN + | CL_SECVAR of variable + | CL_CONST of Constant.t + | CL_IND of inductive + | CL_PROJ of Projection.Repr.t + +type cl_info_typ = { + cl_param : int +} + +type coe_typ = GlobRef.t + +module CoeTypMap = GlobRef.Map_env + +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} + +let coe_info_typ_equal c1 c2 = + GlobRef.equal c1.coe_value c2.coe_value && + c1.coe_local == c2.coe_local && + c1.coe_is_identity == c2.coe_is_identity && + c1.coe_is_projection == c2.coe_is_projection && + Int.equal c1.coe_param c2.coe_param + +let cl_typ_ord t1 t2 = match t1, t2 with + | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 + | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 + | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 + | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 + | _ -> Pervasives.compare t1 t2 (** OK *) + +module ClTyp = struct + type t = cl_typ + let compare = cl_typ_ord +end + +module ClTypMap = Map.Make(ClTyp) + +module IntMap = Map.Make(Int) + +let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 + +type inheritance_path = coe_info_typ list + +(* table des classes, des coercions et graphe d'heritage *) + +module Bijint : +sig + module Index : + sig + type t + val compare : t -> t -> int + val equal : t -> t -> bool + val print : t -> Pp.t + end + type 'a t + val empty : 'a t + val mem : cl_typ -> 'a t -> bool + val map : Index.t -> 'a t -> cl_typ * 'a + val revmap : cl_typ -> 'a t -> Index.t * 'a + val add : cl_typ -> 'a -> 'a t -> 'a t + val dom : 'a t -> cl_typ list +end += +struct + + module Index = struct include Int let print = Pp.int end + + type 'a t = { v : (cl_typ * 'a) IntMap.t; s : int; inv : int ClTypMap.t } + let empty = { v = IntMap.empty; s = 0; inv = ClTypMap.empty } + let mem y b = ClTypMap.mem y b.inv + let map x b = IntMap.find x b.v + let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (IntMap.find n b.v)) + let add x y b = + { v = IntMap.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } + let dom b = List.rev (ClTypMap.fold (fun x _ acc -> x::acc) b.inv []) +end + +type cl_index = Bijint.Index.t + +let init_class_tab = + let open Bijint in + add CL_FUN { cl_param = 0 } (add CL_SORT { cl_param = 0 } empty) + +let class_tab = + Summary.ref ~name:"class_tab" (init_class_tab : cl_info_typ Bijint.t) + +let coercion_tab = + Summary.ref ~name:"coercion_tab" (CoeTypMap.empty : coe_info_typ CoeTypMap.t) + +module ClPairOrd = +struct + type t = cl_index * cl_index + let compare (i1, j1) (i2, j2) = + let c = Bijint.Index.compare i1 i2 in + if Int.equal c 0 then Bijint.Index.compare j1 j2 else c +end + +module ClPairMap = Map.Make(ClPairOrd) + +let inheritance_graph = + Summary.ref ~name:"inheritance_graph" (ClPairMap.empty : inheritance_path ClPairMap.t) + +(* ajout de nouveaux "objets" *) + +let add_new_class cl s = + if not (Bijint.mem cl !class_tab) then + class_tab := Bijint.add cl s !class_tab + +let add_new_coercion coe s = + coercion_tab := CoeTypMap.add coe s !coercion_tab + +let add_new_path x y = + inheritance_graph := ClPairMap.add x y !inheritance_graph + +(* 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 + +let cl_fun_index = fst(class_info CL_FUN) + +let cl_sort_index = fst(class_info CL_SORT) + +(* coercion_info : coe_typ -> coe_info_typ *) + +let coercion_info coe = CoeTypMap.find coe !coercion_tab + +let coercion_exists coe = CoeTypMap.mem coe !coercion_tab + +(* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) + +let find_class_type sigma t = + let open EConstr in + let t', args = Reductionops.whd_betaiotazeta_stack sigma t in + match EConstr.kind sigma t' with + | Var id -> CL_SECVAR id, EInstance.empty, args + | Const (sp,u) -> CL_CONST sp, u, args + | Proj (p, c) when not (Projection.unfolded p) -> + CL_PROJ (Projection.repr p), EInstance.empty, (c :: args) + | Ind (ind_sp,u) -> CL_IND ind_sp, u, args + | Prod _ -> CL_FUN, EInstance.empty, [] + | Sort _ -> CL_SORT, EInstance.empty, [] + | _ -> raise Not_found + + +let subst_cl_typ subst ct = match ct with + CL_SORT + | CL_FUN + | CL_SECVAR _ -> ct + | CL_PROJ c -> + let c' = subst_proj_repr subst c in + if c' == c then ct else CL_PROJ c' + | CL_CONST c -> + let c',t = subst_con subst c in + if c' == c then ct else (match t with + | None -> CL_CONST c' + | Some t -> + pi1 (find_class_type Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value))) + | CL_IND i -> + let i' = subst_ind subst i in + if i' == i then ct else CL_IND i' + +(*CSC: here we should change the datatype for coercions: it should be possible + to declare any term as a coercion *) +let subst_coe_typ subst t = subst_global_reference subst t + +(* class_of : Term.constr -> int *) + +let class_of env sigma t = + let (t, n1, i, u, args) = + try + let (cl, u, args) = find_class_type sigma t in + let (i, { cl_param = n1 } ) = class_info cl in + (t, n1, i, u, args) + with Not_found -> + let t = Tacred.hnf_constr env sigma t in + let (cl, u, args) = find_class_type sigma t in + let (i, { cl_param = n1 } ) = class_info cl in + (t, n1, i, u, args) + in + if Int.equal (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 env sigma c = pi3 (find_class_type sigma c) + +let string_of_class = function + | CL_FUN -> "Funclass" + | CL_SORT -> "Sortclass" + | CL_CONST sp -> + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + | CL_PROJ sp -> + let sp = Projection.Repr.constant sp in + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + | CL_IND sp -> + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (IndRef sp)) + | CL_SECVAR sp -> + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (VarRef sp)) + +let pr_class x = str (string_of_class x) + +(* lookup paths *) + +let lookup_path_between_class (s,t) = + ClPairMap.find (s,t) !inheritance_graph + +let lookup_path_to_fun_from_class s = + lookup_path_between_class (s,cl_fun_index) + +let lookup_path_to_sort_from_class s = + lookup_path_between_class (s,cl_sort_index) + +(* advanced path lookup *) + +let apply_on_class_of env sigma t cont = + try + let (cl,u,args) = find_class_type sigma t in + let (i, { cl_param = n1 } ) = class_info cl in + if not (Int.equal (List.length args) n1) then raise Not_found; + t, cont i + with Not_found -> + (* Is it worth to be more incremental on the delta steps? *) + let t = Tacred.hnf_constr env sigma t in + let (cl, u, args) = find_class_type sigma t in + let (i, { cl_param = n1 } ) = class_info cl in + if not (Int.equal (List.length args) n1) then raise Not_found; + t, cont i + +let lookup_path_between env sigma (s,t) = + let (s,(t,p)) = + apply_on_class_of env sigma s (fun i -> + apply_on_class_of env sigma t (fun j -> + lookup_path_between_class (i,j))) in + (s,t,p) + +let lookup_path_to_fun_from env sigma s = + apply_on_class_of env sigma s lookup_path_to_fun_from_class + +let lookup_path_to_sort_from env sigma s = + apply_on_class_of env sigma s lookup_path_to_sort_from_class + +let mkNamed = function + | GlobRef.ConstRef c -> EConstr.mkConst c + | VarRef v -> EConstr.mkVar v + | ConstructRef c -> EConstr.mkConstruct c + | IndRef i -> EConstr.mkInd i + +let get_coercion_constructor env coe = + let evd = Evd.from_env env in + let red x = fst (Reductionops.whd_all_stack env evd x) in + match EConstr.kind evd (red (mkNamed coe.coe_value)) with + | Constr.Construct (c, _) -> + c, Inductiveops.constructor_nrealargs env c -1 + | _ -> raise Not_found + +let lookup_pattern_path_between env (s,t) = + let i = inductive_class_of s in + let j = inductive_class_of t in + List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) + +(* rajouter une coercion dans le graphe *) + +let path_printer : ((Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = + ref (fun _ -> str "<a class path>") + +let install_path_printer f = path_printer := f + +let print_path x = !path_printer x + +let path_comparator : (Environ.env -> Evd.evar_map -> inheritance_path -> inheritance_path -> bool) ref = + ref (fun _ _ _ _ -> false) + +let install_path_comparator f = path_comparator := f + +let compare_path p q = !path_comparator p q + +let warn_ambiguous_path = + CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" + (fun l -> strbrk"Ambiguous paths: " ++ prlist_with_sep fnl print_path l) + +(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit + coercion,source,target *) + +let different_class_params env i = + let ci = class_info_from_index i in + if (snd ci).cl_param > 0 then true + else + match fst ci with + | CL_IND i -> Environ.is_polymorphic env (IndRef i) + | CL_CONST c -> Environ.is_polymorphic env (ConstRef c) + | _ -> false + +let add_coercion_in_graph env sigma (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 = + if not (Bijint.Index.equal i j) || different_class_params env i then + match lookup_path_between_class ij with + | q -> + if not (compare_path env sigma p q) then + ambig_paths := (ij,p)::!ambig_paths; + false + | exception Not_found -> (add_new_path ij p; true) + else + false + 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 + ClPairMap.iter + (fun (s,t) p -> + if not (Bijint.Index.equal s t) then begin + if Bijint.Index.equal t source then begin + try_add_new_path1 (s,target) (p@[ic]); + ClPairMap.iter + (fun (u,v) q -> + if not (Bijint.Index.equal u v) && Bijint.Index.equal u target && not (List.equal coe_info_typ_equal p q) then + try_add_new_path1 (s,v) (p@[ic]@q)) + old_inheritance_graph + end; + if Bijint.Index.equal s target then try_add_new_path1 (source,t) (ic::p) + end) + old_inheritance_graph + end; + match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths + +type coercion = { + coercion_type : coe_typ; + coercion_local : bool; + coercion_is_id : bool; + coercion_is_proj : Projection.Repr.t option; + coercion_source : cl_typ; + coercion_target : cl_typ; + coercion_params : int; +} + +let subst_coercion subst c = + let coe = subst_coe_typ subst c.coercion_type in + let cls = subst_cl_typ subst c.coercion_source in + let clt = subst_cl_typ subst c.coercion_target in + let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in + if c.coercion_type == coe && c.coercion_source == cls && + c.coercion_target == clt && c.coercion_is_proj == clp + then c + else { c with coercion_type = coe; coercion_source = cls; + coercion_target = clt; coercion_is_proj = clp; } + +(* Computation of the class arity *) + +let reference_arity_length env sigma ref = + let t, _ = Typeops.type_of_global_in_context env ref in + List.length (fst (Reductionops.splay_arity env sigma (EConstr.of_constr t))) + +let projection_arity_length env sigma p = + let len = reference_arity_length env sigma (ConstRef (Projection.Repr.constant p)) in + len - Projection.Repr.npars p + +let class_params env sigma = function + | CL_FUN | CL_SORT -> 0 + | CL_CONST sp -> reference_arity_length env sigma (ConstRef sp) + | CL_PROJ sp -> projection_arity_length env sigma sp + | CL_SECVAR sp -> reference_arity_length env sigma (VarRef sp) + | CL_IND sp -> reference_arity_length env sigma (IndRef sp) + +(* add_class : cl_typ -> locality_flag option -> bool -> unit *) + +let add_class env sigma cl = + add_new_class cl { cl_param = class_params env sigma cl } + +let declare_coercion env sigma c = + let () = add_class env sigma c.coercion_source in + let () = add_class env sigma c.coercion_target in + let is, _ = class_info c.coercion_source in + let it, _ = class_info c.coercion_target in + let xf = + { coe_value = c.coercion_type; + coe_local = c.coercion_local; + coe_is_identity = c.coercion_is_id; + coe_is_projection = c.coercion_is_proj; + coe_param = c.coercion_params; + } in + let () = add_new_coercion c.coercion_type xf in + add_coercion_in_graph env sigma (xf,is,it) + +(* For printing purpose *) +let pr_cl_index = Bijint.Index.print + +let classes () = Bijint.dom !class_tab +let coercions () = + List.rev (CoeTypMap.fold (fun _ y acc -> y::acc) !coercion_tab []) + +let inheritance_graph () = + ClPairMap.bindings !inheritance_graph + +let coercion_of_reference r = + let ref = Nametab.global r in + if not (coercion_exists ref) then + user_err ~hdr:"try_add_coercion" + (Nametab.pr_global_env Id.Set.empty ref ++ str" is not a coercion."); + ref + +module CoercionPrinting = + struct + type t = coe_typ + let compare = GlobRef.Ordered.compare + let encode _env = coercion_of_reference + let subst = subst_coe_typ + let printer x = Nametab.pr_global_env Id.Set.empty x + let key = ["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") + 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 0000000000..c04182930e --- /dev/null +++ b/pretyping/classops.mli @@ -0,0 +1,127 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open EConstr +open Evd +open Mod_subst + +(** {6 This is the type of class kinds } *) +type cl_typ = + | CL_SORT + | CL_FUN + | CL_SECVAR of variable + | CL_CONST of Constant.t + | CL_IND of inductive + | CL_PROJ of Projection.Repr.t + +(** Equality over [cl_typ] *) +val cl_typ_eq : cl_typ -> cl_typ -> bool + +val subst_cl_typ : substitution -> cl_typ -> cl_typ + +(** Comparison of [cl_typ] *) +val cl_typ_ord : cl_typ -> cl_typ -> int + +(** This is the type of infos for declared classes *) +type cl_info_typ = { + cl_param : int } + +(** This is the type of coercion kinds *) +type coe_typ = GlobRef.t + +(** This is the type of infos for declared coercions *) +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} + +(** [cl_index] is the type of class keys *) +type cl_index + +(** This is the type of paths from a class to another *) +type inheritance_path = coe_info_typ list + +(** {6 Access to classes infos } *) + +val class_exists : cl_typ -> bool + +val class_info : cl_typ -> (cl_index * cl_info_typ) +(** @raise Not_found if this type is not a class *) + +val class_info_from_index : cl_index -> cl_typ * cl_info_typ + +(** [find_class_type env sigma c] returns the head reference of [c], + its universe instance and its arguments *) +val find_class_type : evar_map -> types -> cl_typ * EInstance.t * constr list + +(** raises [Not_found] if not convertible to a class *) +val class_of : env -> evar_map -> types -> types * cl_index + +(** raises [Not_found] if not mapped to a class *) +val inductive_class_of : inductive -> cl_index + +val class_args_of : env -> evar_map -> types -> constr list + +(** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) +type coercion = { + coercion_type : coe_typ; + coercion_local : bool; + coercion_is_id : bool; + coercion_is_proj : Projection.Repr.t option; + coercion_source : cl_typ; + coercion_target : cl_typ; + coercion_params : int; +} + +val subst_coercion : substitution -> coercion -> coercion + +val declare_coercion : env -> evar_map -> coercion -> unit + +(** {6 Access to coercions infos } *) +val coercion_exists : coe_typ -> bool + +(** {6 Lookup functions for coercion paths } *) + +(** @raise Not_found in the following functions when no path exists *) + +val lookup_path_between_class : cl_index * cl_index -> inheritance_path +val lookup_path_between : env -> evar_map -> types * types -> + types * types * inheritance_path +val lookup_path_to_fun_from : env -> evar_map -> types -> + types * inheritance_path +val lookup_path_to_sort_from : env -> evar_map -> types -> + types * inheritance_path +val lookup_pattern_path_between : + env -> inductive * inductive -> (constructor * int) list + +(**/**) +(* Crade *) +val install_path_printer : + ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit +val install_path_comparator : + (env -> evar_map -> inheritance_path -> inheritance_path -> bool) -> unit +(**/**) + +(** {6 This is for printing purpose } *) +val string_of_class : cl_typ -> string +val pr_class : cl_typ -> Pp.t +val pr_cl_index : cl_index -> Pp.t +val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list +val classes : unit -> cl_typ list +val coercions : unit -> coe_info_typ 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 0000000000..8c9b6550f3 --- /dev/null +++ b/pretyping/coercion.ml @@ -0,0 +1,561 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Created by Hugo Herbelin for Coq V7 by isolating the coercion + mechanism out of the type inference algorithm in file trad.ml from + Coq V6.3, Nov 1999; The coercion mechanism was implemented in + trad.ml by Amokrane Saïbi, May 1996 *) +(* Addition of products and sorts in canonical structures by Pierre + Corbineau, Feb 2008 *) +(* Turned into an abstract compilation unit by Matthieu Sozeau, March 2006 *) + +open CErrors +open Util +open Names +open Term +open Constr +open Context +open Environ +open EConstr +open Vars +open Reductionops +open Pretype_errors +open Classops +open Evarutil +open Evarconv +open Evd +open Termops +open Globnames + +let get_use_typeclasses_for_conversion = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"use typeclass resolution during conversion" + ~key:["Typeclass"; "Resolution"; "For"; "Conversion"] + ~value:true + +(* Typing operations dealing with coercions *) +exception NoCoercion +exception NoCoercionNoUnifier of evar_map * unification_error + +(* Here, funj is a coercion therefore already typed in global context *) +let apply_coercion_args env sigma check isproj argl funj = + let rec apply_rec sigma acc typ = function + | [] -> + (match isproj with + | Some p -> + let npars = Projection.Repr.npars p in + let p = Projection.make p false in + let args = List.skipn npars argl in + let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in + sigma, { uj_val = applist (mkProj (p, hd), tl); + uj_type = typ } + | None -> + sigma, { uj_val = applist (j_val funj,argl); + uj_type = typ }) + | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) + match EConstr.kind sigma (whd_all env sigma typ) with + | Prod (_,c1,c2) -> + let sigma = + if check then + begin match Evarconv.unify_leq_delay env sigma (Retyping.get_type_of env sigma h) c1 with + | exception Evarconv.UnableToUnify _ -> raise NoCoercion + | sigma -> sigma + end + else sigma + in + apply_rec sigma (h::acc) (subst1 h c2) restl + | _ -> anomaly (Pp.str "apply_coercion_args.") + in + apply_rec sigma [] funj.uj_type argl + +(* 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<n then (DAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in + DAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous)) + pat p + +(* raise Not_found if no coercion found *) +let inh_pattern_coerce_to ?loc env pat ind1 ind2 = + let p = lookup_pattern_path_between env (ind1,ind2) in + apply_pattern_coercion ?loc pat p + +(* Program coercions *) + +open Program + +let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c = + let src = Loc.tag ?loc (Evar_kinds.QuestionMark { + Evar_kinds.default_question_mark with + Evar_kinds.qm_obligation=Evar_kinds.Define opaque; + Evar_kinds.qm_name=na; + }) in + let evd, v = Evarutil.new_evar env !evdref ~src c in + let evd = Evd.set_obligation_evar evd (fst (destEvar evd v)) in + evdref := evd; + v + +let app_opt env evdref f t = + whd_betaiota !evdref (app_opt f t) + +let pair_of_array a = (a.(0), a.(1)) + +let disc_subset sigma x = + match EConstr.kind sigma x with + | App (c, l) -> + (match EConstr.kind sigma c with + Ind (i,_) -> + let len = Array.length l in + let sigty = delayed_force sig_typ in + if Int.equal len 2 && eq_ind i (Globnames.destIndRef sigty) + then + let (a, b) = pair_of_array l in + Some (a, b) + else None + | _ -> None) + | _ -> None + +exception NoSubtacCoercion + +let hnf env evd c = whd_all env evd c +let hnf_nodelta env evd c = whd_betaiota evd c + +let lift_args n sign = + let rec liftrec k = function + | t::sign -> liftn n k t :: (liftrec (k-1) sign) + | [] -> [] + in + liftrec (List.length sign) sign + +let mu env evdref t = + let rec aux v = + let v' = hnf env !evdref v in + match disc_subset !evdref v' with + | Some (u, p) -> + let f, ct = aux u in + let p = hnf_nodelta env !evdref p in + (Some (fun x -> + app_opt env evdref + f (papp evdref sig_proj1 [| u; p; x |])), + ct) + | None -> (None, v) + in aux t + +and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) + : (EConstr.constr -> EConstr.constr) option + = + let open Context.Rel.Declaration in + let rec coerce_unify env x y = + let x = hnf env !evdref x and y = hnf env !evdref y in + try + evdref := Evarconv.unify_leq_delay env !evdref x y; + None + with UnableToUnify _ -> coerce' env x y + and coerce' env x y : (EConstr.constr -> EConstr.constr) option = + let subco () = subset_coerce env evdref x y in + let dest_prod c = + match Reductionops.splay_prod_n env (!evdref) 1 c with + | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na, t), c + | _ -> raise NoSubtacCoercion + in + let coerce_application typ typ' c c' l l' = + let len = Array.length l in + let rec aux tele typ typ' i co = + if i < len then + let hdx = l.(i) and hdy = l'.(i) in + try evdref := unify_leq_delay env !evdref hdx hdy; + let (n, eqT), restT = dest_prod typ in + let (n', eqT'), restT' = dest_prod typ' in + aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co + with UnableToUnify _ -> + let (n, eqT), restT = dest_prod typ in + let (n', eqT'), restT' = dest_prod typ' in + let () = + try evdref := unify_leq_delay env !evdref eqT eqT' + with UnableToUnify _ -> raise NoSubtacCoercion + in + (* Disallow equalities on arities *) + if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; + let restargs = lift_args 1 + (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) + in + let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in + let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in + let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in + let evar = make_existential ?loc n.binder_name env evdref eq in + let eq_app x = papp evdref coq_eq_rect + [| eqT; hdx; pred; x; hdy; evar|] + in + aux (hdy :: tele) (subst1 hdx restT) + (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) + else Some (fun x -> + let term = co x in + let sigma, term = Typing.solve_evars env !evdref term in + evdref := sigma; term) + in + if isEvar !evdref c || isEvar !evdref c' || not (Program.is_program_generalized_coercion ()) then + (* Second-order unification needed. *) + raise NoSubtacCoercion; + aux [] typ typ' 0 (fun x -> x) + in + match (EConstr.kind !evdref x, EConstr.kind !evdref y) with + | Sort s, Sort s' -> + (match ESorts.kind !evdref s, ESorts.kind !evdref s' with + | Prop, Prop | Set, Set -> None + | (Prop | Set), Type _ -> None + | Type x, Type y when Univ.Universe.equal x y -> None (* false *) + | _ -> subco ()) + | Prod (name, a, b), Prod (name', a', b') -> + let name' = + {name' with + binder_name = + Name (Namegen.next_ident_away + Namegen.default_dependent_ident (Termops.vars_of_env env))} + in + let env' = push_rel (LocalAssum (name', a')) env in + let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in + (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) + let coec1 = app_opt env' evdref c1 (mkRel 1) in + (* env, x : a' |- c1[x] : lift 1 a *) + let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in + (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) + (match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun f -> + mkLambda (name', a', + app_opt env' evdref c2 + (mkApp (lift 1 f, [| coec1 |]))))) + + | App (c, l), App (c', l') -> + (match EConstr.kind !evdref c, EConstr.kind !evdref c' with + Ind (i, u), Ind (i', u') -> (* Inductive types *) + let len = Array.length l in + let sigT = delayed_force sigT_typ in + let prod = delayed_force prod_typ in + (* Sigma types *) + if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' + && (eq_ind i (destIndRef sigT) || eq_ind i (destIndRef prod)) + then + if eq_ind i (destIndRef sigT) + then + begin + let (a, pb), (a', pb') = + pair_of_array l, pair_of_array l' + in + let c1 = coerce_unify env a a' in + let remove_head a c = + match EConstr.kind !evdref c with + | Lambda (n, t, t') -> c, t' + | Evar (k, args) -> + let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in + evdref := evs; + let (n, dom, rng) = destLambda !evdref t in + if isEvar !evdref dom then + let (domk, args) = destEvar !evdref dom in + evdref := define domk a !evdref; + else (); + t, rng + | _ -> raise NoSubtacCoercion + in + let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in + let ra = Retyping.relevance_of_type env !evdref a in + let env' = push_rel + (LocalAssum (make_annot (Name Namegen.default_dependent_ident) ra, a)) + env + in + let c2 = coerce_unify env' b b' in + match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun x -> + let x, y = + app_opt env' evdref c1 (papp evdref sigT_proj1 + [| a; pb; x |]), + app_opt env' evdref c2 (papp evdref sigT_proj2 + [| a; pb; x |]) + in + papp evdref sigT_intro [| a'; pb'; x ; y |]) + end + else + begin + let (a, b), (a', b') = + pair_of_array l, pair_of_array l' + in + let c1 = coerce_unify env a a' in + let c2 = coerce_unify env b b' in + match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun x -> + let x, y = + app_opt env evdref c1 (papp evdref prod_proj1 + [| a; b; x |]), + app_opt env evdref c2 (papp evdref prod_proj2 + [| a; b; x |]) + in + papp evdref prod_intro [| a'; b'; x ; y |]) + end + else + if eq_ind i i' && Int.equal len (Array.length l') then + let evm = !evdref in + (try subco () + with NoSubtacCoercion -> + let typ = Typing.unsafe_type_of env evm c in + let typ' = Typing.unsafe_type_of env evm c' in + coerce_application typ typ' c c' l l') + else + subco () + | x, y when EConstr.eq_constr !evdref c c' -> + if Int.equal (Array.length l) (Array.length l') then + let evm = !evdref in + let lam_type = Typing.unsafe_type_of env evm c in + let lam_type' = Typing.unsafe_type_of env evm c' in + coerce_application lam_type lam_type' c c' l l' + else subco () + | _ -> subco ()) + | _, _ -> subco () + + and subset_coerce env evdref x y = + match disc_subset !evdref x with + Some (u, p) -> + let c = coerce_unify env u y in + let f x = + app_opt env evdref c (papp evdref sig_proj1 [| u; p; x |]) + in Some f + | None -> + match disc_subset !evdref y with + Some (u, p) -> + let c = coerce_unify env x u in + Some + (fun x -> + let cx = app_opt env evdref c x in + let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |])) + in + (papp evdref sig_intro [| u; p; cx; evar |])) + | None -> + raise NoSubtacCoercion + in coerce_unify env x y + +let app_coercion env evdref coercion v = + match coercion with + | None -> v + | Some f -> + let sigma, v' = Typing.solve_evars env !evdref (f v) in + evdref := sigma; + whd_betaiota !evdref v' + +let coerce_itf ?loc env evd v t c1 = + let evdref = ref evd in + let coercion = coerce ?loc env evdref t c1 in + let t = Option.map (app_coercion env evdref coercion) v in + !evdref, t + +let saturate_evd env evd = + Typeclasses.resolve_typeclasses + ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd + +(* Apply coercion path from p to hj; raise NoCoercion if not applicable *) +let apply_coercion env sigma p hj typ_cl = + try + let j,t,evd = + List.fold_left + (fun (ja,typ_cl,sigma) i -> + let isid = i.coe_is_identity in + let isproj = i.coe_is_projection in + let sigma, c = new_global sigma i.coe_value in + let typ = Retyping.get_type_of env sigma c in + let fv = make_judge c typ in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma true isproj argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) + (hj,typ_cl,sigma) p + in evd, j + with NoCoercion as e -> raise e + +(* Try to coerce to a funclass; raise NoCoercion if not possible *) +let inh_app_fun_core ~program_mode env evd j = + let t = whd_all env evd j.uj_type in + match EConstr.kind evd t with + | Prod _ -> (evd,j) + | Evar ev -> + let (evd',t) = Evardefine.define_evar_as_product env evd ev in + (evd',{ uj_val = j.uj_val; uj_type = t }) + | _ -> + try let t,p = + lookup_path_to_fun_from env evd j.uj_type in + apply_coercion env evd p j t + with Not_found | NoCoercion -> + if program_mode then + try + let evdref = ref evd in + let coercef, t = mu env evdref t in + let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in + (!evdref, res) + with NoSubtacCoercion | NoCoercion -> + (evd,j) + else raise NoCoercion + +(* Try to coerce to a funclass; returns [j] if no coercion is applicable *) +let inh_app_fun ~program_mode resolve_tc env evd j = + try inh_app_fun_core ~program_mode env evd j + with + | NoCoercion when not resolve_tc + || not (get_use_typeclasses_for_conversion ()) -> (evd, j) + | NoCoercion -> + try inh_app_fun_core ~program_mode env (saturate_evd env evd) j + with NoCoercion -> (evd, j) + +let type_judgment env sigma j = + match EConstr.kind sigma (whd_all env sigma j.uj_type) with + | Sort s -> {utj_val = j.uj_val; utj_type = ESorts.kind sigma s } + | _ -> error_not_a_type env sigma j + +let inh_tosort_force ?loc env evd j = + try + let t,p = lookup_path_to_sort_from env evd j.uj_type in + let evd,j1 = apply_coercion env evd p j t in + let j2 = Environ.on_judgment_type (whd_evar evd) j1 in + (evd,type_judgment env evd j2) + with Not_found | NoCoercion -> + error_not_a_type ?loc env evd j + +let inh_coerce_to_sort ?loc env evd j = + let typ = whd_all env evd j.uj_type in + match EConstr.kind evd typ with + | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = ESorts.kind evd s }) + | Evar ev -> + let (evd',s) = Evardefine.define_evar_as_sort env evd ev in + (evd',{ utj_val = j.uj_val; utj_type = s }) + | _ -> + inh_tosort_force ?loc env evd j + +let inh_coerce_to_base ?loc ~program_mode env evd j = + if program_mode then + let evdref = ref evd in + let ct, typ' = mu env evdref j.uj_type in + let res = + { uj_val = (app_coercion env evdref ct j.uj_val); + uj_type = typ' } + in !evdref, res + else (evd, j) + +let inh_coerce_to_prod ?loc ~program_mode env evd t = + if program_mode then + let evdref = ref evd in + let _, typ' = mu env evdref t in + !evdref, typ' + else (evd, t) + +let inh_coerce_to_fail flags env evd rigidonly v t c1 = + if rigidonly && not (Heads.is_rigid env (EConstr.Unsafe.to_constr c1) && Heads.is_rigid env (EConstr.Unsafe.to_constr t)) + then + raise NoCoercion + else + let evd, v', t' = + try + let t2,t1,p = lookup_path_between env evd (t,c1) in + match v with + | Some v -> + let evd,j = + apply_coercion env evd p + {uj_val = v; uj_type = t} t2 in + evd, Some j.uj_val, j.uj_type + | None -> evd, None, t + with Not_found -> raise NoCoercion + in + try (unify_leq_delay ~flags env evd t' c1, v') + with UnableToUnify _ -> raise NoCoercion + +let default_flags_of env = + default_flags_of TransparentState.full + +let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigidonly v t c1 = + try (unify_leq_delay ~flags env evd t c1, v) + with UnableToUnify (best_failed_evd,e) -> + try inh_coerce_to_fail flags env evd rigidonly v t c1 + with NoCoercion -> + match + EConstr.kind evd (whd_all env evd t), + EConstr.kind evd (whd_all env evd c1) + with + | Prod (name,t1,t2), Prod (_,u1,u2) -> + (* Conversion did not work, we may succeed with a coercion. *) + (* We eta-expand (hence possibly modifying the original term!) *) + (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) + (* has type forall (x:u1), u2 (with v' recursively obtained) *) + (* Note: we retype the term because template polymorphism may have *) + (* weakened its type *) + let name = map_annot (function + | Anonymous -> Name Namegen.default_dependent_ident + | na -> na) name in + let open Context.Rel.Declaration in + let env1 = push_rel (LocalAssum (name,u1)) env in + let (evd', v1) = + inh_conv_coerce_to_fail ?loc env1 evd rigidonly + (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in + let v1 = Option.get v1 in + let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in + let t2 = match v2 with + | None -> subst_term evd' v1 t2 + | Some v2 -> Retyping.get_type_of env1 evd' v2 in + let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in + (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') + | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) + +(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) +let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd cj t = + let (evd', val') = + try + inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly (Some cj.uj_val) cj.uj_type t + with NoCoercionNoUnifier (best_failed_evd,e) -> + try + if program_mode then + coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t + else raise NoSubtacCoercion + with + | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> + error_actual_type ?loc env best_failed_evd cj t e + | NoSubtacCoercion -> + let evd' = saturate_evd env evd in + try + if evd' == evd then + error_actual_type ?loc env best_failed_evd cj t e + else + inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t + with NoCoercionNoUnifier (_evd,_error) -> + error_actual_type ?loc env best_failed_evd cj t e + in + let val' = match val' with Some v -> v | None -> assert(false) in + (evd',{ uj_val = val'; uj_type = t }) + +let inh_conv_coerce_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false flags env evd +let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc true flags env evd + +let inh_conv_coerces_to ?loc env evd ?(flags=default_flags_of env) t t' = + try + fst (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t') + with NoCoercion -> + evd (* Maybe not enough information to unify *) + diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli new file mode 100644 index 0000000000..43d4059785 --- /dev/null +++ b/pretyping/coercion.mli @@ -0,0 +1,68 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Evd +open Names +open Environ +open EConstr +open Glob_term + +(** {6 Coercions. } *) + +(** [inh_app_fun resolve_tc env isevars j] coerces [j] to a function; i.e. it + inserts a coercion into [j], if needed, in such a way it gets as + type a product; it returns [j] if no coercion is applicable. + resolve_tc=false disables resolving type classes (as the last + resort before failing) *) +val inh_app_fun : program_mode:bool -> bool -> + env -> evar_map -> unsafe_judgment -> evar_map * 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 : ?loc:Loc.t -> + env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment + +(** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it + inserts a coercion into [j], if needed, in such a way it gets as + type its base type (the notion depends on the coercion system) *) +val inh_coerce_to_base : ?loc:Loc.t -> program_mode:bool -> + env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment + +(** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) +val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> + env -> evar_map -> types -> evar_map * types + +(** [inh_conv_coerce_to resolve_tc Loc.t 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. resolve_tc=false disables resolving type classes (as the last + resort before failing) *) + +val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool -> + env -> evar_map -> ?flags:Evarconv.unify_flags -> + unsafe_judgment -> types -> evar_map * unsafe_judgment + +val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool -> + env -> evar_map -> ?flags:Evarconv.unify_flags -> + unsafe_judgment -> types -> evar_map * unsafe_judgment + +(** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] + is coercible to an object of type [t'] adding evar constraints if needed; + it fails if no coercion exists *) +val inh_conv_coerces_to : ?loc:Loc.t -> + env -> evar_map -> ?flags:Evarconv.unify_flags -> + types -> types -> evar_map + +(** [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:Loc.t -> env -> cases_pattern -> inductive -> inductive -> cases_pattern diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml new file mode 100644 index 0000000000..6bfbb9a9c0 --- /dev/null +++ b/pretyping/constr_matching.ml @@ -0,0 +1,562 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Pp +open CErrors +open Util +open Names +open Constr +open Context +open Globnames +open Termops +open EConstr +open Vars +open Pattern +open Patternops +open Context.Rel.Declaration +open Ltac_pretype +(*i*) + +(* Given a term with second-order variables in it, + represented by Meta's, and possibly applied using [SOAPP] to + terms, this function will perform second-order, binding-preserving, + matching, in the case where the pattern is a pattern in the sense + of Dale Miller. + + ALGORITHM: + + Given a pattern, we decompose it, flattening Cast's and apply's, + recursing on all operators, and pushing the name of the binder each + time we descend a binder. + + When we reach a first-order variable, we ask that the corresponding + term's free-rels all be higher than the depth of the current stack. + + When we reach a second-order application, we ask that the + intersection of the free-rels of the term and the current stack be + contained in the arguments of the application, and in that case, we + construct a LAMBDA with the names on the stack. + + *) + +type binding_bound_vars = Id.Set.t +type bound_ident_map = Id.t Id.Map.t + +exception PatternMatchingFailure + +let warn_meta_collision = + CWarnings.create ~name:"meta-collision" ~category:"ltac" + (fun name -> + strbrk "Collision between bound variable " ++ Id.print name ++ + strbrk " and a metavariable of same name.") + + +let constrain sigma n (ids, m) ((names,seen as names_seen), terms as subst) = + let open EConstr in + try + let (ids', m') = Id.Map.find n terms in + if List.equal Id.equal ids ids' && eq_constr sigma m m' then subst + else raise PatternMatchingFailure + with Not_found -> + let () = if Id.Map.mem n names then warn_meta_collision n in + (names_seen, Id.Map.add n (ids, m) terms) + +let add_binders na1 na2 binding_vars ((names,seen), terms as subst) = + match na1, na2.binder_name with + | Name id1, Name id2 when Id.Set.mem id1 binding_vars -> + if Id.Map.mem id1 names then + let () = Glob_ops.warn_variable_collision id1 in + subst + else + let id2 = Namegen.next_ident_away id2 seen in + let names = Id.Map.add id1 id2 names in + let seen = Id.Set.add id2 seen in + let () = if Id.Map.mem id1 terms then + warn_meta_collision id1 in + ((names,seen), terms) + | _ -> subst + +let rec build_lambda sigma vars ctx m = match vars with +| [] -> + if Vars.closed0 sigma m then m else raise PatternMatchingFailure +| n :: vars -> + (* change [ x1 ... xn y z1 ... zm |- t ] into + [ x1 ... xn z1 ... zm |- lam y. t ] *) + let pre, suf = List.chop (pred n) ctx in + let (na, t, suf) = match suf with + | [] -> assert false + | (_, id, t) :: suf -> + (map_annot Name.mk_name id, t, suf) + in + (* Check that the abstraction is legal by generating a transitive closure of + its dependencies. *) + let is_nondep t clear = match clear with + | [] -> true + | _ -> + let rels = free_rels sigma t in + let check i b = b || not (Int.Set.mem i rels) in + List.for_all_i check 1 clear + in + let fold (_, _, t) clear = is_nondep t clear :: clear in + (* Produce a list of booleans: true iff we keep the hypothesis *) + let clear = List.fold_right fold pre [false] in + let clear = List.drop_last clear in + (* If the conclusion depends on a variable we cleared, failure *) + let () = if not (is_nondep m clear) then raise PatternMatchingFailure in + (* Create the abstracted term *) + let fold (k, accu) keep = + if keep then + let k = succ k in + (k, Some k :: accu) + else (k, None :: accu) + in + let keep, shift = List.fold_left fold (0, []) clear in + let shift = List.rev shift in + let map = function + | None -> mkProp (* dummy term *) + | Some i -> mkRel (i + 1) + in + (* [x1 ... xn y z1 ... zm] -> [x1 ... xn f(z1) ... f(zm) y] *) + let subst = + List.map map shift @ + mkRel 1 :: + List.mapi (fun i _ -> mkRel (i + keep + 2)) suf + in + let map i (na, id, c) = + let i = succ i in + let subst = List.skipn i subst in + let subst = List.map (fun c -> Vars.lift (- i) c) subst in + (na, id, substl subst c) + in + let pre = List.mapi map pre in + let pre = List.filter_with clear pre in + let m = substl subst m in + let map i = + if i > n then i - n + keep + else match List.nth shift (i - 1) with + | None -> + (* We cleared a variable that we wanted to abstract! *) + raise PatternMatchingFailure + | Some k -> k + in + let vars = List.map map vars in + (* Create the abstraction *) + let m = mkLambda (na, Vars.lift keep t, m) in + build_lambda sigma vars (pre @ suf) m + +let rec extract_bound_aux k accu frels ctx = match ctx with +| [] -> accu +| (na, _, _) :: ctx -> + if Int.Set.mem k frels then + begin match na with + | Name id -> + let () = if Id.Set.mem id accu then raise PatternMatchingFailure in + extract_bound_aux (k + 1) (Id.Set.add id accu) frels ctx + | Anonymous -> raise PatternMatchingFailure + end + else extract_bound_aux (k + 1) accu frels ctx + +let extract_bound_vars frels ctx = + extract_bound_aux 1 Id.Set.empty frels ctx + +let dummy_constr = EConstr.mkProp + +let make_renaming ids = function +| (Name id, _, _) -> + begin + try EConstr.mkRel (List.index Id.equal id ids) + with Not_found -> dummy_constr + end +| _ -> dummy_constr + +let push_binder na1 na2 t ctx = + let id2 = map_annot (function + | Name id2 -> id2 + | Anonymous -> + let avoid = Id.Set.of_list (List.map (fun (_,id,_) -> id.binder_name) ctx) in + Namegen.next_ident_away Namegen.default_non_dependent_ident avoid) na2 + in + (na1, id2, t) :: ctx + +(* This is an optimization of the main pattern-matching which shares + the longest common prefix of the body and type of a fixpoint. The + only practical effect at the time of writing is in binding variable + names: these variable names must be bound only once since the user + view at a fix displays only a (maximal) shared common prefix *) + +let rec match_under_common_fix_binders sorec sigma binding_vars ctx ctx' env env' subst t1 t2 b1 b2 = + match t1, EConstr.kind sigma t2, b1, EConstr.kind sigma b2 with + | PProd(na1,c1,t1'), Prod(na2,c2,t2'), PLambda (_,c1',b1'), Lambda (na2',c2',b2') -> + let ctx = push_binder na1 na2 c2 ctx in + let ctx' = push_binder na1 na2' c2' ctx' in + let env = EConstr.push_rel (LocalAssum (na2,c2)) env in + let subst = sorec ctx env subst c1 c2 in + let subst = sorec ctx env subst c1' c2' in + let subst = add_binders na1 na2 binding_vars subst in + match_under_common_fix_binders sorec sigma binding_vars + ctx ctx' env env' subst t1' t2' b1' b2' + | PLetIn(na1,c1,u1,t1), LetIn(na2,c2,u2,t2), PLetIn(_,c1',u1',b1), LetIn(na2',c2',u2',b2) -> + let ctx = push_binder na1 na2 u2 ctx in + let ctx' = push_binder na1 na2' u2' ctx' in + let env = EConstr.push_rel (LocalDef (na2,c2,t2)) env in + let subst = sorec ctx env subst c1 c2 in + let subst = sorec ctx env subst c1' c2' in + let subst = Option.fold_left (fun subst u1 -> sorec ctx env subst u1 u2) subst u1 in + let subst = Option.fold_left (fun subst u1' -> sorec ctx env subst u1' u2') subst u1' in + let subst = add_binders na1 na2 binding_vars subst in + match_under_common_fix_binders sorec sigma binding_vars + ctx ctx' env env' subst t1 t2 b1 b2 + | _ -> + sorec ctx' env' (sorec ctx env subst t1 t2) b1 b2 + +let merge_binding sigma allow_bound_rels ctx n cT subst = + let c = match ctx with + | [] -> (* Optimization *) + ([], cT) + | _ -> + let frels = free_rels sigma cT in + if allow_bound_rels then + let vars = extract_bound_vars frels ctx in + let ordered_vars = Id.Set.elements vars in + let rename binding = make_renaming ordered_vars binding in + let renaming = List.map rename ctx in + (ordered_vars, Vars.substl renaming cT) + else + let depth = List.length ctx in + let min_elt = try Int.Set.min_elt frels with Not_found -> succ depth in + if depth < min_elt then + ([], Vars.lift (- depth) cT) + else raise PatternMatchingFailure + in + constrain sigma n c subst + +let matches_core env sigma allow_bound_rels + (binding_vars,pat) c = + let open EConstr in + let convref ref c = + match ref, EConstr.kind sigma c with + | VarRef id, Var id' -> Names.Id.equal id id' + | ConstRef c, Const (c',_) -> Constant.equal c c' + | IndRef i, Ind (i', _) -> Names.eq_ind i i' + | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' + | _, _ -> false + in + let rec sorec ctx env subst p t = + let cT = strip_outer_cast sigma t in + match p, EConstr.kind sigma cT with + | PSoApp (n,args),m -> + let fold (ans, seen) = function + | PRel n -> + let () = if Int.Set.mem n seen then user_err (str "Non linear second-order pattern") in + (n :: ans, Int.Set.add n seen) + | _ -> user_err (str "Only bound indices allowed in second order pattern matching.") + in + let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in + let frels = free_rels sigma cT in + if Int.Set.subset frels relset then + constrain sigma n ([], build_lambda sigma relargs ctx cT) subst + else + raise PatternMatchingFailure + + | PMeta (Some n), m -> merge_binding sigma allow_bound_rels ctx n cT subst + + | PMeta None, m -> subst + + | PRef (VarRef v1), Var v2 when Id.equal v1 v2 -> subst + + | PVar v1, Var v2 when Id.equal v1 v2 -> subst + + | PRef ref, _ when convref ref cT -> subst + + | PRel n1, Rel n2 when Int.equal n1 n2 -> subst + + | PSort ps, Sort s -> + if Sorts.family_equal ps (Sorts.family (ESorts.kind sigma s)) + then subst else raise PatternMatchingFailure + + | PApp (p, [||]), _ -> sorec ctx env subst p t + + | PApp (PApp (h, a1), a2), _ -> + sorec ctx env subst (PApp(h,Array.append a1 a2)) t + + | PApp (PMeta meta,args1), App (c2,args2) -> + (let diff = Array.length args2 - Array.length args1 in + if diff >= 0 then + let args21, args22 = Array.chop diff args2 in + let c = mkApp(c2,args21) in + let subst = + match meta with + | None -> subst + | Some n -> merge_binding sigma allow_bound_rels ctx n c subst in + Array.fold_left2 (sorec ctx env) subst args1 args22 + else (* Might be a projection on the right *) + match EConstr.kind sigma c2 with + | Proj (pr, c) when not (Projection.unfolded pr) -> + (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in + sorec ctx env subst p term + with Retyping.RetypeError _ -> raise PatternMatchingFailure) + | _ -> raise PatternMatchingFailure) + + | PApp (c1,arg1), App (c2,arg2) -> + (match c1, EConstr.kind sigma c2 with + | PRef (ConstRef r), Proj (pr,c) when not (Constant.equal r (Projection.constant pr)) + || Projection.unfolded pr -> + raise PatternMatchingFailure + | PProj (pr1,c1), Proj (pr,c) -> + if Projection.equal pr1 pr then + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure + else raise PatternMatchingFailure + | _, Proj (pr,c) when not (Projection.unfolded pr) -> + (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in + sorec ctx env subst p term + with Retyping.RetypeError _ -> raise PatternMatchingFailure) + | _, _ -> + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure) + + | PApp (PRef (ConstRef c1), _), Proj (pr, c2) + when Projection.unfolded pr || not (Constant.equal c1 (Projection.constant pr)) -> + raise PatternMatchingFailure + + | PApp (c, args), Proj (pr, c2) -> + (try let term = Retyping.expand_projection env sigma pr c2 [] in + sorec ctx env subst p term + with Retyping.RetypeError _ -> raise PatternMatchingFailure) + + | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> + sorec ctx env subst c1 c2 + + | PProd (na1,c1,d1), Prod(na2,c2,d2) -> + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 + + | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 + + | PLetIn (na1,c1,Some t1,d1), LetIn(na2,c2,t2,d2) -> + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + (add_binders na1 na2 binding_vars (sorec ctx env (sorec ctx env subst c1 c2) t1 t2)) d1 d2 + + | PLetIn (na1,c1,None,d1), LetIn(na2,c2,t2,d2) -> + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 + + | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> + let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in + let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in + let n = Context.Rel.length ctx_b2 in + let n' = Context.Rel.length ctx_b2' in + if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then + let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = push_binder Anonymous na t l in + let ctx_br = List.fold_left f ctx ctx_b2 in + let ctx_br' = List.fold_left f ctx ctx_b2' in + let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in + sorec ctx_br' (push_rel_context ctx_b2' env) + (sorec ctx_br (push_rel_context ctx_b2 env) + (sorec ctx env subst a1 a2) b1 b2) b1' b2' + else + raise PatternMatchingFailure + + | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) -> + let n2 = Array.length br2 in + let () = match ci1.cip_ind with + | None -> () + | Some ind1 -> + (* ppedrot: Something spooky going here. The comparison used to be + the generic one, so I may have broken something. *) + if not (eq_ind ind1 ci2.ci_ind) then raise PatternMatchingFailure + in + let () = + if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) + then raise PatternMatchingFailure + in + let chk_branch subst (j,n,c) = + (* (ind,j+1) is normally known to be a correct constructor + and br2 a correct match over the same inductive *) + assert (j < n2); + sorec ctx env subst c br2.(j) + in + let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in + List.fold_left chk_branch chk_head br1 + + | PFix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(lna2,tl2,bl2)) + when Array.equal Int.equal ln1 ln2 && i1 = i2 -> + let ctx' = Array.fold_left3 (fun ctx na1 na2 t2 -> push_binder na1 na2 t2 ctx) ctx lna1 lna2 tl2 in + let env' = Array.fold_left2 (fun env na2 c2 -> EConstr.push_rel (LocalAssum (na2,c2)) env) env lna2 tl2 in + let subst = Array.fold_left4 (match_under_common_fix_binders sorec sigma binding_vars ctx ctx' env env') subst tl1 tl2 bl1 bl2 in + Array.fold_left2 (fun subst na1 na2 -> add_binders na1 na2 binding_vars subst) subst lna1 lna2 + + | PCoFix (i1,(lna1,tl1,bl1)), CoFix (i2,(lna2,tl2,bl2)) + when i1 = i2 -> + let ctx' = Array.fold_left3 (fun ctx na1 na2 t2 -> push_binder na1 na2 t2 ctx) ctx lna1 lna2 tl2 in + let env' = Array.fold_left2 (fun env na2 c2 -> EConstr.push_rel (LocalAssum (na2,c2)) env) env lna2 tl2 in + let subst = Array.fold_left4 (match_under_common_fix_binders sorec sigma binding_vars ctx ctx' env env') subst tl1 tl2 bl1 bl2 in + Array.fold_left2 (fun subst na1 na2 -> add_binders na1 na2 binding_vars subst) subst lna1 lna2 + + | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> + Array.fold_left2 (sorec ctx env) subst args1 args2 + | PInt i1, Int i2 when Uint63.equal i1 i2 -> subst + | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ + | PProd _ | PLetIn _ | PSort _ | PIf _ | PCase _ + | PFix _ | PCoFix _| PEvar _ | PInt _), _ -> raise PatternMatchingFailure + + in + sorec [] env ((Id.Map.empty,Id.Set.empty), Id.Map.empty) pat c + +let matches_core_closed env sigma pat c = + let names, subst = matches_core env sigma false pat c in + (fst names, Id.Map.map snd subst) + +let extended_matches env sigma pat c = + let (names,_), subst = matches_core env sigma true pat c in + names, subst + +let matches env sigma pat c = + snd (matches_core_closed env sigma (Id.Set.empty,pat) c) + +let special_meta = (-1) + +type matching_result = + { m_sub : bound_ident_map * patvar_map; + m_ctx : constr Lazy.t; } + +let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=c; } , (IStream.thunk n) ) + +let isPMeta = function PMeta _ -> true | _ -> false + +let matches_head env sigma pat c = + let open EConstr in + let head = + match pat, EConstr.kind sigma c with + | PApp (c1,arg1), App (c2,arg2) -> + if isPMeta c1 then c else + let n1 = Array.length arg1 in + if n1 < Array.length arg2 then mkApp (c2,Array.sub arg2 0 n1) else c + | c1, App (c2,arg2) when not (isPMeta c1) -> c2 + | _ -> c in + matches env sigma pat head + +(* Tells if it is an authorized occurrence and if the instance is closed *) +let authorized_occ env sigma closed pat c mk_ctx = + try + let subst = matches_core_closed env sigma pat c in + if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst) + then (fun next -> next ()) + else (fun next -> mkresult subst (lazy (mk_ctx (mkMeta special_meta))) next) + with PatternMatchingFailure -> (fun next -> next ()) + +let subargs env v = Array.map_to_list (fun c -> (env, c)) v + +(* Tries to match a subterm of [c] with [pat] *) +let sub_match ?(closed=true) env sigma pat c = + let open EConstr in + let rec aux env c mk_ctx next = + let here = authorized_occ env sigma closed pat c mk_ctx in + let next () = match EConstr.kind sigma c with + | Cast (c1,k,c2) -> + let next_mk_ctx = function + | [c1] -> mk_ctx (mkCast (c1, k, c2)) + | _ -> assert false + in + try_aux [env, c1] next_mk_ctx next + | Lambda (x,c1,c2) -> + let next_mk_ctx = function + | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) + | _ -> assert false + in + let env' = EConstr.push_rel (LocalAssum (x,c1)) env in + try_aux [(env, c1); (env', c2)] next_mk_ctx next + | Prod (x,c1,c2) -> + let next_mk_ctx = function + | [c1; c2] -> mk_ctx (mkProd (x, c1, c2)) + | _ -> assert false + in + let env' = EConstr.push_rel (LocalAssum (x,c1)) env in + try_aux [(env, c1); (env', c2)] next_mk_ctx next + | LetIn (x,c1,t,c2) -> + let next_mk_ctx = function + | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2)) + | _ -> assert false + in + let env' = EConstr.push_rel (LocalDef (x,c1,t)) env in + try_aux [(env, c1); (env', c2)] next_mk_ctx next + | App (c1,lc) -> + let lc1 = Array.sub lc 0 (Array.length lc - 1) in + let app = mkApp (c1,lc1) in + let mk_ctx = function + | [app';c] -> mk_ctx (mkApp (app',[|c|])) + | _ -> assert false in + try_aux [(env, app); (env, Array.last lc)] mk_ctx next + | Case (ci,hd,c1,lc) -> + let next_mk_ctx = function + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | _ -> assert false + in + let sub = (env, c1) :: (env, hd) :: subargs env lc in + try_aux sub next_mk_ctx next + | Fix (indx,(names,types,bodies as recdefs)) -> + let nb_fix = Array.length types in + let next_mk_ctx le = + let (ntypes,nbodies) = CList.chop nb_fix le in + mk_ctx (mkFix (indx,(names, Array.of_list ntypes, Array.of_list nbodies))) in + let env' = push_rec_types recdefs env in + let sub = subargs env types @ subargs env' bodies in + try_aux sub next_mk_ctx next + | CoFix (i,(names,types,bodies as recdefs)) -> + let nb_fix = Array.length types in + let next_mk_ctx le = + let (ntypes,nbodies) = CList.chop nb_fix le in + mk_ctx (mkCoFix (i,(names, Array.of_list ntypes, Array.of_list nbodies))) in + let env' = push_rec_types recdefs env in + let sub = subargs env types @ subargs env' bodies in + try_aux sub next_mk_ctx next + | Proj (p,c') -> + begin try + let term = Retyping.expand_projection env sigma p c' [] in + aux env term mk_ctx next + with Retyping.RetypeError _ -> next () + end + | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ | Int _ -> + next () + in + here next + + (* Tries [sub_match] for all terms in the list *) + and try_aux lc mk_ctx next = + let rec try_sub_match_rec lacc lc = + match lc with + | [] -> next () + | (env, c) :: tl -> + let mk_ctx ce = mk_ctx (List.rev_append lacc (ce :: List.map snd tl)) in + let next () = try_sub_match_rec (c :: lacc) tl in + aux env c mk_ctx next + in + try_sub_match_rec [] lc in + let lempty () = IStream.Nil in + let result () = aux env c (fun x -> x) lempty in + IStream.thunk result + +let match_subterm env sigma pat c = sub_match env sigma pat c + +let is_matching env sigma pat c = + try let _ = matches env sigma pat c in true + with PatternMatchingFailure -> false + +let is_matching_head env sigma pat c = + try let _ = matches_head env sigma pat c in true + with PatternMatchingFailure -> false + +let is_matching_appsubterm ?(closed=true) env sigma pat c = + let pat = (Id.Set.empty,pat) in + let results = sub_match ~closed env sigma pat c in + not (IStream.is_empty results) diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli new file mode 100644 index 0000000000..d19789ef42 --- /dev/null +++ b/pretyping/constr_matching.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This module implements pattern-matching on terms *) + +open Names +open Constr +open EConstr +open Environ +open Pattern +open Ltac_pretype + +type binding_bound_vars = Id.Set.t + +(** [PatternMatchingFailure] is the exception raised when pattern + matching fails *) +exception PatternMatchingFailure + +(** [special_meta] is the default name of the meta holding the + surrounding context in subterm matching *) +val special_meta : metavariable + +(** [bound_ident_map] represents the result of matching binding + identifiers of the pattern with the binding identifiers of the term + matched *) +type bound_ident_map = Id.t Id.Map.t + +(** [matches pat c] matches [c] against [pat] and returns the resulting + assignment of metavariables; it raises [PatternMatchingFailure] if + not matchable; bindings are given in increasing order based on the + numbers given in the pattern *) +val matches : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map + +(** [matches_head pat c] does the same as [matches pat c] but accepts + [pat] to match an applicative prefix of [c] *) +val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map + +(** [extended_matches pat c] also returns the names of bound variables + in [c] that matches the bound variables in [pat]; if several bound + variables or metavariables have the same name, the metavariable, + or else the rightmost bound variable, takes precedence *) +val extended_matches : + env -> Evd.evar_map -> binding_bound_vars * constr_pattern -> + constr -> bound_ident_map * extended_patvar_map + +(** [is_matching pat c] just tells if [c] matches against [pat] *) +val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool + +(** [is_matching_head pat c] just tells if [c] or an applicative + prefix of it matches against [pat] *) +val is_matching_head : env -> Evd.evar_map -> constr_pattern -> constr -> bool + +(** The type of subterm matching results: a substitution + a context + (whose hole is denoted here with [special_meta]) *) +type matching_result = + { m_sub : bound_ident_map * patvar_map; + m_ctx : EConstr.t Lazy.t } + +(** [match_subterm pat c] returns the substitution and the context + corresponding to each **closed** subterm of [c] matching [pat], + considering application contexts as well. *) +val match_subterm : env -> Evd.evar_map -> + binding_bound_vars * constr_pattern -> constr -> + matching_result IStream.t + +(** [is_matching_appsubterm pat c] tells if a subterm of [c] matches + against [pat] taking partial subterms into consideration *) +val is_matching_appsubterm : ?closed:bool -> env -> Evd.evar_map -> constr_pattern -> constr -> bool diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml new file mode 100644 index 0000000000..062e3ca8b2 --- /dev/null +++ b/pretyping/detyping.ml @@ -0,0 +1,1137 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Constr +open Context +open Term +open EConstr +open Vars +open Inductiveops +open Glob_term +open Glob_ops +open Termops +open Namegen +open Libnames +open Globnames +open Mod_subst +open Decl_kinds +open Context.Named.Declaration +open Ltac_pretype + +type detyping_flags = { + flg_lax : bool; + flg_isgoal : bool; +} + +module Avoid : +sig + type t + val make : fast:bool -> Id.Set.t -> t + val compute_name : Evd.evar_map -> let_in:bool -> pattern:bool -> + detyping_flags -> t -> Name.t list * 'a -> Name.t -> + EConstr.constr -> Name.t * t + val next_name_away : detyping_flags -> Name.t -> t -> Id.t * t +end = +struct + +open Nameops + +type t = +| Nice of Id.Set.t +| Fast of Subscript.t Id.Map.t + (** Overapproximation of the set of names to avoid. If [(id ↦ s) ∈ m] then for + all subscript [s'] smaller than [s], [add_subscript id s'] needs to be + avoided. *) + +let make ~fast ids = + if fast then + let fold id accu = + let id, ss = get_subscript id in + let old_ss = try Id.Map.find id accu with Not_found -> Subscript.zero in + if Subscript.compare ss old_ss <= 0 then accu else Id.Map.add id ss accu + in + let avoid = Id.Set.fold fold ids Id.Map.empty in + Fast avoid + else Nice ids + +let fresh_id_in id avoid = + let id, _ = get_subscript id in + (* Find the first free subscript for that identifier *) + let ss = try Subscript.succ (Id.Map.find id avoid) with Not_found -> Subscript.zero in + let avoid = Id.Map.add id ss avoid in + (add_subscript id ss, avoid) + +let compute_name sigma ~let_in ~pattern flags avoid env na c = +match avoid with +| Nice avoid -> + let flags = + if flags.flg_isgoal then RenamingForGoal + else if pattern then RenamingForCasesPattern (fst env, c) + else RenamingElsewhereFor (fst env, c) + in + let na, avoid = + if let_in then compute_displayed_let_name_in sigma flags avoid na c + else compute_displayed_name_in sigma flags avoid na c + in + na, Nice avoid +| Fast avoid -> + (* In fast mode, we use a dumber algorithm but algorithmically more + efficient algorithm that doesn't iterate through the term to find the + used constants and variables. *) + let id = match na with + | Name id -> id + | Anonymous -> + if flags.flg_isgoal then default_non_dependent_ident + else if pattern then default_dependent_ident + else default_non_dependent_ident + in + let id, avoid = fresh_id_in id avoid in + (Name id, Fast avoid) + +let next_name_away flags na avoid = match avoid with +| Nice avoid -> + let id = next_name_away na avoid in + id, Nice (Id.Set.add id avoid) +| Fast avoid -> + let id = match na with + | Anonymous -> default_non_dependent_ident + | Name id -> id + in + let id, avoid = fresh_id_in id avoid in + (id, Fast avoid) + +end + +let compute_name = Avoid.compute_name +let next_name_away = Avoid.next_name_away + +type _ delay = +| Now : 'a delay +| Later : [ `thunk ] delay + +(** Should we keep details of universes during detyping ? *) +let print_universes = ref false + +(** If true, prints local context of evars, whatever print_arguments *) +let print_evar_arguments = ref false + +let add_name na b t (nenv, env) = + let open Context.Rel.Declaration in + (* Is this just a dummy? Be careful, printing doesn't always give us + a correct env. *) + let r = Sorts.Relevant in + add_name na nenv, push_rel (match b with + | None -> LocalAssum (make_annot na r,t) + | Some b -> LocalDef (make_annot na r,b,t) + ) + env + +let add_name_opt na b t (nenv, env) = + match t with + | None -> Termops.add_name na nenv, env + | Some t -> add_name na b t (nenv, env) + +(****************************************************************************) +(* Tools for printing of Cases *) + +let encode_inductive env r = + let indsp = Nametab.global_inductive r in + let constr_lengths = constructors_nrealargs env indsp in + (indsp,constr_lengths) + +(* Parameterization of the translation from constr to ast *) + +(* Tables for Cases printing under a "if" form, a "let" form, *) + +let has_two_constructors lc = + Int.equal (Array.length lc) 2 (* & lc.(0) = 0 & lc.(1) = 0 *) + +let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 + +let encode_bool env ({CAst.loc} as r) = + let (x,lc) = encode_inductive env r in + if not (has_two_constructors lc) then + user_err ?loc ~hdr:"encode_if" + (str "This type has not exactly two constructors."); + x + +let encode_tuple env ({CAst.loc} as r) = + let (x,lc) = encode_inductive env r in + if not (isomorphic_to_tuple lc) then + user_err ?loc ~hdr:"encode_tuple" + (str "This type cannot be seen as a tuple type."); + x + +module PrintingInductiveMake = + functor (Test : sig + val encode : Environ.env -> qualid -> inductive + val member_message : Pp.t -> bool -> Pp.t + val field : string + val title : string + end) -> + struct + type t = inductive + let compare = ind_ord + let encode = Test.encode + let subst subst obj = subst_ind subst obj + let printer ind = Nametab.pr_global_env Id.Set.empty (IndRef ind) + let key = ["Printing";Test.field] + let title = Test.title + let member_message x = Test.member_message (printer x) + let synchronous = true + end + +module PrintingCasesIf = + PrintingInductiveMake (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 = + PrintingInductiveMake (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) + +(* Flags.for printing or not wildcard and synthetisable types *) + +open Goptions + +let wildcard_value = ref true +let force_wildcard () = !wildcard_value + +let () = declare_bool_option + { optdepr = false; + optname = "forced wildcard"; + optkey = ["Printing";"Wildcard"]; + optread = force_wildcard; + optwrite = (:=) wildcard_value } + +let fast_name_generation = ref false + +let () = declare_bool_option { + optdepr = false; + optname = "fast bound name generation algorithm"; + optkey = ["Fast";"Name";"Printing"]; + optread = (fun () -> !fast_name_generation); + optwrite = (:=) fast_name_generation; +} + +let synth_type_value = ref true +let synthetize_type () = !synth_type_value + +let () = declare_bool_option + { optdepr = false; + optname = "pattern matching return type synthesizability"; + optkey = ["Printing";"Synth"]; + optread = synthetize_type; + optwrite = (:=) synth_type_value } + +let reverse_matching_value = ref true +let reverse_matching () = !reverse_matching_value + +let () = declare_bool_option + { optdepr = false; + optname = "pattern-matching reversibility"; + optkey = ["Printing";"Matching"]; + optread = reverse_matching; + optwrite = (:=) reverse_matching_value } + +let print_primproj_params_value = ref false +let print_primproj_params () = !print_primproj_params_value + +let () = declare_bool_option + { optdepr = false; + optname = "printing of primitive projection parameters"; + optkey = ["Printing";"Primitive";"Projection";"Parameters"]; + optread = print_primproj_params; + optwrite = (:=) print_primproj_params_value } + + +(* Auxiliary function for MutCase printing *) +(* [computable] tries to tell if the predicate typing the result is inferable*) + +let computable sigma 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 affirm 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) *) + + let sign,ccl = decompose_lam_assum sigma p in + Int.equal (Context.Rel.length sign) (k + 1) + && + noccur_between sigma 1 (k+1) ccl + +let lookup_name_as_displayed env sigma t s = + let rec lookup avoid n c = match EConstr.kind sigma c with + | Prod (name,_,c') -> + (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with + | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) + | LetIn (name,_,_,c') -> + (match Namegen.compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with + | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) + | Cast (c,_,_) -> lookup avoid n c + | _ -> None + in lookup (Environ.ids_of_named_context_val (Environ.named_context_val env)) 1 t + +let lookup_index_as_renamed env sigma t n = + let rec lookup n d c = match EConstr.kind sigma c with + | Prod (name,_,c') -> + (match Namegen.compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with + (Name _,_) -> lookup n (d+1) c' + | (Anonymous,_) -> + if Int.equal n 0 then + Some (d-1) + else if Int.equal n 1 then + Some d + else + lookup (n-1) (d+1) c') + | LetIn (name,_,_,c') -> + (match Namegen.compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with + | (Name _,_) -> lookup n (d+1) c' + | (Anonymous,_) -> + if Int.equal n 0 then + Some (d-1) + else if Int.equal n 1 then + Some d + else + lookup (n-1) (d+1) c' + ) + | Cast (c,_,_) -> lookup n d c + | _ -> if Int.equal n 0 then Some (d-1) else None + in lookup n 1 t + +(**********************************************************************) +(* Factorization of match patterns *) + +let print_factorize_match_patterns = ref true + +let () = + declare_bool_option + { optdepr = false; + optname = "factorization of \"match\" patterns in printing"; + optkey = ["Printing";"Factorizable";"Match";"Patterns"]; + optread = (fun () -> !print_factorize_match_patterns); + optwrite = (fun b -> print_factorize_match_patterns := b) } + +let print_allow_match_default_clause = ref true + +let () = + declare_bool_option + { optdepr = false; + optname = "possible use of \"match\" default pattern in printing"; + optkey = ["Printing";"Allow";"Match";"Default";"Clause"]; + optread = (fun () -> !print_allow_match_default_clause); + optwrite = (fun b -> print_allow_match_default_clause := b) } + +let rec join_eqns (ids,rhs as x) patll = function + | ({CAst.loc; v=(ids',patl',rhs')} as eqn')::rest -> + if not !Flags.raw_print && !print_factorize_match_patterns && + List.eq_set Id.equal ids ids' && glob_constr_eq rhs rhs' + then + join_eqns x (patl'::patll) rest + else + let eqn,rest = join_eqns x patll rest in + eqn, eqn'::rest + | [] -> + patll, [] + +let number_of_patterns {CAst.v=(_ids,patll,_rhs)} = List.length patll + +let is_default_candidate {CAst.v=(ids,_patll,_rhs)} = ids = [] + +let rec move_more_factorized_default_candidate_to_end eqn n = function + | eqn' :: eqns -> + let set,get = set_temporary_memory () in + if is_default_candidate eqn' && set (number_of_patterns eqn') >= n then + let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn' (get ()) eqns in + if isbest then false, dft, eqns else false, dft, eqn' :: eqns + else + let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn n eqns in + isbest, dft, eqn' :: eqns + | [] -> true, Some eqn, [] + +let rec select_default_clause = function + | eqn :: eqns -> + let set,get = set_temporary_memory () in + if is_default_candidate eqn && set (number_of_patterns eqn) > 1 then + let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn (get ()) eqns in + if isbest then dft, eqns else dft, eqn :: eqns + else + let dft, eqns = select_default_clause eqns in dft, eqn :: eqns + | [] -> None, [] + +let factorize_eqns eqns = + let open CAst in + let rec aux found = function + | {loc;v=(ids,patl,rhs)}::rest -> + let patll,rest = join_eqns (ids,rhs) [patl] rest in + aux (CAst.make ?loc (ids,patll,rhs)::found) rest + | [] -> + found in + let eqns = aux [] (List.rev eqns) in + let mk_anon patl = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl in + let open CAst in + if not !Flags.raw_print && !print_allow_match_default_clause && eqns <> [] then + match select_default_clause eqns with + (* At least two clauses and the last one is disjunctive with no variables *) + | Some {loc=gloc;v=([],patl::_::_,rhs)}, (_::_ as eqns) -> + eqns@[CAst.make ?loc:gloc ([],[mk_anon patl],rhs)] + (* Only one clause which is disjunctive with no variables: we keep at least one constructor *) + (* so that it is not interpreted as a dummy "match" *) + | Some {loc=gloc;v=([],patl::patl'::_,rhs)}, [] -> + [CAst.make ?loc:gloc ([],[patl;mk_anon patl'],rhs)] + | Some {v=((_::_,_,_ | _,([]|[_]),_))}, _ -> assert false + | None, eqns -> eqns + else + eqns + +(**********************************************************************) +(* Fragile algorithm to reverse pattern-matching compilation *) + +let update_name sigma na ((_,(e,_)),c) = + match na with + | Name _ when force_wildcard () && noccurn sigma (List.index Name.equal na e) c -> + Anonymous + | _ -> + na + +let rec decomp_branch tags nal flags (avoid,env as e) sigma c = + match tags with + | [] -> (List.rev nal,(e,c)) + | b::tags -> + let na,c,let_in,body,t = + match EConstr.kind sigma (strip_outer_cast sigma c), b with + | Lambda (na,t,c),false -> na.binder_name,c,true,None,Some t + | LetIn (na,b,t,c),true -> + na.binder_name,c,false,Some b,Some t + | _, false -> + Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])), + false,None,None + | _, true -> + Anonymous,lift 1 c,false,None,None + in + let na',avoid' = compute_name sigma ~let_in ~pattern:true flags avoid env na c in + decomp_branch tags (na'::nal) flags + (avoid', add_name_opt na' body t env) sigma c + +let rec build_tree na isgoal e sigma ci cl = + let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in + let cnl = ci.ci_pp_info.cstr_tags in + List.flatten + (List.init (Array.length cl) + (fun i -> contract_branch isgoal e sigma (cnl.(i),mkpat i,cl.(i)))) + +and align_tree nal isgoal (e,c as rhs) sigma = match nal with + | [] -> [Id.Set.empty,[],rhs] + | na::nal -> + match EConstr.kind sigma c with + | Case (ci,p,c,cl) when + eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) + && not (Int.equal (Array.length cl) 0) + && (* don't contract if p dependent *) + computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> + let clauses = build_tree na isgoal e sigma ci cl in + List.flatten + (List.map (fun (ids,pat,rhs) -> + let lines = align_tree nal isgoal rhs sigma in + List.map (fun (ids',hd,rest) -> Id.Set.fold Id.Set.add ids ids',pat::hd,rest) lines) + clauses) + | _ -> + let na = update_name sigma na rhs in + let pat = DAst.make @@ PatVar na in + let mat = align_tree nal isgoal rhs sigma in + List.map (fun (ids,hd,rest) -> Nameops.Name.fold_right Id.Set.add na ids,pat::hd,rest) mat + +and contract_branch isgoal e sigma (cdn,mkpat,rhs) = + let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in + let mat = align_tree nal isgoal rhs sigma in + List.map (fun (ids,hd,rhs) -> ids,mkpat rhs hd,rhs) mat + +(**********************************************************************) +(* Transform internal representation of pattern-matching into list of *) +(* clauses *) + +let is_nondep_branch sigma c l = + try + (* FIXME: do better using tags from l *) + let sign,ccl = decompose_lam_n_decls sigma (List.length l) c in + noccur_between sigma 1 (Context.Rel.length sign) ccl + with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *) + false + +let extract_nondep_branches test c b l = + let rec strip l r = + match DAst.get r, l with + | r', [] -> r + | GLambda (_,_,_,t), false::l -> strip l t + | GLetIn (_,_,_,t), true::l -> strip l t + (* FIXME: do we need adjustment? *) + | _,_ -> assert false in + if test c l then Some (strip l b) else None + +let it_destRLambda_or_LetIn_names l c = + let rec aux l nal c = + match DAst.get c, l with + | _, [] -> (List.rev nal,c) + | GLambda (na,_,_,c), false::l -> aux l (na::nal) c + | GLetIn (na,_,_,c), true::l -> aux l (na::nal) c + | _, true::l -> (* let-expansion *) aux l (Anonymous :: nal) c + | _, false::l -> + (* eta-expansion *) + let next l = + let x = next_ident_away default_dependent_ident l in + (* Not efficient but unusual and no function to get free glob_vars *) +(* if occur_glob_constr x c then next (x::l) else x in *) + x + in + let x = next (free_glob_vars c) in + let a = DAst.make @@ GVar x in + aux l (Name x :: nal) + (match DAst.get c with + | GApp (p,l) -> DAst.make ?loc:c.CAst.loc @@ GApp (p,l@[a]) + | _ -> DAst.make @@ GApp (c,[a])) + in aux l [] c + +let detype_case computable detype detype_eqns testdep avoid data p c bl = + let (indsp,st,constagsl,k) = data in + let synth_type = synthetize_type () in + let tomatch = detype c in + let alias, aliastyp, pred= + if (not !Flags.raw_print) && synth_type && computable && not (Int.equal (Array.length bl) 0) + then + Anonymous, None, None + else + let p = detype p in + let nl,typ = it_destRLambda_or_LetIn_names k p in + let n,typ = match DAst.get typ with + | GLambda (x,_,t,c) -> x, c + | _ -> Anonymous, typ in + let aliastyp = + if List.for_all (Name.equal Anonymous) nl then None + else Some (CAst.make (indsp,nl)) in + n, aliastyp, Some typ + in + let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in + let tag = + try + if !Flags.raw_print then + RegularStyle + else if st == LetPatternStyle then + st + else if PrintingLet.active indsp then + LetStyle + else if PrintingIf.active indsp then + IfStyle + else + st + with Not_found -> st + in + match tag, aliastyp with + | LetStyle, None -> + let bl' = Array.map detype bl in + let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in + GLetTuple (nal,(alias,pred),tomatch,d) + | IfStyle, None -> + let bl' = Array.map detype bl in + let nondepbrs = + Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in + if Array.for_all ((!=) None) nondepbrs then + GIf (tomatch,(alias,pred), + Option.get nondepbrs.(0),Option.get nondepbrs.(1)) + else + let eqnl = detype_eqns constructs constagsl bl in + GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) + | _ -> + let eqnl = detype_eqns constructs constagsl bl in + GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) + +let rec share_names detype flags n l avoid env sigma c t = + match EConstr.kind sigma c, EConstr.kind sigma t with + (* factorize even when not necessary to have better presentation *) + | Lambda (na,t,c), Prod (na',t',c') -> + let na = Nameops.Name.pick_annot na na' in + let t' = detype flags avoid env sigma t in + let id, avoid = next_name_away flags na.binder_name avoid in + let env = add_name (Name id) None t env in + share_names detype flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' + (* May occur for fix built interactively *) + | LetIn (na,b,t',c), _ when n > 0 -> + let t'' = detype flags avoid env sigma t' in + let b' = detype flags avoid env sigma b in + let id, avoid = next_name_away flags na.binder_name avoid in + let env = add_name (Name id) (Some b) t' env in + share_names detype flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) + (* Only if built with the f/n notation or w/o let-expansion in types *) + | _, LetIn (_,b,_,t) when n > 0 -> + share_names detype flags n l avoid env sigma 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 flags avoid env sigma t' in + let id, avoid = next_name_away flags na'.binder_name avoid in + let env = add_name (Name id) None t' env in + let appc = mkApp (lift 1 c,[|mkRel 1|]) in + share_names detype flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' + (* If built with the f/n notation: we renounce to share names *) + | _ -> + if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough"); + let c = detype flags avoid env sigma c in + let t = detype flags avoid env sigma t in + (List.rev l,c,t) + +let rec share_pattern_names detype n l avoid env sigma c t = + let open Pattern in + if n = 0 then + let c = detype avoid env sigma c in + let t = detype avoid env sigma t in + (List.rev l,c,t) + else match c, t with + | PLambda (na,t,c), PProd (na',t',c') -> + let na = match (na,na') with + Name _, _ -> na + | _, Name _ -> na' + | _ -> na in + let t' = detype avoid env sigma t in + let id = Namegen.next_name_away na avoid in + let avoid = Id.Set.add id avoid in + let env = Name id :: env in + share_pattern_names detype (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' + | _ -> + if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough"); + let c = detype avoid env sigma c in + let t = detype avoid env sigma t in + (List.rev l,c,t) + +let detype_fix detype flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = + let def_avoid, def_env, lfi = + Array.fold_left2 + (fun (avoid, env, l) na ty -> + let id, avoid = next_name_away flags na.binder_name avoid in + (avoid, add_name (Name id) None ty env, id::l)) + (avoid, env, []) names tys in + let n = Array.length tys in + let v = Array.map3 + (fun c t i -> share_names detype flags (i+1) [] def_avoid def_env sigma c (lift n t)) + bodies tys vn in + GRec(GFix (Array.map (fun i -> Some i) (fst nvn), snd 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) + +let detype_cofix detype flags avoid env sigma n (names,tys,bodies) = + let def_avoid, def_env, lfi = + Array.fold_left2 + (fun (avoid, env, l) na ty -> + let id, avoid = next_name_away flags na.binder_name avoid in + (avoid, add_name (Name id) None ty env, id::l)) + (avoid, env, []) names tys in + let ntys = Array.length tys in + let v = Array.map2 + (fun c t -> share_names detype flags 0 [] def_avoid def_env sigma c (lift ntys t)) + bodies tys in + GRec(GCoFix 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) + +(* TODO use some algebraic type with a case for unnamed univs so we + can cleanly detype them. NB: this corresponds to a hack in + Pretyping.interp_universe_level_name to convert Foo.xx strings into + universes. *) +let hack_qualid_of_univ_level sigma l = + match Termops.reference_of_level sigma l with + | Some qid -> qid + | None -> + let path = String.split_on_char '.' (Univ.Level.to_string l) in + let path = List.rev_map Id.of_string_soft path in + Libnames.qualid_of_dirpath (DirPath.make path) + +let detype_universe sigma u = + let fn (l, n) = + let qid = hack_qualid_of_univ_level sigma l in + Some (qid, n) + in + Univ.Universe.map fn u + +let detype_sort sigma = function + | SProp -> GSProp + | Prop -> GProp + | Set -> GSet + | Type u -> + GType + (if !print_universes + then detype_universe sigma u + else []) + +type binder_kind = BProd | BLambda | BLetIn + +(**********************************************************************) +(* Main detyping function *) + +let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable.")) +let set_detype_anonymous f = detype_anonymous := f + +let detype_level sigma l = + let l = hack_qualid_of_univ_level sigma l in + GType (UNamed l) + +let detype_instance sigma l = + let l = EInstance.kind sigma l in + if Univ.Instance.is_empty l then None + else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) + +let delay (type a) (d : a delay) (f : a delay -> _ -> _ -> _ -> _ -> _ -> a glob_constr_r) flags env avoid sigma t : a glob_constr_g = + match d with + | Now -> DAst.make (f d flags env avoid sigma t) + | Later -> DAst.delay (fun () -> f d flags env avoid sigma t) + +let rec detype d flags avoid env sigma t = + delay d detype_r flags avoid env sigma t + +and detype_r d flags avoid env sigma t = + match EConstr.kind sigma (collapse_appl sigma t) with + | Rel n -> + (try match lookup_name_of_rel n (fst env) with + | Name id -> GVar id + | Anonymous -> GVar (!detype_anonymous n) + with Not_found -> + let s = "_UNBOUND_REL_"^(string_of_int n) + in GVar (Id.of_string s)) + | Meta n -> + (* Meta in constr are not user-parsable and are mapped to Evar *) + if n = Constr_matching.special_meta then + (* Using a dash to be unparsable *) + GEvar (Id.of_string_soft "CONTEXT-HOLE", []) + else + GEvar (Id.of_string_soft ("M" ^ string_of_int n), []) + | Var id -> + (* Discriminate between section variable and non-section variable *) + (try let _ = Global.lookup_named id in GRef (VarRef id, None) + with Not_found -> GVar id) + | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) + | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> + DAst.get (detype d flags avoid env sigma c1) + | Cast (c1,k,c2) -> + let d1 = detype d flags avoid env sigma c1 in + let d2 = detype d flags avoid env sigma c2 in + let cast = match k with + | VMcast -> CastVM d2 + | NATIVEcast -> CastNative d2 + | _ -> CastConv d2 + in + GCast(d1,cast) + | Prod (na,ty,c) -> detype_binder d flags BProd avoid env sigma na None ty c + | Lambda (na,ty,c) -> detype_binder d flags BLambda avoid env sigma na None ty c + | LetIn (na,b,ty,c) -> detype_binder d flags BLetIn avoid env sigma na (Some b) ty c + | App (f,args) -> + let mkapp f' args' = + match DAst.get f' with + | GApp (f',args'') -> + GApp (f',args''@args') + | _ -> GApp (f',args') + in + mkapp (detype d flags avoid env sigma f) + (Array.map_to_list (detype d flags avoid env sigma) args) + | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) + | Proj (p,c) -> + let noparams () = + let pars = Projection.npars p in + let hole = DAst.make @@ GHole(Evar_kinds.InternalHole,Namegen.IntroAnonymous,None) in + let args = List.make pars hole in + GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + (args @ [detype d flags avoid env sigma c])) + in + if flags.flg_lax || !Flags.in_debugger || !Flags.in_toplevel then + try noparams () + with _ -> + (* lax mode, used by debug printers only *) + GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + [detype d flags avoid env sigma c]) + else + if print_primproj_params () then + try + let c = Retyping.expand_projection (snd env) sigma p c [] in + DAst.get (detype d flags avoid env sigma c) + with Retyping.RetypeError _ -> noparams () + else noparams () + + | Evar (evk,cl) -> + let bound_to_itself_or_letin decl c = + match decl with + | LocalDef _ -> true + | LocalAssum (id,_) -> + try let n = List.index Name.equal (Name id.binder_name) (fst env) in + isRelN sigma n c + with Not_found -> isVarId sigma id.binder_name c + in + let id,l = + try + let id = match Evd.evar_ident evk sigma with + | None -> Termops.evar_suggested_name evk sigma + | Some id -> id + in + let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in + let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match EConstr.kind sigma c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in + let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel sigma c && Int.Set.mem (destRel sigma c) rels || isVar sigma c && (Id.Set.mem (destVar sigma c) fvs)))) (Evd.find sigma evk) cl in + id,l + with Not_found -> + Id.of_string ("X" ^ string_of_int (Evar.repr evk)), + (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) + in + GEvar (id, + List.map (on_snd (detype d flags avoid env sigma)) l) + | Ind (ind_sp,u) -> + GRef (IndRef ind_sp, detype_instance sigma u) + | Construct (cstr_sp,u) -> + GRef (ConstructRef cstr_sp, detype_instance sigma u) + | Case (ci,p,c,bl) -> + let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in + detype_case comp (detype d flags avoid env sigma) + (detype_eqns d flags avoid env sigma ci comp) + (is_nondep_branch sigma) avoid + (ci.ci_ind,ci.ci_pp_info.style, + ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) + p c bl + | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef + | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef + | Int i -> GInt i + +and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = + try + if !Flags.raw_print || not (reverse_matching ()) then raise Exit; + let mat = build_tree Anonymous flags (avoid,env) sigma ci bl in + List.map (fun (ids,pat,((avoid,env),c)) -> + CAst.make (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) + mat + with e when CErrors.noncritical e -> + Array.to_list + (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) + +and detype_eqn d flags avoid env sigma constr construct_nargs branch = + let make_pat x avoid env b body ty ids = + if force_wildcard () && noccurn sigma 1 b then + DAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids + else + let na,avoid' = compute_name sigma ~let_in:false ~pattern:true flags avoid env x b in + DAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na + in + let rec buildrec ids patlist avoid env l b = + match EConstr.kind sigma b, l with + | _, [] -> CAst.make @@ + (Id.Set.elements ids, + [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], + detype d flags avoid env sigma b) + | Lambda (x,t,b), false::l -> + let pat,new_avoid,new_env,new_ids = make_pat x.binder_name avoid env b None t ids in + buildrec new_ids (pat::patlist) new_avoid new_env l b + + | LetIn (x,b,t,b'), true::l -> + let pat,new_avoid,new_env,new_ids = make_pat x.binder_name avoid env b' (Some b) t ids in + buildrec new_ids (pat::patlist) new_avoid new_env l b' + + | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) + buildrec ids patlist avoid env l c + + | _, true::l -> + let pat = DAst.make @@ PatVar Anonymous in + buildrec ids (pat::patlist) avoid env l b + + | _, false::l -> + (* 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 None mkProp ids in + buildrec new_ids (pat::patlist) new_avoid new_env l new_b + + in + buildrec Id.Set.empty [] avoid env construct_nargs branch + +and detype_binder d flags bk avoid env sigma {binder_name=na} body ty c = + let na',avoid' = match bk with + | BLetIn -> compute_name sigma ~let_in:true ~pattern:false flags avoid env na c + | _ -> compute_name sigma ~let_in:false ~pattern:false flags avoid env na c in + let r = detype d flags avoid' (add_name na' body ty env) sigma c in + match bk with + | BProd -> GProd (na',Explicit,detype d { flags with flg_isgoal = false } avoid env sigma ty, r) + | BLambda -> GLambda (na',Explicit,detype d { flags with flg_isgoal = false } avoid env sigma ty, r) + | BLetIn -> + let c = detype d { flags with flg_isgoal = false } avoid env sigma (Option.get body) in + (* Heuristic: we display the type if in Prop *) + let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in + let t = if s != InProp && not !Flags.raw_print then None else Some (detype d { flags with flg_isgoal = false } avoid env sigma ty) in + GLetIn (na', c, t, r) + +let detype_rel_context d flags where avoid env sigma sign = + let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in + let rec aux avoid env = function + | [] -> [] + | decl::rest -> + let open Context.Rel.Declaration in + let na = get_name decl in + let t = get_type decl in + let na',avoid' = + match where with + | None -> na,avoid + | Some c -> + compute_name sigma ~let_in:(is_local_def decl) ~pattern:false flags avoid env na c + in + let b = match decl with + | LocalAssum _ -> None + | LocalDef (_,b,_) -> Some b + in + let b' = Option.map (detype d flags avoid env sigma) b in + let t' = detype d flags avoid env sigma t in + (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest + in aux avoid env (List.rev sign) + +let detype_names isgoal avoid nenv env sigma t = + let flags = { flg_isgoal = isgoal; flg_lax = false } in + let avoid = Avoid.make ~fast:!fast_name_generation avoid in + detype Now flags avoid (nenv,env) sigma t +let detype d ?(lax=false) isgoal avoid env sigma t = + let flags = { flg_isgoal = isgoal; flg_lax = lax } in + let avoid = Avoid.make ~fast:!fast_name_generation avoid in + detype d flags avoid (names_of_rel_context env, env) sigma t + +let detype_rel_context d ?(lax = false) where avoid env sigma sign = + let flags = { flg_isgoal = false; flg_lax = lax } in + let avoid = Avoid.make ~fast:!fast_name_generation avoid in + detype_rel_context d flags where avoid env sigma sign + +let detype_closed_glob ?lax isgoal avoid env sigma t = + let open Context.Rel.Declaration in + let convert_id cl id = + try Id.Map.find id cl.idents + with Not_found -> id + in + let convert_name cl = function + | Name id -> Name (convert_id cl id) + | Anonymous -> Anonymous + in + let rec detype_closed_glob cl cg : Glob_term.glob_constr = DAst.map (function + | GVar id -> + (* if [id] is bound to a name. *) + begin try + GVar(Id.Map.find id cl.idents) + (* if [id] is bound to a typed term *) + with Not_found -> try + (* assumes [detype] does not raise [Not_found] exceptions *) + let (b,c) = Id.Map.find id cl.typed in + (* spiwack: I'm not sure it is the right thing to do, + but I'm computing the detyping environment like + [Printer.pr_constr_under_binders_env] does. *) + let assums = List.map (fun id -> LocalAssum (make_annot (Name id) Sorts.Relevant,(* dummy *) mkProp)) b in + let env = push_rel_context assums env in + DAst.get (detype Now ?lax isgoal avoid env sigma c) + (* if [id] is bound to a [closed_glob_constr]. *) + with Not_found -> try + let {closure;term} = Id.Map.find id cl.untyped in + DAst.get (detype_closed_glob closure term) + (* Otherwise [id] stands for itself *) + with Not_found -> + GVar id + end + | GLambda (id,k,t,c) -> + let id = convert_name cl id in + GLambda(id,k,detype_closed_glob cl t, detype_closed_glob cl c) + | GProd (id,k,t,c) -> + let id = convert_name cl id in + GProd(id,k,detype_closed_glob cl t, detype_closed_glob cl c) + | GLetIn (id,b,t,e) -> + let id = convert_name cl id in + GLetIn(id,detype_closed_glob cl b, Option.map (detype_closed_glob cl) t, detype_closed_glob cl e) + | GLetTuple (ids,(n,r),b,e) -> + let ids = List.map (convert_name cl) ids in + let n = convert_name cl n in + GLetTuple (ids,(n,r),detype_closed_glob cl b, detype_closed_glob cl e) + | GCases (sty,po,tml,eqns) -> + let (tml,eqns) = + Glob_ops.map_pattern_binders (fun na -> convert_name cl na) tml eqns + in + let (tml,eqns) = + Glob_ops.map_pattern (fun c -> detype_closed_glob cl c) tml eqns + in + GCases(sty,po,tml,eqns) + | c -> + DAst.get (Glob_ops.map_glob_constr (detype_closed_glob cl) cg) + ) cg + in + detype_closed_glob t.closure t.term + +(**********************************************************************) +(* Module substitution: relies on detyping *) + +let rec subst_cases_pattern subst = DAst.map (function + | PatVar _ as pat -> pat + | PatCstr (((kn,i),j),cpl,n) as pat -> + let kn' = subst_mind subst kn + and cpl' = List.Smart.map (subst_cases_pattern subst) cpl in + if kn' == kn && cpl' == cpl then pat else + PatCstr (((kn',i),j),cpl',n) + ) + +let (f_subst_genarg, subst_genarg_hook) = Hook.make () + +let rec subst_glob_constr env subst = DAst.map (function + | GRef (ref,u) as raw -> + let ref',t = subst_global subst ref in + if ref' == ref then raw else (match t with + | None -> GRef (ref', u) + | Some t -> + let evd = Evd.from_env env in + let t = t.Univ.univ_abstracted_value in (* XXX This seems dangerous *) + DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t))) + + | GSort _ + | GVar _ + | GEvar _ + | GInt _ + | GPatVar _ as raw -> raw + + | GApp (r,rl) as raw -> + let r' = subst_glob_constr env subst r + and rl' = List.Smart.map (subst_glob_constr env subst) rl in + if r' == r && rl' == rl then raw else + GApp(r',rl') + + | GLambda (n,bk,r1,r2) as raw -> + let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in + if r1' == r1 && r2' == r2 then raw else + GLambda (n,bk,r1',r2') + + | GProd (n,bk,r1,r2) as raw -> + let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in + if r1' == r1 && r2' == r2 then raw else + GProd (n,bk,r1',r2') + + | GLetIn (n,r1,t,r2) as raw -> + let r1' = subst_glob_constr env subst r1 in + let r2' = subst_glob_constr env subst r2 in + let t' = Option.Smart.map (subst_glob_constr env subst) t in + if r1' == r1 && t == t' && r2' == r2 then raw else + GLetIn (n,r1',t',r2') + + | GCases (sty,rtno,rl,branches) as raw -> + let open CAst in + let rtno' = Option.Smart.map (subst_glob_constr env subst) rtno + and rl' = List.Smart.map (fun (a,x as y) -> + let a' = subst_glob_constr env subst a in + let (n,topt) = x in + let topt' = Option.Smart.map + (fun ({loc;v=((sp,i),y)} as t) -> + let sp' = subst_mind subst sp in + if sp == sp' then t else CAst.(make ?loc ((sp',i),y))) topt in + if a == a' && topt == topt' then y else (a',(n,topt'))) rl + and branches' = List.Smart.map + (fun ({loc;v=(idl,cpl,r)} as branch) -> + let cpl' = + List.Smart.map (subst_cases_pattern subst) cpl + and r' = subst_glob_constr env subst r in + if cpl' == cpl && r' == r then branch else + CAst.(make ?loc (idl,cpl',r'))) + branches + in + if rtno' == rtno && rl' == rl && branches' == branches then raw else + GCases (sty,rtno',rl',branches') + + | GLetTuple (nal,(na,po),b,c) as raw -> + let po' = Option.Smart.map (subst_glob_constr env subst) po + and b' = subst_glob_constr env subst b + and c' = subst_glob_constr env subst c in + if po' == po && b' == b && c' == c then raw else + GLetTuple (nal,(na,po'),b',c') + + | GIf (c,(na,po),b1,b2) as raw -> + let po' = Option.Smart.map (subst_glob_constr env subst) po + and b1' = subst_glob_constr env subst b1 + and b2' = subst_glob_constr env subst b2 + and c' = subst_glob_constr env subst c in + if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else + GIf (c',(na,po'),b1',b2') + + | GRec (fix,ida,bl,ra1,ra2) as raw -> + let ra1' = Array.Smart.map (subst_glob_constr env subst) ra1 + and ra2' = Array.Smart.map (subst_glob_constr env subst) ra2 in + let bl' = Array.Smart.map + (List.Smart.map (fun (na,k,obd,ty as dcl) -> + let ty' = subst_glob_constr env subst ty in + let obd' = Option.Smart.map (subst_glob_constr env subst) obd in + if ty'==ty && obd'==obd then dcl else (na,k,obd',ty'))) + bl in + if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else + GRec (fix,ida,bl',ra1',ra2') + + | GHole (knd, naming, solve) as raw -> + let nknd = match knd with + | Evar_kinds.ImplicitArg (ref, i, b) -> + let nref, _ = subst_global subst ref in + if nref == ref then knd else Evar_kinds.ImplicitArg (nref, i, b) + | _ -> knd + in + let nsolve = Option.Smart.map (Hook.get f_subst_genarg subst) solve in + if nsolve == solve && nknd == knd then raw + else GHole (nknd, naming, nsolve) + + | GCast (r1,k) as raw -> + let r1' = subst_glob_constr env subst r1 in + let k' = smartmap_cast_type (subst_glob_constr env subst) k in + if r1' == r1 && k' == k then raw else GCast (r1',k') + + ) + +(* Utilities to transform kernel cases to simple pattern-matching problem *) + +let simple_cases_matrix_of_branches ind brs = + List.map (fun (i,n,b) -> + let nal,c = it_destRLambda_or_LetIn_names n b in + let mkPatVar na = DAst.make @@ PatVar na in + let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + let ids = List.map_filter Nameops.Name.to_option nal in + CAst.make @@ (ids,[p],c)) + brs + +let return_type_of_predicate ind nrealargs_tags pred = + let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in + (List.hd nal, Some (CAst.make (ind, List.tl nal))), Some p diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli new file mode 100644 index 0000000000..1a8e97efb8 --- /dev/null +++ b/pretyping/detyping.mli @@ -0,0 +1,105 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open EConstr +open Glob_term +open Termops +open Mod_subst +open Evd +open Ltac_pretype + +type _ delay = +| Now : 'a delay +| Later : [ `thunk ] delay + +(** Should we keep details of universes during detyping ? *) +val print_universes : bool ref + +(** If true, prints full local context of evars *) +val print_evar_arguments : bool ref + +(** If true, contract branches with same r.h.s. and same matching + variables in a disjunctive pattern *) +val print_factorize_match_patterns : bool ref + +(** If true and the last non unique clause of a "match" is a + variable-free disjunctive pattern, turn it into a catch-call case *) +val print_allow_match_default_clause : bool ref + +val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern + +val subst_glob_constr : env -> substitution -> glob_constr -> glob_constr + +val factorize_eqns : 'a cases_clauses_g -> 'a disjunctive_cases_clauses_g + +(** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr + de Bruijn indexes are turned to bound names, avoiding names in [avoid] + [isgoal] tells if naming must avoid global-level synonyms as intro does + [ctx] gives the names of the free variables *) + +val detype_names : bool -> Id.Set.t -> names_context -> env -> evar_map -> constr -> glob_constr + +val detype : 'a delay -> ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> constr -> 'a glob_constr_g + +val detype_sort : evar_map -> Sorts.t -> glob_sort + +val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.Set.t -> (names_context * env) -> + evar_map -> rel_context -> 'a glob_decl_g list + +val share_pattern_names : + (Id.Set.t -> names_context -> 'c -> Pattern.constr_pattern -> 'a) -> int -> + (Name.t * Decl_kinds.binding_kind * 'b option * 'a) list -> + Id.Set.t -> names_context -> 'c -> Pattern.constr_pattern -> + Pattern.constr_pattern -> + (Name.t * Decl_kinds.binding_kind * 'b option * 'a) list * 'a * 'a + +val detype_closed_glob : ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> closed_glob_constr -> glob_constr + +(** look for the index of a named var or a nondep var as it is renamed *) +val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option +val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option + +(* XXX: This is a hack and should go away *) +val set_detype_anonymous : (?loc:Loc.t -> int -> Id.t) -> unit + +val force_wildcard : unit -> bool +val synthetize_type : unit -> bool + +(** Utilities to transform kernel cases to simple pattern-matching problem *) + +val it_destRLambda_or_LetIn_names : bool list -> glob_constr -> Name.t list * glob_constr +val simple_cases_matrix_of_branches : + inductive -> (int * bool list * glob_constr) list -> cases_clauses +val return_type_of_predicate : + inductive -> bool list -> glob_constr -> predicate_pattern * glob_constr option + +val subst_genarg_hook : + (substitution -> Genarg.glob_generic_argument -> Genarg.glob_generic_argument) Hook.t + +module PrintingInductiveMake : + functor (Test : sig + val encode : Environ.env -> Libnames.qualid -> Names.inductive + val member_message : Pp.t -> bool -> Pp.t + val field : string + val title : string + end) -> + sig + type t = Names.inductive + val compare : t -> t -> int + val encode : Environ.env -> Libnames.qualid -> Names.inductive + val subst : substitution -> t -> t + val printer : t -> Pp.t + val key : Goptions.option_name + val title : string + val member_message : t -> bool -> Pp.t + val synchronous : bool + end diff --git a/pretyping/doc.tex b/pretyping/doc.tex new file mode 100644 index 0000000000..d92a027eaf --- /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/dune b/pretyping/dune new file mode 100644 index 0000000000..14bce92de1 --- /dev/null +++ b/pretyping/dune @@ -0,0 +1,6 @@ +(library + (name pretyping) + (synopsis "Coq's Type Inference Component (Pretyper)") + (public_name coq.pretyping) + (wrapped false) + (libraries engine)) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml new file mode 100644 index 0000000000..0ccc4fd9f9 --- /dev/null +++ b/pretyping/evarconv.ml @@ -0,0 +1,1796 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Util +open Names +open Constr +open Termops +open Environ +open EConstr +open Context +open Vars +open Reduction +open Reductionops +open Recordops +open Evarutil +open Evardefine +open Evarsolve +open Evd +open Pretype_errors + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +type unify_flags = Evarsolve.unify_flags + +type unify_fun = unify_flags -> + env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result + +let default_transparent_state env = TransparentState.full +(* Conv_oracle.get_transp_state (Environ.oracle env) *) + +let default_flags_of ?(subterm_ts=TransparentState.empty) ts = + { modulo_betaiota = true; + open_ts = ts; closed_ts = ts; subterm_ts; + frozen_evars = Evar.Set.empty; with_cs = true; + allow_K_at_toplevel = true } + +let default_flags env = + let ts = default_transparent_state env in + default_flags_of ts + +let debug_unification = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Print states sent to Evarconv unification"; + optkey = ["Debug";"Unification"]; + optread = (fun () -> !debug_unification); + optwrite = (fun a -> debug_unification:=a); +}) + +let debug_ho_unification = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Print higher-order unification debug information"; + optkey = ["Debug";"HO";"Unification"]; + optread = (fun () -> !debug_ho_unification); + optwrite = (fun a -> debug_ho_unification:=a); +}) + +(*******************************************) +(* Functions to deal with impossible cases *) +(*******************************************) +let impossible_default_case env = + let type_of_id = Coqlib.lib_ref "core.IDProp.type" in + let c, ctx = UnivGen.fresh_global_instance env (Coqlib.(lib_ref "core.IDProp.idProp")) in + let (_, u) = Constr.destRef c in + Some (c, Constr.mkRef (type_of_id, u), ctx) + +let coq_unit_judge = + let open Environ in + let make_judge c t = make_judge (EConstr.of_constr c) (EConstr.of_constr t) in + let na1 = make_annot (Name (Id.of_string "A")) Sorts.Relevant in + let na2 = make_annot (Name (Id.of_string "H")) Sorts.Relevant in + fun env -> + match impossible_default_case env with + | Some (id, type_of_id, ctx) -> + make_judge id type_of_id, ctx + | None -> + (* In case the constants id/ID are not defined *) + Environ.make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) + (mkProd (na1,mkProp,mkArrow (mkRel 1) Sorts.Relevant (mkRel 2))), + Univ.ContextSet.empty + +let unfold_projection env evd ts p c = + let cst = Projection.constant p in + if TransparentState.is_transparent_constant ts cst then + Some (mkProj (Projection.unfold p, c)) + else None + +let eval_flexible_term ts env evd c = + match EConstr.kind evd c with + | Const (c, u) -> + if TransparentState.is_transparent_constant ts c + then Option.map EConstr.of_constr (constant_opt_value_in env (c, EInstance.kind evd u)) + else None + | Rel n -> + (try match lookup_rel n env with + | RelDecl.LocalAssum _ -> None + | RelDecl.LocalDef (_,v,_) -> Some (lift n v) + with Not_found -> None) + | Var id -> + (try + if TransparentState.is_transparent_variable ts id then + env |> lookup_named id |> NamedDecl.get_value + else None + with Not_found -> None) + | LetIn (_,b,_,c) -> Some (subst1 b c) + | Lambda _ -> Some c + | Proj (p, c) -> + if Projection.unfolded p then assert false + else unfold_projection env evd ts p c + | _ -> assert false + +type flex_kind_of_term = + | Rigid + | MaybeFlexible of EConstr.t (* reducible but not necessarily reduced *) + | Flexible of EConstr.existential + +let is_frozen flags (evk, _) = Evar.Set.mem evk flags.frozen_evars + +let flex_kind_of_term flags env evd c sk = + match EConstr.kind evd c with + | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> + Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term flags.open_ts env evd c) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> + if flags.modulo_betaiota then MaybeFlexible c + else Rigid + | Evar ev -> + if is_frozen flags ev then Rigid + else Flexible ev + | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ -> Rigid + | Meta _ -> Rigid + | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) + | Cast _ | App _ | Case _ -> assert false + +let apprec_nohdbeta flags env evd c = + let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in + if flags.modulo_betaiota && Stack.not_purely_applicative sk + then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env evd Cst_stack.empty appr)) + else c + +let position_problem l2r = function + | CONV -> None + | CUMUL -> Some l2r + +(* [occur_rigidly ev evd t] tests if the evar ev occurs in a rigid + context in t. Precondition: t has a rigid head and is not reducible. + + That function is an under approximation of occur-check, it can return + false even if the occur-check would succeed on the normal form. This + means we might postpone unsolvable constraints which will ultimately + result in an occur-check after reductions. If it returns true, we + know that the occur-check would also return true on the normal form. + + [t] is assumed to have a rigid head, which can + appear under a elimination context (e.g. application, match or projection). + + In the inner recursive function, the result indicates if the term is + rigid (irreducible), normal (succession of constructors) or + potentially reducible. For applications, this means than an + occurrence of the evar in arguments should be looked at to find an + occur-check if the head is rigid or normal. For inductive + eliminations, only an occurrence in a rigid context of the + discriminee counts as a rigid occurrence overall, not a normal + occurrence which might disappear after reduction. *) + +type result = Rigid of bool | Normal of bool | Reducible + +let rigid_normal_occ = function Rigid b -> b | Normal b -> b | _ -> false + +let occur_rigidly flags env evd (evk,_) t = + let rec aux t = + match EConstr.kind evd t with + | App (f, c) -> + (match aux f with + | Rigid b -> Rigid (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) + | Normal b -> Normal (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) + | Reducible -> Reducible) + | Construct _ -> Normal false + | Ind _ | Sort _ -> Rigid false + | Proj (p, c) -> + let cst = Projection.constant p in + let rigid = not (TransparentState.is_transparent_constant flags.open_ts cst) in + if rigid then aux c + else (* if the evar appears rigidly in c then this elimination + cannot reduce and we have a rigid occurrence, otherwise + we don't know. *) + (match aux c with + | Rigid _ as res -> res + | Normal b -> Reducible + | Reducible -> Reducible) + | Evar (evk',l as ev) -> + if Evar.equal evk evk' then Rigid true + else if is_frozen flags ev then + Rigid (Array.exists (fun x -> rigid_normal_occ (aux x)) l) + else Reducible + | Cast (p, _, _) -> aux p + | Lambda (na, t, b) -> aux b + | LetIn (na, _, _, b) -> aux b + | Const (c,_) -> + if TransparentState.is_transparent_constant flags.open_ts c then Reducible + else Rigid false + | Prod (_, b, t) -> + let b' = aux b and t' = aux t in + if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true + else Reducible + | Rel _ | Var _ -> Reducible + | Case (_,_,c,_) -> + (match aux c with + | Rigid b -> Rigid b + | _ -> Reducible) + | Meta _ | Fix _ | CoFix _ | Int _ -> Reducible + in + match aux t with + | Rigid b -> b + | Normal b -> b + | Reducible -> false + +(* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose + the problem (t1 stack1) = (t2 stack2) into a problem + + stack1 = params1@[c1]@extra_args1 + stack2 = us2@extra_args2 + t1 params1 c1 = proji params (c xs) + t2 us2 = head us + extra_args1 = extra_args2 + + by finding a record R and an object c := [xs:bs](Build_R params v1..vn) + with vi = (head us), for which we know that the i-th projection proji + satisfies + + proji params (c xs) = head 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 env sigma (t1,sk1) (t2,sk2) = + let (proji, u), arg = Termops.global_app_of_constr sigma t1 in + let canon_s,sk2_effective = + try + match EConstr.kind sigma t2 with + Prod (_,a,b) -> (* assert (l2=[]); *) + let _, a, b = destProd sigma t2 in + if noccurn sigma 1 b then + lookup_canonical_conversion (proji, Prod_cs), + (Stack.append_app [|a;pop b|] Stack.empty) + else raise Not_found + | Sort s -> + let s = ESorts.kind sigma s in + lookup_canonical_conversion + (proji, Sort_cs (Sorts.family s)),[] + | Proj (p, c) -> + let c2 = Globnames.ConstRef (Projection.constant p) in + let c = Retyping.expand_projection env sigma p c [] in + let _, args = destApp sigma c in + let sk2 = Stack.append_app args sk2 in + lookup_canonical_conversion (proji, Const_cs c2), sk2 + | _ -> + let (c2, _) = Termops.global_of_constr sigma t2 in + lookup_canonical_conversion (proji, Const_cs c2),sk2 + with Not_found -> + let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in + (c,cs),[] + in + let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in + let us = List.map EConstr.of_constr us in + let params = List.map EConstr.of_constr params in + let params1, c1, extra_args1 = + match arg with + | Some c -> (* A primitive projection applied to c *) + let ty = Retyping.get_type_of ~lax:true env sigma c in + let (i,u), ind_args = + try Inductiveops.find_mrectype env sigma ty + with _ -> raise Not_found + in Stack.append_app_list ind_args Stack.empty, c, sk1 + | None -> + match Stack.strip_n_app nparams sk1 with + | Some (params1, c1, extra_args1) -> params1, c1, extra_args1 + | _ -> raise Not_found in + let us2,extra_args2 = + let l_us = List.length us in + if Int.equal l_us 0 then Stack.empty,sk2_effective + else match (Stack.strip_n_app (l_us-1) sk2_effective) with + | None -> raise Not_found + | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in + let u, ctx' = UnivGen.fresh_instance_from ctx None in + let subst = Univ.make_inverse_instance_subst u in + let c = EConstr.of_constr c in + let c' = subst_univs_level_constr subst c in + let t' = EConstr.of_constr t' in + let t' = subst_univs_level_constr subst t' in + let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in + let params = List.map (fun c -> subst_univs_level_constr subst c) params in + let us = List.map (fun c -> subst_univs_level_constr subst c) us in + let h, _ = decompose_app_vect sigma t' in + ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), + (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, + (n, Stack.zip sigma (t2,sk2)) + +(* Precondition: one of the terms of the pb is an uninstantiated evar, + * possibly applied to arguments. *) + +let join_failures evd1 evd2 e1 e2 = + match e1, e2 with + | _, CannotSolveConstraint (_,ProblemBeyondCapabilities) -> (evd1,e1) + | _ -> (evd2,e2) + +let rec ise_try evd = function + [] -> assert false + | [f] -> f evd + | f1::l -> + match f1 evd with + | Success _ as x -> x + | UnifFailure (evd1,e1) -> + match ise_try evd l with + | Success _ as x -> x + | UnifFailure (evd2,e2) -> + let evd,e = join_failures evd1 evd2 e1 e2 in + UnifFailure (evd,e) + +let ise_and evd l = + let rec ise_and i = function + [] -> assert false + | [f] -> f i + | f1::l -> + match f1 i with + | Success i' -> ise_and i' l + | UnifFailure _ as x -> x in + ise_and evd l + +let ise_exact ise x1 x2 = + match ise x1 x2 with + | None, out -> out + | _, (UnifFailure _ as out) -> out + | Some _, Success i -> UnifFailure (i,NotSameArgSize) + +let ise_array2 evd f v1 v2 = + let rec allrec i = function + | -1 -> Success i + | n -> + match f i v1.(n) v2.(n) with + | Success i' -> allrec i' (n-1) + | UnifFailure _ as x -> x in + let lv1 = Array.length v1 in + if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1) + else UnifFailure (evd,NotSameArgSize) + +(* Applicative node of stack are read from the outermost to the innermost + but are unified the other way. *) +let rec ise_app_stack2 env f evd sk1 sk2 = + match sk1,sk2 with + | Stack.App node1 :: q1, Stack.App node2 :: q2 -> + let (t1,l1) = Stack.decomp_node_last node1 q1 in + let (t2,l2) = Stack.decomp_node_last node2 q2 in + begin match ise_app_stack2 env f evd l1 l2 with + |(_,UnifFailure _) as x -> x + |x,Success i' -> x,f env i' CONV t1 t2 + end + | _, _ -> (sk1,sk2), Success evd + +(* This function tries to unify 2 stacks element by element. It works + from the end to the beginning. If it unifies a non empty suffix of + stacks but not the entire stacks, the first part of the answer is + Some(the remaining prefixes to tackle)) *) +let ise_stack2 no_app env evd f sk1 sk2 = + let rec ise_stack2 deep i sk1 sk2 = + let fail x = if deep then Some (List.rev sk1, List.rev sk2), Success i + else None, x in + match sk1, sk2 with + | [], [] -> None, Success i + | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 -> + (match f env i CONV t1 t2 with + | Success i' -> + (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with + | Success i'' -> ise_stack2 true i'' q1 q2 + | UnifFailure _ as x -> fail x) + | UnifFailure _ as x -> fail x) + | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + then ise_stack2 true i q1 q2 + else fail (UnifFailure (i, NotSameHead)) + | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, + Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> + if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then + match ise_and i [ + (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); + (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); + (fun i -> ise_exact (ise_stack2 false i) a1 a2)] with + | Success i' -> ise_stack2 true i' q1 q2 + | UnifFailure _ as x -> fail x + else fail (UnifFailure (i,NotSameHead)) + | Stack.App _ :: _, Stack.App _ :: _ -> + if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else + begin match ise_app_stack2 env f i sk1 sk2 with + |_,(UnifFailure _ as x) -> fail x + |(l1, l2), Success i' -> ise_stack2 true i' l1 l2 + end + |_, _ -> fail (UnifFailure (i,(* Maybe improve: *) NotSameHead)) + in ise_stack2 false evd (List.rev sk1) (List.rev sk2) + +(* Make sure that the matching suffix is the all stack *) +let exact_ise_stack2 env evd f sk1 sk2 = + let rec ise_stack2 i sk1 sk2 = + match sk1, sk2 with + | [], [] -> Success i + | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 -> + ise_and i [ + (fun i -> ise_stack2 i q1 q2); + (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); + (fun i -> f env i CONV t1 t2)] + | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, + Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> + if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then + ise_and i [ + (fun i -> ise_stack2 i q1 q2); + (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); + (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); + (fun i -> ise_stack2 i a1 a2)] + else UnifFailure (i,NotSameHead) + | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + then ise_stack2 i q1 q2 + else (UnifFailure (i, NotSameHead)) + | Stack.App _ :: _, Stack.App _ :: _ -> + begin match ise_app_stack2 env f i sk1 sk2 with + |_,(UnifFailure _ as x) -> x + |(l1, l2), Success i' -> ise_stack2 i' l1 l2 + end + |_, _ -> UnifFailure (i,(* Maybe improve: *) NotSameHead) + in + if Reductionops.Stack.compare_shape sk1 sk2 then + ise_stack2 evd (List.rev sk1) (List.rev sk2) + else UnifFailure (evd, (* Dummy *) NotSameHead) + +(* Add equality constraints for covariant/invariant positions. For + irrelevant positions, unify universes when flexible. *) +let compare_cumulative_instances evd variances u u' = + match Evarutil.compare_cumulative_instances CONV variances u u' evd with + | Inl evd -> + Success evd + | Inr p -> UnifFailure (evd, UnifUnivInconsistency p) + +let conv_fun f flags on_types = + let typefn env evd pbty term1 term2 = + let flags = { (default_flags env) with + with_cs = flags.with_cs; + frozen_evars = flags.frozen_evars } + in f flags env evd pbty term1 term2 + in + let termfn env evd pbty term1 term2 = + f flags env evd pbty term1 term2 + in + match on_types with + | TypeUnification -> typefn + | TermUnification -> termfn + +let rec evar_conv_x flags env evd pbty term1 term2 = + let term1 = whd_head_evar evd term1 in + let term2 = whd_head_evar evd term2 in + (* 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. + Note: incomplete heuristic... *) + let ground_test = + if is_ground_term evd term1 && is_ground_term evd term2 then ( + let e = + match infer_conv ~catch_incon:false ~pb:pbty ~ts:flags.closed_ts env evd term1 term2 with + | Some evd -> Success evd + | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)) + | exception Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) + in + match e with + | UnifFailure (evd, e) when not (is_ground_env evd env) -> None + | _ -> Some e) + else None + in + match ground_test with + | Some result -> result + | None -> + (* Until pattern-unification is used consistently, use nohdbeta to not + destroy beta-redexes that can be used for 1st-order unification *) + let term1 = apprec_nohdbeta flags env evd term1 in + let term2 = apprec_nohdbeta flags env evd term2 in + let default () = + evar_eqappr_x flags env evd pbty + (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) + in + begin match EConstr.kind evd term1, EConstr.kind evd term2 with + | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem true pbty,ev,term2) with + | UnifFailure (_,(OccurCheck _ | NotClean _)) -> + (* Eta-expansion might apply *) + (* OccurCheck: eta-expansion could solve + ?X = {| foo := ?X.(foo) |} + NotClean: pruning in solve_simple_eqn is incomplete wrt + Miller patterns *) + default () + | x -> x) + | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem false pbty,ev,term1) with + | UnifFailure (_, (OccurCheck _ | NotClean _)) -> + (* OccurCheck: eta-expansion could solve + ?X = {| foo := ?X.(foo) |} + NotClean: pruning in solve_simple_eqn is incomplete wrt + Miller patterns *) + default () + | x -> x) + | _ -> default () + end + +and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty + ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = + let quick_fail i = (* not costly, loses info *) + UnifFailure (i, NotSameHead) + in + let miller_pfenning on_left fallback ev lF tM evd = + match is_unification_pattern_evar env evd ev lF tM with + | None -> fallback () + | Some l1' -> (* Miller-Pfenning's patterns unification *) + let t2 = tM in + let t2 = solve_pattern_eqn env evd l1' t2 in + solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem on_left pbty,ev,t2) + in + let consume_stack on_left (termF,skF) (termO,skO) evd = + let switch f a b = if on_left then f a b else f b a in + let not_only_app = Stack.not_purely_applicative skO in + match switch (ise_stack2 not_only_app env evd (evar_conv_x flags)) skF skO with + |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) -> + switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) -> + switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + |None, Success i' -> switch (evar_conv_x flags env i' pbty) termF termO + |_, (UnifFailure _ as x) -> x + |Some _, _ -> UnifFailure (evd,NotSameArgSize) in + let eta env evd onleft sk term sk' term' = + assert (match sk with [] -> true | _ -> false); + let (na,c1,c'1) = destLambda evd term in + let c = nf_evar evd c1 in + let env' = push_rel (RelDecl.LocalAssum (na,c)) env in + let out1 = whd_betaiota_deltazeta_for_iota_state + flags.open_ts env' evd Cst_stack.empty (c'1, Stack.empty) in + let out2 = whd_nored_state evd + (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), + Cst_stack.empty in + if onleft then evar_eqappr_x flags env' evd CONV out1 out2 + else evar_eqappr_x flags env' evd CONV out2 out1 + in + let rigids env evd sk term sk' term' = + let check_strict evd u u' = + let cstrs = Univ.enforce_eq_instances u u' Univ.Constraint.empty in + try Success (Evd.add_constraints evd cstrs) + with Univ.UniverseInconsistency p -> UnifFailure (evd, UnifUnivInconsistency p) + in + let compare_heads evd = + match EConstr.kind evd term, EConstr.kind evd term' with + | Const (c, u), Const (c', u') when Constant.equal c c' -> + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + check_strict evd u u' + | Const _, Const _ -> UnifFailure (evd, NotSameHead) + | Ind ((mi,i) as ind , u), Ind (ind', u') when Names.eq_ind ind ind' -> + if EInstance.is_empty u && EInstance.is_empty u' then Success evd + else + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + let mind = Environ.lookup_mind mi env in + let open Declarations in + begin match mind.mind_variance with + | None -> check_strict evd u u' + | Some variances -> + let nparamsaplied = Stack.args_size sk in + let nparamsaplied' = Stack.args_size sk' in + let needed = Reduction.inductive_cumulativity_arguments (mind,i) in + if not (Int.equal nparamsaplied needed && Int.equal nparamsaplied' needed) + then check_strict evd u u' + else + compare_cumulative_instances evd variances u u' + end + | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) + | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') + when Names.eq_constructor cons cons' -> + if EInstance.is_empty u && EInstance.is_empty u' then Success evd + else + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + let mind = Environ.lookup_mind mi env in + let open Declarations in + begin match mind.mind_variance with + | None -> check_strict evd u u' + | Some variances -> + let nparamsaplied = Stack.args_size sk in + let nparamsaplied' = Stack.args_size sk' in + let needed = Reduction.constructor_cumulativity_arguments (mind,ind,ctor) in + if not (Int.equal nparamsaplied needed && Int.equal nparamsaplied' needed) + then check_strict evd u u' + else + Success (compare_constructor_instances evd u u') + end + | Construct _, Construct _ -> UnifFailure (evd, NotSameHead) + | _, _ -> anomaly (Pp.str "") + in + ise_and evd [(fun i -> + try compare_heads i + with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk sk')] + in + let consume on_left (_, skF as apprF) (_,skM as apprM) i = + if not (Stack.is_empty skF && Stack.is_empty skM) then + consume_stack on_left apprF apprM i + else quick_fail i + in + let miller on_left ev (termF,skF as apprF) (termM, skM as apprM) i = + let switch f a b = if on_left then f a b else f b a in + let not_only_app = Stack.not_purely_applicative skM in + match Stack.list_of_app_stack skF with + | None -> quick_fail evd + | Some lF -> + let tM = Stack.zip evd apprM in + miller_pfenning on_left + (fun () -> if not_only_app then (* Postpone the use of an heuristic *) + switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM + else quick_fail i) + ev lF tM i + in + let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let switch f a b = if on_left then f a b else f b a in + let delta i = + switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i cstsM (vM,skM)) + in + let default i = ise_try i [miller on_left ev apprF apprM; + consume on_left apprF apprM; + delta] + in + match EConstr.kind evd termM with + | Proj (p, c) when not (Stack.is_empty skF) -> + (* Might be ?X args = p.c args', and we have to eta-expand the + primitive projection if |args| >= |args'|+1. *) + let nargsF = Stack.args_size skF and nargsM = Stack.args_size skM in + begin + (* ?X argsF' ~= (p.c ..) argsM' -> ?X ~= (p.c ..), no need to expand *) + if nargsF <= nargsM then default evd + else + let f = + try + let termM' = Retyping.expand_projection env evd p c [] in + let apprM', cstsM' = + whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd cstsM (termM',skM) + in + let delta' i = + switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) (apprM',cstsM') + in + fun i -> ise_try i [miller on_left ev apprF apprM'; + consume on_left apprF apprM'; delta'] + with Retyping.RetypeError _ -> + (* Happens thanks to w_unify building ill-typed terms *) + default + in f evd + end + | _ -> default evd + in + let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) = + let switch f a b = if on_left then f a b else f b a in + let eta evd = + match EConstr.kind evd termR with + | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> + eta env evd false skR termR skF termF + | Construct u -> eta_constructor flags env evd skR u skF termF + | _ -> UnifFailure (evd,NotSameHead) + in + match Stack.list_of_app_stack skF with + | None -> + ise_try evd [consume_stack on_left apprF apprR; eta] + | Some lF -> + let tR = Stack.zip evd apprR in + miller_pfenning on_left + (fun () -> + ise_try evd + [eta;(* Postpone the use of an heuristic *) + (fun i -> + if not (occur_rigidly flags env i ev tR) then + let i,tF = + if isRel i tR || isVar i tR then + (* Optimization so as to generate candidates *) + let i,ev = evar_absorb_arguments env i ev lF in + i,mkEvar ev + else + i,Stack.zip evd apprF in + switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) + tF tR + else + UnifFailure (evd,OccurCheck (fst ev,tR)))]) + ev lF tR evd + in + let first_order env i t1 t2 sk1 sk2 = + (* Try first-order unification *) + match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with + | None, Success i' -> + (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) + (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) + let ev1' = whd_evar i' t1 in + if isEvar i' ev1' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem true pbty,destEvar i' ev1',term2) + else + evar_eqappr_x flags env evd pbty + ((ev1', sk1), csts1) ((term2, sk2), csts2) + | Some (r,[]), Success i' -> + (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) + (* we now unify r[?ev1] and ?ev2 *) + let ev2' = whd_evar i' t2 in + if isEvar i' ev2' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) + else + evar_eqappr_x flags env evd pbty + ((ev2', sk1), csts1) ((term2, sk2), csts2) + | Some ([],r), Success i' -> + (* Symmetrically *) + (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) + (* we now unify ?ev1 and r[?ev2] *) + let ev1' = whd_evar i' t1 in + if isEvar i' ev1' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) + else evar_eqappr_x flags env evd pbty + ((ev1', sk1), csts1) ((term2, sk2), csts2) + | None, (UnifFailure _ as x) -> + (* sk1 and sk2 have no common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true (destEvar evd t1) appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false (destEvar evd t2) appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *) + x + | Some _, Success _ -> + (* sk1 and sk2 have a common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true (destEvar evd t1) appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false (destEvar evd t2) appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) + UnifFailure (i,NotSameArgSize) + | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") + in + let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in + (* Evar must be undefined since we have flushed evars *) + let () = if !debug_unification then + let open Pp in + Feedback.msg_notice (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in + match (flex_kind_of_term flags env evd term1 sk1, + flex_kind_of_term flags env evd term2 sk2) with + | Flexible (sp1,al1), Flexible (sp2,al2) -> + (* sk1[?ev1] =? sk2[?ev2] *) + let f1 i = first_order env i term1 term2 sk1 sk2 + and f2 i = + if Evar.equal sp1 sp2 then + match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with + |None, Success i' -> + Success (solve_refl (fun flags p env i pbty a1 a2 -> + let flags = + match p with + | TypeUnification -> default_flags env + | TermUnification -> flags + in + is_success (evar_conv_x flags env i pbty a1 a2)) flags + env i' (position_problem true pbty) sp1 al1 al2) + |_, (UnifFailure _ as x) -> x + |Some _, _ -> UnifFailure (i,NotSameArgSize) + else UnifFailure (i,NotSameHead) + and f3 i = miller true (sp1,al1) appr1 appr2 i + and f4 i = miller false (sp2,al2) appr2 appr1 i + and f5 i = + (* We ensure failure of consuming the stacks does not + propagate an error about unification of the stacks while + the heads themselves cannot be unified, so we return + NotSameHead. *) + match consume true appr1 appr2 i with + | Success _ as x -> x + | UnifFailure _ -> quick_fail i + in + ise_try evd [f1; f2; f3; f4; f5] + + | Flexible ev1, MaybeFlexible v2 -> + flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + + | MaybeFlexible v1, Flexible ev2 -> + flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + + | MaybeFlexible v1, MaybeFlexible v2 -> begin + match EConstr.kind evd term1, EConstr.kind evd term2 with + | LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) -> + let f1 i = (* FO *) + ise_and i + [(fun i -> ise_try i + [(fun i -> evar_conv_x flags env i CUMUL t1 t2); + (fun i -> evar_conv_x flags env i CUMUL t2 t1)]); + (fun i -> evar_conv_x flags env i CONV b1 b2); + (fun i -> + let b = nf_evar i b1 in + let t = nf_evar i t1 in + let na = Nameops.Name.pick_annot na1 na2 in + evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] + and f2 i = + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + in evar_eqappr_x flags env i pbty out1 out2 + in + ise_try evd [f1; f2] + + | Proj (p, c), Proj (p', c') when Projection.repr_equal p p' -> + let f1 i = + ise_and i + [(fun i -> evar_conv_x flags env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] + and f2 i = + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + in evar_eqappr_x flags env i pbty out1 out2 + in + ise_try evd [f1; f2] + + (* Catch the p.c ~= p c' cases *) + | Proj (p,c), Const (p',u) when Constant.equal (Projection.constant p) p' -> + let res = + try Some (destApp evd (Retyping.expand_projection env evd p c [])) + with Retyping.RetypeError _ -> None + in + (match res with + | Some (f1,args1) -> + evar_eqappr_x flags env evd pbty ((f1,Stack.append_app args1 sk1),csts1) + (appr2,csts2) + | None -> UnifFailure (evd,NotSameHead)) + + | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> + let res = + try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) + with Retyping.RetypeError _ -> None + in + (match res with + | Some (f2,args2) -> + evar_eqappr_x flags env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) + | None -> UnifFailure (evd,NotSameHead)) + + | _, _ -> + let f1 i = + (* Gather the universe constraints that would make term1 and term2 equal. + If these only involve unifications of flexible universes to other universes, + allow this identification (first-order unification of universes). Otherwise + fallback to unfolding. + *) + let univs = EConstr.eq_constr_universes env evd term1 term2 in + match univs with + | Some univs -> + ise_and i [(fun i -> + try Success (Evd.add_universe_constraints i univs) + with UniversesDiffer -> UnifFailure (i,NotSameHead) + | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] + | None -> + UnifFailure (i,NotSameHead) + and f2 i = + (try + if not flags.with_cs then raise Not_found + else conv_record flags env i + (try check_conv_record env i appr1 appr2 + with Not_found -> check_conv_record env i appr2 appr1) + with Not_found -> UnifFailure (i,NoCanonicalStructure)) + and f3 i = + (* heuristic: unfold second argument first, exception made + if the first argument is a beta-redex (expand a constant + only if necessary) or the second argument is potentially + usable as a canonical projection or canonical value *) + let rec is_unnamed (hd, args) = match EConstr.kind i hd with + | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _) -> + Stack.not_purely_applicative args + | (CoFix _|Meta _|Rel _)-> true + | Evar _ -> Stack.not_purely_applicative args + (* false (* immediate solution without Canon Struct *)*) + | Lambda _ -> assert (match args with [] -> true | _ -> false); true + | LetIn (_,b,_,c) -> is_unnamed + (fst (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i Cst_stack.empty (subst1 b c, args))) + | Fix _ -> true (* Partially applied fix can be the result of a whd call *) + | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args + | Case _ | App _| Cast _ -> assert false in + let rhs_is_stuck_and_unnamed () = + let applicative_stack = fst (Stack.strip_app sk2) in + is_unnamed + (fst (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i Cst_stack.empty (v2, applicative_stack))) in + let rhs_is_already_stuck = + rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in + + if (EConstr.isLambda i term1 || rhs_is_already_stuck) + && (not (Stack.not_purely_applicative sk1)) then + evar_eqappr_x ~rhs_is_already_stuck flags env i pbty + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + (appr2,csts2) + else + evar_eqappr_x flags env i pbty (appr1,csts1) + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + in + ise_try evd [f1; f2; f3] + end + + | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> + let (na1,c1,c'1) = EConstr.destLambda evd term1 in + let (na2,c2,c'2) = EConstr.destLambda evd term2 in + ise_and evd + [(fun i -> evar_conv_x flags env i CONV c1 c2); + (fun i -> + let c = nf_evar i c1 in + let na = Nameops.Name.pick_annot na1 na2 in + evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2); + (* When in modulo_betaiota = false case, lambda's are not reduced *) + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] + + | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 + | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 + + | MaybeFlexible v1, Rigid -> + let f3 i = + (try + if not flags.with_cs then raise Not_found + else conv_record flags env i (check_conv_record env i appr1 appr2) + with Not_found -> UnifFailure (i,NoCanonicalStructure)) + and f4 i = + evar_eqappr_x flags env i pbty + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + (appr2,csts2) + in + ise_try evd [f3; f4] + + | Rigid, MaybeFlexible v2 -> + let f3 i = + (try + if not flags.with_cs then raise Not_found + else conv_record flags env i (check_conv_record env i appr2 appr1) + with Not_found -> UnifFailure (i,NoCanonicalStructure)) + and f4 i = + evar_eqappr_x flags env i pbty (appr1,csts1) + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + in + ise_try evd [f3; f4] + + (* Eta-expansion *) + | Rigid, _ when isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> + eta env evd true sk1 term1 sk2 term2 + + | _, Rigid when isLambda evd term2 && (* if ever ill-typed: *) List.is_empty sk2 -> + eta env evd false sk2 term2 sk1 term1 + + | Rigid, Rigid -> begin + match EConstr.kind evd term1, EConstr.kind evd term2 with + + | Sort s1, Sort s2 when app_empty -> + (try + let s1 = ESorts.kind evd s1 in + let s2 = ESorts.kind evd s2 in + let evd' = + if pbty == CONV + then Evd.set_eq_sort env evd s1 s2 + else Evd.set_leq_sort env evd s1 s2 + in Success evd' + with Univ.UniverseInconsistency p -> + UnifFailure (evd,UnifUnivInconsistency p) + | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead)) + + | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> + ise_and evd + [(fun i -> evar_conv_x flags env i CONV c1 c2); + (fun i -> + let c = nf_evar i c1 in + let na = Nameops.Name.pick_annot n1 n2 in + evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] + + | Rel x1, Rel x2 -> + if Int.equal x1 x2 then + exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 + else UnifFailure (evd,NotSameHead) + + | Var var1, Var var2 -> + if Id.equal var1 var2 then + exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 + else UnifFailure (evd,NotSameHead) + + | Const _, Const _ + | Ind _, Ind _ + | Construct _, Construct _ + | Int _, Int _ -> + rigids env evd sk1 term1 sk2 term2 + + | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) + if Evar.equal sp1 sp2 then + match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with + |None, Success i' -> + ise_array2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 + |_, (UnifFailure _ as x) -> x + |Some _, _ -> UnifFailure (evd,NotSameArgSize) + else UnifFailure (evd,NotSameHead) + + | Construct u, _ -> + eta_constructor flags env evd sk1 u sk2 term2 + + | _, Construct u -> + eta_constructor flags env evd sk2 u sk1 term1 + + | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) + if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then + ise_and evd [ + (fun i -> ise_array2 i (fun i' -> evar_conv_x flags env i' CONV) tys1 tys2); + (fun i -> ise_array2 i (fun i' -> evar_conv_x flags (push_rec_types recdef1 env) i' CONV) bds1 bds2); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] + else UnifFailure (evd, NotSameHead) + + | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> + if Int.equal i1 i2 then + ise_and evd + [(fun i -> ise_array2 i + (fun i -> evar_conv_x flags env i CONV) tys1 tys2); + (fun i -> ise_array2 i + (fun i -> evar_conv_x flags (push_rec_types recdef1 env) i CONV) + bds1 bds2); + (fun i -> exact_ise_stack2 env i + (evar_conv_x flags) sk1 sk2)] + else UnifFailure (evd,NotSameHead) + + | (Meta _, _) | (_, Meta _) -> + begin match ise_stack2 true env evd (evar_conv_x flags) sk1 sk2 with + |_, (UnifFailure _ as x) -> x + |None, Success i' -> evar_conv_x flags env i' CONV term1 term2 + |Some (sk1',sk2'), Success i' -> evar_conv_x flags env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) + end + + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _), _ -> + UnifFailure (evd,NotSameHead) + | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _) -> + UnifFailure (evd,NotSameHead) + | Case _, _ -> UnifFailure (evd,NotSameHead) + | Proj _, _ -> UnifFailure (evd,NotSameHead) + | (App _ | Cast _), _ -> assert false + | LetIn _, _ -> assert false + end + +and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = + (* Tries to unify the states + + (proji params1 c1 | sk1) = (proji params2 (c (?xs:bs)) | sk2) + + and the terms + + h us = h2 us2 + + where + + c = the constant for the canonical structure (i.e. some term of the form + fun (xs:bs) => Build_R params v1 .. vi-1 (h us) vi+1 .. vn) + bs = the types of the parameters of the canonical structure + c1 = the main argument of the canonical projection + sk1, sk2 = the surrounding stacks of the conversion problem + params1, params2 = the params of the projection (empty if a primitive proj) + + knowing that + + (proji params1 c1 | sk1) = (h2 us2 | sk2) + + had to be initially resolved + *) + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + if Reductionops.Stack.compare_shape sk1 sk2 then + let (evd',ks,_,test) = + List.fold_left + (fun (i,ks,m,test) b -> + if match n with Some n -> Int.equal m n | None -> false then + let ty = Retyping.get_type_of env i t2 in + let test i = evar_conv_x flags env i CUMUL ty (substl ks b) in + (i,t2::ks, m-1, test) + else + let dloc = Loc.tag Evar_kinds.InternalHole in + let (i', ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in + (i', ev :: ks, m - 1,test)) + (evd,[],List.length bs,fun i -> Success i) bs + in + let app = mkApp (c, Array.rev_of_list ks) in + ise_and evd' + [(fun i -> + exact_ise_stack2 env i + (fun env' i' cpb x1 x -> evar_conv_x flags env' i' cpb x1 (substl ks x)) + params1 params); + (fun i -> + exact_ise_stack2 env i + (fun env' i' cpb u1 u -> evar_conv_x flags env' i' cpb u1 (substl ks u)) + us2 us); + (fun i -> evar_conv_x flags env i CONV c1 app); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2); + test; + (fun i -> evar_conv_x flags env i CONV h2 + (fst (decompose_app_vect i (substl ks h))))] + else UnifFailure(evd,(*dummy*)NotSameHead) + +and eta_constructor flags env evd sk1 ((ind, i), u) sk2 term2 = + let open Declarations in + let mib = lookup_mind (fst ind) env in + match get_projections env ind with + | Some projs when mib.mind_finite == BiFinite -> + let pars = mib.mind_nparams in + (try + let l1' = Stack.tail pars sk1 in + let l2' = + let term = Stack.zip evd (term2,sk2) in + List.map (fun p -> EConstr.mkProj (Projection.make p false, term)) (Array.to_list projs) + in + exact_ise_stack2 env evd (evar_conv_x { flags with with_cs = false}) l1' + (Stack.append_app_list l2' Stack.empty) + with + | Invalid_argument _ -> + (* Stack.tail: partially applied constructor *) + UnifFailure(evd,NotSameHead)) + | _ -> UnifFailure (evd,NotSameHead) + +let evar_conv_x flags = evar_conv_x flags + +let evar_unify = conv_fun evar_conv_x + +(* Profiling *) +let evar_conv_x = + if Flags.profile then + let evar_conv_xkey = CProfile.declare_profile "evar_conv_x" in + CProfile.profile6 evar_conv_xkey evar_conv_x + else evar_conv_x + +let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x () + +let evar_conv_x flags = Hook.get evar_conv_hook_get flags + +let set_evar_conv f = Hook.set evar_conv_hook_set f + + +(* We assume here |l1| <= |l2| *) + +let first_order_unification flags env evd (ev1,l1) (term2,l2) = + let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in + ise_and evd + (* First compare extra args for better failure message *) + [(fun i -> ise_array2 i (fun i -> evar_conv_x flags env i CONV) rest2 l1); + (fun i -> + (* Then instantiate evar unless already done by unifying args *) + let t2 = mkApp(term2,deb2) in + if is_defined i (fst ev1) then + evar_conv_x flags env i CONV t2 (mkEvar ev1) + else + solve_simple_eqn ~choose:true ~imitate_defs:false + evar_unify flags env i (None,ev1,t2))] + +let choose_less_dependent_instance evk evd term args = + let evi = Evd.find_undefined evd evk in + let subst = make_pure_subst evi args in + let subst' = List.filter (fun (id,c) -> EConstr.eq_constr evd c term) subst in + match subst' with + | [] -> None + | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) + +type occurrence_match_test = + env -> evar_map -> constr -> + env -> evar_map -> int -> constr -> constr -> bool * evar_map + +type occurrence_selection = + | AtOccurrences of Locus.occurrences + | Unspecified of Abstraction.abstraction + +type occurrences_selection = + occurrence_match_test * occurrence_selection list + +let default_occurrence_selection = Unspecified Abstraction.Imitate + +let default_occurrence_test ~frozen_evars ts _ origsigma _ env sigma _ c pat = + let flags = { (default_flags_of ~subterm_ts:ts ts) with frozen_evars } in + match evar_conv_x flags env sigma CONV c pat with + | Success sigma -> true, sigma + | UnifFailure _ -> false, sigma + +let default_occurrences_selection ?(frozen_evars=Evar.Set.empty) ts n = + (default_occurrence_test ~frozen_evars ts, + List.init n (fun _ -> default_occurrence_selection)) + +let apply_on_subterm env evd fixedref f test c t = + let test = test env evd c in + let prc env evd = Termops.Internal.print_constr_env env evd in + let evdref = ref evd in + let rec applyrec (env,(k,c) as acc) t = + if Evar.Set.exists (fun fixed -> occur_evar !evdref fixed t) !fixedref then + match EConstr.kind !evdref t with + | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t + | _ -> map_constr_with_binders_left_to_right !evdref + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) + applyrec acc t + else + (if !debug_ho_unification then + Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); + let b, evd = + try test env !evdref k c t + with e when CErrors.noncritical e -> assert false in + if b then (if !debug_ho_unification then Feedback.msg_debug (Pp.str "succeeded"); + let evd', t' = f !evdref k t in + evdref := evd'; t') + else ( + if !debug_ho_unification then Feedback.msg_debug (Pp.str "failed"); + map_constr_with_binders_left_to_right !evdref + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) + applyrec acc t)) + in + let t' = applyrec (env,(0,c)) t in + !evdref, t' + +let filter_possible_projections evd c ty ctxt args = + (* Since args in the types will be replaced by holes, we count the + fv of args to have a well-typed filter; don't know how necessary + it is however to have a well-typed filter here *) + let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in + let fv2 = collect_vars evd (mkApp (c,args)) in + let len = Array.length args in + let tyvars = collect_vars evd ty in + List.map_i (fun i decl -> + let () = assert (i < len) in + let a = Array.unsafe_get args i in + (match decl with + | NamedDecl.LocalAssum _ -> false + | NamedDecl.LocalDef (_,c,_) -> not (isRel evd c || isVar evd c)) || + a == c || + (* Here we make an approximation, for instance, we could also be *) + (* interested in finding a term u convertible to c such that a occurs *) + (* in u *) + isRel evd a && Int.Set.mem (destRel evd a) fv1 || + isVar evd a && Id.Set.mem (destVar evd a) fv2 || + Id.Set.mem (NamedDecl.get_id decl) tyvars) + 0 ctxt + +let solve_evars = ref (fun _ -> failwith "solve_evars not installed") +let set_solve_evars f = solve_evars := f + +(* We solve the problem env_rhs |- ?e[u1..un] = rhs knowing + * x1:T1 .. xn:Tn |- ev : ty + * by looking for a maximal well-typed abtraction over u1..un in rhs + * + * We first build C[e11..e1p1,..,en1..enpn] obtained from rhs by replacing + * all occurrences of u1..un by evars eij of type Ti' where itself Ti' has + * been obtained from the type of ui by also replacing all occurrences of + * u1..ui-1 by evars. + * + * Then, we use typing to infer the relations between the different + * occurrences. If some occurrence is still unconstrained after typing, + * we instantiate successively the unresolved occurrences of un by xn, + * of un-1 by xn-1, etc [the idea comes from Chung-Kil Hur, that he + * used for his Heq plugin; extensions to several arguments based on a + * proposition from Dan Grayson] + *) + +let check_selected_occs env sigma c occ occs = + let notfound = + match occs with + | AtOccurrences occs -> + (match occs with + | Locus.AtLeastOneOccurrence -> occ == 1 + | Locus.AllOccurrences -> false + | Locus.AllOccurrencesBut l -> List.last l > occ + | Locus.OnlyOccurrences l -> List.last l > occ + | Locus.NoOccurrences -> false) + | Unspecified abstract -> false + in if notfound then + raise (PretypeError (env,sigma,NoOccurrenceFound (c,None))) + else () + +exception TypingFailed of evar_map + +let set_of_evctx l = + List.fold_left (fun s decl -> Id.Set.add (NamedDecl.get_id decl) s) Id.Set.empty l + +(** Weaken the existentials so that they can be typed in sign and raise + an error if the term otherwise mentions variables not bound in sign. *) +let thin_evars env sigma sign c = + let evdref = ref sigma in + let ctx = set_of_evctx sign in + let rec applyrec (env,acc) t = + match kind sigma t with + | Evar (ev, args) -> + let evi = Evd.find_undefined sigma ev in + let filter = Array.map (fun c -> Id.Set.subset (collect_vars sigma c) ctx) args in + let filter = Filter.make (Array.to_list filter) in + let candidates = Option.map (List.map EConstr.of_constr) (evar_candidates evi) in + let evd, ev = restrict_evar !evdref ev filter candidates in + evdref := evd; whd_evar !evdref t + | Var id -> + if not (Id.Set.mem id ctx) then raise (TypingFailed sigma) + else t + | _ -> + map_constr_with_binders_left_to_right !evdref + (fun d (env,acc) -> (push_rel d env, acc+1)) + applyrec (env,acc) t + in + let c' = applyrec (env,0) c in + (!evdref, c') + +let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = + try + let evi = Evd.find_undefined evd evk in + let evi = nf_evar_info evd evi in + let env_evar_unf = evar_env evi in + let env_evar = evar_filtered_env evi in + let sign = named_context_val env_evar in + let ctxt = evar_filtered_context evi in + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); + Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); + let args = Array.map (nf_evar evd) args in + let vars = List.map NamedDecl.get_id ctxt in + let argsubst = List.map2 (fun id c -> (id, c)) vars (Array.to_list args) in + let instance = List.map mkVar vars in + let rhs = nf_evar evd rhs in + if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); + (* Ensure that any progress made by Typing.e_solve_evars will not contradict + the solution we are trying to build here by adding the problem as a constraint. *) + let evd = Evarutil.add_unification_pb (CONV,env_rhs,mkEvar (evk,args),rhs) evd in + let prc env evd c = Termops.Internal.print_constr_env env evd c in + let rec make_subst = function + | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> + begin match occs with + | AtOccurrences loc when not (Locusops.is_all_occurrences loc) -> + user_err Pp.(str "Cannot force abstraction on identity instance.") + | _ -> + make_subst (ctxt',l,occsl) + end + | decl'::ctxt', c::l, occs::occsl -> + let id = NamedDecl.get_annot decl' in + let t = NamedDecl.get_type decl' in + let evs = ref [] in + let c = nf_evar evd c in + (* ty is in env_rhs now *) + let ty = replace_vars argsubst t in + let filter' = filter_possible_projections evd c (nf_evar evd ty) ctxt args in + (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) + | _, _, [] -> [] + | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") + in + let fixed = ref Evar.Set.empty in + let rec set_holes env_rhs evd rhs = function + | (id,idty,c,cty,evsref,filter,occs)::subst -> + let c = nf_evar evd c in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"set holes for: " ++ + prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ + prc env_rhs evd c ++ str" in " ++ + prc env_rhs evd rhs); + let occ = ref 1 in + let set_var evd k inst = + let oc = !occ in + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"Found one occurrence"); + Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); + incr occ; + match occs with + | AtOccurrences occs -> + if Locusops.is_selected oc occs then evd, mkVar id.binder_name + else evd, inst + | Unspecified prefer_abstraction -> + let evd, evty = set_holes env_rhs evd cty subst in + let evty = nf_evar evd evty in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ + str" of type: " ++ prc env_evar evd evty ++ + str " for " ++ prc env_rhs evd c); + let instance = Filter.filter_list filter instance in + (* Allow any type lower than the variable's type as the + abstracted subterm might have a smaller type, which could be + crucial to make the surrounding context typecheck. *) + let evd, evty = + if isArity evd evty then + refresh_universes ~status:Evd.univ_flexible (Some true) + env_evar_unf evd evty + else evd, evty in + let (evd, ev) = new_evar_instance sign evd evty ~filter instance in + let evk = fst (destEvar evd ev) in + evsref := (evk,evty,inst,prefer_abstraction)::!evsref; + fixed := Evar.Set.add evk !fixed; + evd, ev + in + let evd, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); + let () = check_selected_occs env_rhs evd c !occ occs in + let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in + set_holes env_rhs' evd rhs' subst + | [] -> evd, rhs in + + let subst = make_subst (ctxt,Array.to_list args,argoccs) in + + let evd, rhs' = set_holes env_rhs evd rhs subst in + let rhs' = nf_evar evd rhs' in + (* Thin evars making the term typable in env_evar *) + let evd, rhs' = thin_evars env_evar evd ctxt rhs' in + (* We instantiate the evars of which the value is forced by typing *) + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); + Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + let evd,rhs' = + try !solve_evars env_evar evd rhs' + with e when Pretype_errors.precatchable_exception e -> + (* Could not revert all subterms *) + raise (TypingFailed evd) in + let rhs' = nf_evar evd rhs' in + (* We instantiate the evars of which the value is forced by typing *) + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); + Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + + let rec abstract_free_holes evd = function + | (id,idty,c,cty,evsref,_,_)::l -> + let id = id.binder_name in + let c = nf_evar evd c in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracting: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c); + let rec force_instantiation evd = function + | (evk,evty,inst,abstract)::evs -> + let evk = Option.default evk (Evarutil.advance evd evk) in + let evd = + if is_undefined evd evk then + (* We try abstraction or concretisation for *) + (* this unconstrained occurrence *) + (* and we use typing to propagate this instantiation *) + (* We avoid making an arbitrary choice by leaving candidates *) + (* if both can work *) + let evi = Evd.find_undefined evd evk in + let vid = mkVar id in + let candidates = [inst; vid] in + try + let evd, ev = Evarutil.restrict_evar evd evk (Evd.evar_filter evi) (Some candidates) in + let evi = Evd.find evd ev in + (match evar_candidates evi with + | Some [t] -> + if not (noccur_evar env_rhs evd ev (EConstr.of_constr t)) then + raise (TypingFailed evd); + instantiate_evar evar_unify flags evd ev (EConstr.of_constr t) + | Some l when abstract = Abstraction.Abstract && + List.exists (fun c -> isVarId evd id (EConstr.of_constr c)) l -> + instantiate_evar evar_unify flags evd ev vid + | _ -> evd) + with e -> user_err (Pp.str "Cannot find an instance") + else + ((if !debug_ho_unification then + let evi = Evd.find evd evk in + let env = Evd.evar_env evi in + Feedback.msg_debug Pp.(str"evar is defined: " ++ + int (Evar.repr evk) ++ spc () ++ + prc env evd (match evar_body evi with Evar_defined c -> c + | Evar_empty -> assert false))); + evd) + in force_instantiation evd evs + | [] -> abstract_free_holes evd l + in force_instantiation evd !evsref + | [] -> + if Evd.is_defined evd evk then + (* Can happen due to dependencies: instantiating evars in the arguments of evk might + instantiate evk itself. *) + (if !debug_ho_unification then + begin + let evi = Evd.find evd evk in + let evenv = evar_env evi in + let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in + Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) + end; + evd) + else + try + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let rhs' = nf_evar evd rhs' in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ + prc evenv evd rhs'); + (* solve_evars is not commuting with nf_evar, because restricting + an evar might provide a more specific type. *) + let evd, _ = !solve_evars evenv evd rhs' in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); + let flags = default_flags_of TransparentState.full in + Evarsolve.instantiate_evar evar_unify flags evd evk rhs' + with IllTypedInstance _ -> raise (TypingFailed evd) + in + let evd = abstract_free_holes evd subst in + evd, true + with TypingFailed evd -> evd, false + +let default_evar_selection flags evd (ev,args) = + let evi = Evd.find_undefined evd ev in + let rec aux args abs = + match args, abs with + | _ :: args, a :: abs -> + let spec = + if not flags.allow_K_at_toplevel then + (* [evar_absorb_arguments] puts an Abstract flag for the + toplevel binders that were absorbed. *) + let occs = + if a == Abstraction.Abstract then Locus.AtLeastOneOccurrence + else Locus.AllOccurrences + in AtOccurrences occs + else Unspecified a + in spec :: aux args abs + | l, [] -> List.map (fun _ -> default_occurrence_selection) l + | [], _ :: _ -> assert false + in aux (Array.to_list args) evi.evar_abstract_arguments + +let second_order_matching_with_args flags env evd with_ho pbty ev l t = + if with_ho then + let evd,ev = evar_absorb_arguments env evd ev (Array.to_list l) in + let argoccs = default_evar_selection flags evd ev in + let test = default_occurrence_test ~frozen_evars:flags.frozen_evars flags.subterm_ts in + let evd, b = + try second_order_matching flags env evd ev (test,argoccs) t + with PretypeError (_, _, NoOccurrenceFound _) -> evd, false + in + if b then Success evd + else + UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) + else + let pb = (pbty,env,mkApp(mkEvar ev,l),t) in + UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) + +let is_beyond_capabilities = function + | CannotSolveConstraint (pb,ProblemBeyondCapabilities) -> true + | _ -> false + +let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = + let t1 = apprec_nohdbeta flags env evd (whd_head_evar evd t1) in + let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in + let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in + let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in + let () = if !debug_unification then + let open Pp in + Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ + Termops.Internal.print_constr_env env evd t1 ++ cut () ++ + Termops.Internal.print_constr_env env evd t2 ++ cut ())) in + let app_empty = Array.is_empty l1 && Array.is_empty l2 in + match EConstr.kind evd term1, EConstr.kind evd term2 with + | Evar (evk1,args1 as ev1), (Rel _|Var _) when app_empty + && not (is_frozen flags ev1) + && List.for_all (fun a -> EConstr.eq_constr evd a term2 || isEvar evd a) + (remove_instance_local_defs evd evk1 args1) -> + (* The typical kind of constraint coming from pattern-matching return + type inference *) + (match choose_less_dependent_instance evk1 evd term2 args1 with + | Some evd -> Success evd + | None -> + let reason = ProblemBeyondCapabilities in + UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) + | (Rel _|Var _), Evar (evk2,args2 as ev2) when app_empty + && not (is_frozen flags ev2) + && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) + (remove_instance_local_defs evd evk2 args2) -> + (* The typical kind of constraint coming from pattern-matching return + type inference *) + (match choose_less_dependent_instance evk2 evd term1 args2 with + | Some evd -> Success evd + | None -> + let reason = ProblemBeyondCapabilities in + UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) + | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> + let f flags ontype env evd pbty x y = + let reds = + match ontype with + | TypeUnification -> TransparentState.full + | TermUnification -> flags.open_ts + in is_fconv ~reds pbty env evd x y + in + Success (solve_refl ~can_drop:true f flags env evd + (position_problem true pbty) evk1 args1 args2) + | Evar ev1, Evar ev2 when app_empty -> + (* solve_evar_evar handles the cases ev1 and/or ev2 are frozen *) + Success (solve_evar_evar ~force:true + (evar_define evar_unify flags ~choose:true) + evar_unify flags env evd + (position_problem true pbty) ev1 ev2) + | Evar ev1,_ when not (is_frozen flags ev1) && Array.length l1 <= Array.length l2 -> + (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) + (* and otherwise second-order matching *) + ise_try evd + [(fun evd -> first_order_unification flags env evd (ev1,l1) appr2); + (fun evd -> + second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2)] + | _,Evar ev2 when not (is_frozen flags ev2) && Array.length l2 <= Array.length l1 -> + (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) + (* and otherwise second-order matching *) + ise_try evd + [(fun evd -> first_order_unification flags env evd (ev2,l2) appr1); + (fun evd -> + second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1)] + | Evar ev1,_ when not (is_frozen flags ev1) -> + (* Try second-order pattern-matching *) + second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2 + | _,Evar ev2 when not (is_frozen flags ev2) -> + (* Try second-order pattern-matching *) + second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1 + | _ -> + (* Some head evar have been instantiated, or unknown kind of problem *) + evar_conv_x flags env evd pbty t1 t2 + +let error_cannot_unify env evd pb ?reason t1 t2 = + Pretype_errors.error_cannot_unify + ?loc:(loc_of_conv_pb evd pb) env + evd ?reason (t1, t2) + +let check_problems_are_solved env evd = + match snd (extract_all_conv_pbs evd) with + | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2 + | _ -> () + +exception MaxUndefined of (Evar.t * evar_info * EConstr.t list) + +let max_undefined_with_candidates evd = + let fold evk evi () = match evi.evar_candidates with + | None -> () + | Some l -> raise (MaxUndefined (evk, evi, l)) + in + (* [fold_right] traverses the undefined map in decreasing order of + indices. The evar with candidates of maximum index is thus the + first evar with candidates found by a [fold_right] + traversal. This has a significant impact on performance. *) + try + let () = Evar.Map.fold_right fold (Evd.undefined_map evd) () in + None + with MaxUndefined ans -> + Some ans + +let rec solve_unconstrained_evars_with_candidates flags evd = + (* max_undefined is supposed to return the most recent, hence + possibly most dependent evar *) + match max_undefined_with_candidates evd with + | None -> evd + | Some (evk,ev_info,l) -> + let rec aux = function + | [] -> user_err Pp.(str "Unsolvable existential variables.") + | a::l -> + (* In case of variables, most recent ones come first *) + try + let evd = instantiate_evar evar_unify flags evd evk a in + match reconsider_unif_constraints evar_unify flags evd with + | Success evd -> solve_unconstrained_evars_with_candidates flags evd + | UnifFailure _ -> aux l + with + | IllTypedInstance _ -> aux l + | e when Pretype_errors.precatchable_exception e -> aux l in + (* Expected invariant: most dependent solutions come first *) + (* so as to favor progress when used with the refine tactics *) + let evd = aux l in + solve_unconstrained_evars_with_candidates flags evd + +let solve_unconstrained_impossible_cases env evd = + Evd.fold_undefined (fun evk ev_info evd' -> + match ev_info.evar_source with + | loc,Evar_kinds.ImpossibleCase -> + let j, ctx = coq_unit_judge env in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in + let ty = j_type j in + let flags = default_flags env in + instantiate_evar evar_unify flags evd' evk ty + | _ -> evd') evd evd + +let solve_unif_constraints_with_heuristics env + ?(flags=default_flags env) ?(with_ho=false) evd = + let evd = solve_unconstrained_evars_with_candidates flags evd in + let rec aux evd pbs progress stuck = + match pbs with + | (pbty,env,t1,t2 as pb) :: pbs -> + (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with + | Success evd' -> + let evd' = solve_unconstrained_evars_with_candidates flags evd' in + let (evd', rest) = extract_all_conv_pbs evd' in + begin match rest with + | [] -> aux evd' pbs true stuck + | l -> + (* Unification got actually stuck, postpone *) + let reason = CannotSolveConstraint (pb,ProblemBeyondCapabilities) in + aux evd pbs progress ((pb, reason):: stuck) + end + | UnifFailure (evd,reason) -> + if is_beyond_capabilities reason then + aux evd pbs progress ((pb,reason) :: stuck) + else aux evd [] false ((pb,reason) :: stuck)) + | _ -> + if progress then aux evd (List.map fst stuck) false [] + else + match stuck with + | [] -> (* We're finished *) evd + | ((pbty,env,t1,t2 as pb), reason) :: _ -> + (* There remains stuck problems *) + Pretype_errors.error_cannot_unify ?loc:(loc_of_conv_pb evd pb) + env evd ~reason (t1, t2) + in + let (evd,pbs) = extract_all_conv_pbs evd in + let heuristic_solved_evd = aux evd pbs false [] in + check_problems_are_solved env heuristic_solved_evd; + solve_unconstrained_impossible_cases env heuristic_solved_evd + +(* Main entry points *) + +exception UnableToUnify of evar_map * unification_error + +let unify_delay ?flags env evd t1 t2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + match evar_conv_x flags env evd CONV t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) + +let unify_leq_delay ?flags env evd t1 t2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + match evar_conv_x flags env evd CUMUL t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) + +let unify ?flags ?(with_ho=true) env evd cv_pb ty1 ty2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + let res = evar_conv_x flags env evd cv_pb ty1 ty2 in + match res with + | Success evd -> + solve_unif_constraints_with_heuristics ~flags ~with_ho env evd + | UnifFailure (evd, reason) -> + raise (PretypeError (env, evd, CannotUnify (ty1, ty2, Some reason))) + +(* deprecated *) +let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = + let flags = default_flags_of ts in + match evar_conv_x flags env evd CONV t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) + +let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd = + let flags = default_flags_of ts in + match evar_conv_x flags env evd CUMUL t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) + +let make_opt = function + | Success evd -> Some evd + | UnifFailure _ -> None + +let conv env ?(ts=default_transparent_state env) evd t1 t2 = + let flags = default_flags_of ts in + make_opt(evar_conv_x flags env evd CONV t1 t2) + +let cumul env ?(ts=default_transparent_state env) evd t1 t2 = + let flags = default_flags_of ts in + make_opt(evar_conv_x flags env evd CUMUL t1 t2) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli new file mode 100644 index 0000000000..0fe47c2a48 --- /dev/null +++ b/pretyping/evarconv.mli @@ -0,0 +1,155 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open EConstr +open Environ +open Reductionops +open Evd +open Locus + +(** {4 Unification for type inference. } *) + +type unify_flags = Evarsolve.unify_flags + +(** The default subterm transparent state is no unfoldings *) +val default_flags_of : ?subterm_ts:TransparentState.t -> TransparentState.t -> unify_flags + +type unify_fun = unify_flags -> + env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result + +val conv_fun : unify_fun -> Evarsolve.unifier + +exception UnableToUnify of evar_map * Pretype_errors.unification_error + +(** {6 Main unification algorithm for type inference. } *) + +(** There are two variants for unification: one that delays constraints outside its capabilities + ([unify_delay]) and another that tries to solve such remaining constraints using + heuristics ([unify]). *) + +(** Theses functions allow to pass arbitrary flags to the unifier and can delay constraints. + In case the flags are not specified, they default to + [default_flags_of TransparentState.full] currently. + + In case of success, the two terms are hence unifiable only if the remaining constraints + can be solved or [check_problems_are_solved] is true. + + @raises UnableToUnify in case the two terms do not unify *) + +val unify_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map +val unify_leq_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map + +(** returns exception UnableToUnify with best known evar_map if not unifiable *) +val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map +[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] +val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map +[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] +(** The same function resolving evars by side-effect and + catching the exception *) + +val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] +val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] + +(** This function also calls [solve_unif_constraints_with_heuristics] to resolve any remaining + constraints. In case of success the two terms are unified without condition. + + The with_ho option tells if higher-order unification should be tried to resolve the + constraints. + + @raises a PretypeError if it cannot unify *) +val unify : ?flags:unify_flags -> ?with_ho:bool -> + env -> evar_map -> conv_pb -> constr -> constr -> evar_map + +(** {6 Unification heuristics. } *) + +(** Try heuristics to solve pending unification problems and to solve + evars with candidates. + + The with_ho option tells if higher-order unification should be tried + to resolve the constraints. + + @raises a PretypeError if it fails to resolve some problem *) + +val solve_unif_constraints_with_heuristics : + env -> ?flags:unify_flags -> ?with_ho:bool -> evar_map -> evar_map + +(** Check all pending unification problems are solved and raise a + PretypeError otherwise *) + +val check_problems_are_solved : env -> evar_map -> unit + +(** Check if a canonical structure is applicable *) + +val check_conv_record : env -> evar_map -> + state -> state -> + Univ.ContextSet.t * (constr * constr) + * constr * constr list * (constr Stack.t * constr Stack.t) * + (constr Stack.t * constr Stack.t) * + (constr Stack.t * constr Stack.t) * constr * + (int option * constr) + +(** Try to solve problems of the form ?x[args] = c by second-order + matching, using typing to select occurrences *) + +type occurrence_match_test = + env -> evar_map -> constr -> (* Used to precompute the local tests *) + env -> evar_map -> int -> constr -> constr -> bool * evar_map + +(** When given the choice of abstracting an occurrence or leaving it, + force abstration. *) + +type occurrence_selection = + | AtOccurrences of occurrences + | Unspecified of Abstraction.abstraction + +(** By default, unspecified, not preferring abstraction. + This provides the most general solutions. *) +val default_occurrence_selection : occurrence_selection + +type occurrences_selection = + occurrence_match_test * occurrence_selection list + +val default_occurrence_test : frozen_evars:Evar.Set.t -> TransparentState.t -> occurrence_match_test + +(** [default_occurrence_selection n] + Gives the default test and occurrences for [n] arguments *) +val default_occurrences_selection : ?frozen_evars:Evar.Set.t (* By default, none *) -> + TransparentState.t -> int -> occurrences_selection + +val second_order_matching : unify_flags -> env -> evar_map -> + EConstr.existential -> occurrences_selection -> constr -> evar_map * bool + +(** Declare function to enforce evars resolution by using typing constraints *) + +val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit + +(** Override default [evar_conv_x] algorithm. *) +val set_evar_conv : unify_fun -> unit + +(** The default unification algorithm with evars and universes. *) +val evar_conv_x : unify_fun + +val evar_unify : Evarsolve.unifier + +(**/**) +(* For debugging *) +val evar_eqappr_x : ?rhs_is_already_stuck:bool -> unify_flags -> + env -> evar_map -> + conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> + Evarsolve.unification_result + +val occur_rigidly : Evarsolve.unify_flags -> + 'a -> Evd.evar_map -> Evar.t * 'b -> EConstr.t -> bool +(**/**) + +(** {6 Functions to deal with impossible cases } *) +val coq_unit_judge : env -> EConstr.unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml new file mode 100644 index 0000000000..a51cb22c20 --- /dev/null +++ b/pretyping/evardefine.ml @@ -0,0 +1,209 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Sorts +open Util +open Pp +open Names +open Constr +open Context +open Termops +open EConstr +open Vars +open Namegen +open Evd +open Evarutil +open Evar_kinds +open Pretype_errors + +module RelDecl = Context.Rel.Declaration + +let env_nf_evar sigma env = + let nf_evar c = nf_evar sigma c in + process_rel_context + (fun d e -> push_rel (RelDecl.map_constr nf_evar d) e) env + +let env_nf_betaiotaevar sigma env = + process_rel_context + (fun d env -> + push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota env sigma c) d) env) env + +(****************************************) +(* Operations on value/type constraints *) +(****************************************) + +type type_constraint = EConstr.types option + +type val_constraint = EConstr.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 + +let idx = Namegen.default_dependent_ident + +(* Refining an evar to a product *) + +let define_pure_evar_as_product env evd evk = + let open Context.Named.Declaration in + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let id = next_ident_away idx (Environ.ids_of_named_context_val evi.evar_hyps) in + let concl = Reductionops.whd_all evenv evd evi.evar_concl in + let s = destSort evd concl in + let evksrc = evar_source evk evd in + let src = subterm_source evk ~where:Domain evksrc in + let evd1,(dom,u1) = + new_type_evar evenv evd univ_flexible_alg ~src ~filter:(evar_filter evi) + in + let rdom = Sorts.Relevant in (* TODO relevance *) + let evd2,rng = + let newenv = push_named (LocalAssum (make_annot id rdom, dom)) evenv in + let src = subterm_source evk ~where:Codomain evksrc in + let filter = Filter.extend 1 (evar_filter evi) in + if Environ.is_impredicative_sort env (ESorts.kind evd1 s) then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar newenv evd1 concl ~src ~filter + else + let status = univ_flexible_alg in + let evd3, (rng, srng) = + new_type_evar newenv evd1 status ~src ~filter + in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let evd3 = Evd.set_leq_sort evenv evd3 (Sorts.sort_of_univ prods) (ESorts.kind evd1 s) in + evd3, rng + in + let prod = mkProd (make_annot (Name id) rdom, dom, subst_var id rng) in + let evd3 = Evd.define evk prod evd2 in + evd3,prod + +(* Refine an applied evar to a product and returns its instantiation *) + +let define_evar_as_product env evd (evk,args) = + let evd,prod = define_pure_evar_as_product env evd evk in + (* Quick way to compute the instantiation of evk with args *) + let na,dom,rng = destProd evd prod in + let evdom = mkEvar (fst (destEvar evd dom), args) in + let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evrng = mkEvar (fst (destEvar evd rng), evrngargs) in + evd, mkProd (na, evdom, evrng) + +(* Refine an evar with an abstraction + + I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where: + - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y) + or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B + with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type + - x1..xq,y:A |- ?e':B +*) + +let define_pure_evar_as_lambda env evd evk = + let open Context.Named.Declaration in + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let typ = Reductionops.whd_all evenv evd (evar_concl evi) in + let evd1,(na,dom,rng) = match EConstr.kind evd typ with + | Prod (na,dom,rng) -> (evd,(na,dom,rng)) + | Evar ev' -> let evd,typ = define_evar_as_product env evd ev' in evd,destProd evd typ + | _ -> error_not_product env evd typ in + let avoid = Environ.ids_of_named_context_val evi.evar_hyps in + let id = + map_annot (fun na -> next_name_away_with_default_using_types "x" na avoid + (Reductionops.whd_evar evd dom)) na + in + let newenv = push_named (LocalAssum (id, dom)) evenv in + let filter = Filter.extend 1 (evar_filter evi) in + let src = subterm_source evk ~where:Body (evar_source evk evd1) in + let abstract_arguments = Abstraction.abstract_last evi.evar_abstract_arguments in + let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id.binder_name) rng) ~filter ~abstract_arguments in + let lam = mkLambda (map_annot Name.mk_name id, dom, subst_var id.binder_name body) in + Evd.define evk lam evd2, lam + +let define_evar_as_lambda env evd (evk,args) = + let evd,lam = define_pure_evar_as_lambda env evd evk in + (* Quick way to compute the instantiation of evk with args *) + let na,dom,body = destLambda evd lam in + let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evbody = mkEvar (fst (destEvar evd body), evbodyargs) in + evd, mkLambda (na, dom, evbody) + +let rec evar_absorb_arguments env evd (evk,args as ev) = function + | [] -> evd,ev + | a::l -> + (* TODO: optimize and avoid introducing intermediate evars *) + let evd,lam = define_pure_evar_as_lambda env evd evk in + let _,_,body = destLambda evd lam in + let evk = fst (destEvar evd body) in + evar_absorb_arguments env evd (evk, Array.cons a args) l + +(* Refining an evar to a sort *) + +let define_evar_as_sort env evd (ev,args) = + let evd, s = new_sort_variable univ_rigid evd in + let evi = Evd.find_undefined evd ev in + let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in + let sort = destSort evd concl in + let evd' = Evd.define ev (mkSort s) evd in + Evd.set_leq_sort env evd' (Sorts.super s) (ESorts.kind evd' sort), 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 evd tycon = + let rec real_split evd c = + let t = Reductionops.whd_all env evd c in + match EConstr.kind evd t with + | Prod (na,dom,rng) -> evd, (na, dom, rng) + | Evar ev (* ev is undefined because of whd_all *) -> + let (evd',prod) = define_evar_as_product env evd ev in + let (na,dom,rng) = destProd evd prod in + let anon = {na with binder_name = Anonymous} in + evd',(anon, dom, rng) + | App (c,args) when isEvar evd c -> + let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in + real_split evd' (mkApp (lam,args)) + | _ -> error_not_product ?loc env evd c + in + match tycon with + | None -> evd,(make_annot Anonymous Relevant,None,None) + | Some c -> + let evd', (n, dom, rng) = real_split evd c in + evd', (n, mk_tycon dom, mk_tycon rng) + +let valcon_of_tycon x = x +let lift_tycon n = Option.map (lift n) + +let pr_tycon env sigma = function + None -> str "None" + | Some t -> Termops.Internal.print_constr_env env sigma t diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli new file mode 100644 index 0000000000..8ff113196b --- /dev/null +++ b/pretyping/evardefine.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Evd +open Environ + +val env_nf_evar : evar_map -> env -> env +val env_nf_betaiotaevar : evar_map -> env -> env + +type type_constraint = types 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 + +(** Instantiate an evar by as many lambda's as needed so that its arguments + are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into + [?y[vars1:=args1,vars:=args]] with + [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) +val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> + evar_map * existential + +val split_tycon : + ?loc:Loc.t -> env -> evar_map -> type_constraint -> + evar_map * (Name.t Context.binder_annot * type_constraint * type_constraint) + +val valcon_of_tycon : type_constraint -> val_constraint +val lift_tycon : int -> type_constraint -> type_constraint + +val define_evar_as_product : env -> evar_map -> existential -> evar_map * types +val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types +val define_evar_as_sort : env -> evar_map -> existential -> evar_map * Sorts.t + +(** {6 debug pretty-printer:} *) + +val pr_tycon : env -> evar_map -> type_constraint -> Pp.t + diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml new file mode 100644 index 0000000000..4a941a68b1 --- /dev/null +++ b/pretyping/evarsolve.ml @@ -0,0 +1,1759 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Sorts +open Util +open CErrors +open Names +open Context +open Constr +open Environ +open Termops +open Evd +open EConstr +open Vars +open Namegen +open Retyping +open Reductionops +open Evarutil +open Pretype_errors + +type unify_flags = { + modulo_betaiota: bool; + open_ts : TransparentState.t; + closed_ts : TransparentState.t; + subterm_ts : TransparentState.t; + frozen_evars : Evar.Set.t; + allow_K_at_toplevel : bool; + with_cs : bool } + +type unification_kind = + | TypeUnification + | TermUnification + +(************************) +(* Unification results *) +(************************) + +type unification_result = + | Success of evar_map + | UnifFailure of evar_map * unification_error + +let is_success = function Success _ -> true | UnifFailure _ -> false + +let test_success unify flags b env evd c c' rhs = + is_success (unify flags b env evd c c' rhs) + +(** A unification function parameterized by: + - unification flags + - the kind of unification + - environment + - sigma + - conversion problem + - the two terms to unify. *) + +type unifier = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> unification_result + +(** A conversion function: parameterized by the kind of unification, + environment, sigma, conversion problem and the two terms to convert. + Conversion is not allowed to instantiate evars contrary to unification. *) +type conversion_check = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> bool + +let normalize_evar evd ev = + match EConstr.kind evd (mkEvar ev) with + | Evar (evk,args) -> (evk,args) + | _ -> assert false + +let get_polymorphic_positions env sigma f = + let open Declarations in + match EConstr.kind sigma f with + | Ind (ind, u) | Construct ((ind, _), u) -> + let mib,oib = Inductive.lookup_mind_specif env ind in + (match oib.mind_arity with + | RegularArity _ -> assert false + | TemplateArity templ -> templ.template_param_levels) + | _ -> assert false + +let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) + pbty env evd t = + let evdref = ref evd in + (* direction: true for fresh universes lower than the existing ones *) + let refresh_sort status ~direction s = + let s = ESorts.kind !evdref s in + let sigma, s' = new_sort_variable status !evdref in + evdref := sigma; + let evd = + if direction then set_leq_sort env !evdref s' s + else set_leq_sort env !evdref s s' + in evdref := evd; mkSort s' + in + let rec refresh ~onlyalg status ~direction t = + match EConstr.kind !evdref t with + | Sort s -> + begin match ESorts.kind !evdref s with + | Type u -> + (* TODO: check if max(l,u) is not ok as well *) + (match Univ.universe_level u with + | None -> refresh_sort status ~direction s + | Some l -> + (match Evd.universe_rigidity !evdref l with + | UnivRigid -> + if not onlyalg then refresh_sort status ~direction s + else t + | UnivFlexible alg -> + (if alg then + evdref := Evd.make_nonalgebraic_variable !evdref l); + t)) + | Set when refreshset && not direction -> + (* Cannot make a universe "lower" than "Set", + only refreshing when we want higher universes. *) + refresh_sort status ~direction s + | _ -> t + end + | Prod (na,u,v) -> + let v' = refresh ~onlyalg status ~direction v in + if v' == v then t else mkProd (na, u, v') + | _ -> t + in + (* Refresh the types of evars under template polymorphic references *) + let rec refresh_term_evars ~onevars ~top t = + match EConstr.kind !evdref t with + | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> + let pos = get_polymorphic_positions env !evdref f in + refresh_polymorphic_positions args pos; t + | App (f, args) when top && isEvar !evdref f -> + let f' = refresh_term_evars ~onevars:true ~top:false f in + let args' = Array.map (refresh_term_evars ~onevars ~top:false) args in + if f' == f && args' == args then t + else mkApp (f', args') + | Evar (ev, a) when onevars -> + let evi = Evd.find !evdref ev in + let ty = evi.evar_concl in + let ty' = refresh ~onlyalg univ_flexible ~direction:true ty in + if ty == ty' then t + else (evdref := Evd.downcast ev ty' !evdref; t) + | Sort s -> + (match ESorts.kind !evdref s with + | Type u when not (Univ.Universe.is_levels u) -> + refresh_sort Evd.univ_flexible ~direction:false s + | _ -> t) + | _ -> EConstr.map !evdref (refresh_term_evars ~onevars ~top:false) t + and refresh_polymorphic_positions args pos = + let rec aux i = function + | Some l :: ls -> + if i < Array.length args then + ignore(refresh_term_evars ~onevars:true ~top:false args.(i)); + aux (succ i) ls + | None :: ls -> + if i < Array.length args then + ignore(refresh_term_evars ~onevars:false ~top:false args.(i)); + aux (succ i) ls + | [] -> () + in aux 0 pos + in + let t' = + if isArity !evdref t then + match pbty with + | None -> + (* No cumulativity needed, but we still need to refresh the algebraics *) + refresh ~onlyalg:true univ_flexible ~direction:false t + | Some direction -> refresh ~onlyalg status ~direction t + else refresh_term_evars ~onevars:false ~top:true t + in !evdref, t' + +let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = + let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in + refresh_universes (Some false) env sigma ty + +let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = + match pbty with + | Some true -> add_conv_pb ~tail (Reduction.CUMUL,env,t1,t2) evd + | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd + | None -> add_conv_pb ~tail (Reduction.CONV,env,t1,t2) evd + +(* We retype applications to ensure the universe constraints are collected *) + +exception IllTypedInstance of env * EConstr.types * EConstr.types + +let recheck_applications unify flags env evdref t = + let rec aux env t = + match EConstr.kind !evdref t with + | App (f, args) -> + let () = aux env f in + let fty = Retyping.get_type_of env !evdref f in + let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in + let rec aux i ty = + if i < Array.length argsty then + match EConstr.kind !evdref (whd_all env !evdref ty) with + | Prod (na, dom, codom) -> + (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with + | Success evd -> evdref := evd; + aux (succ i) (subst1 args.(i) codom) + | UnifFailure (evd, reason) -> + Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) + else () + in aux 0 fty + | _ -> + iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t + in aux env t + + +(*------------------------------------* + * Restricting existing evars * + *------------------------------------*) + +type 'a update = +| UpdateWith of 'a +| NoUpdate + +open Context.Named.Declaration +let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign + +let restrict_evar_key evd evk filter candidates = + match filter, candidates with + | None, NoUpdate -> evd, evk + | _ -> + let evi = Evd.find_undefined evd evk in + let oldfilter = evar_filter evi in + begin match filter, candidates with + | Some filter, NoUpdate when Filter.equal oldfilter filter -> + evd, evk + | _ -> + let filter = match filter with + | None -> evar_filter evi + | Some filter -> filter in + let candidates = match candidates with + | NoUpdate -> evi.evar_candidates + | UpdateWith c -> Some c in + restrict_evar evd evk filter candidates + end + +(* Restrict an applied evar and returns its restriction in the same context *) +(* (the filter is assumed to be at least stronger than the original one) *) +let restrict_applied_evar evd (evk,argsv) filter candidates = + let evd,newevk = restrict_evar_key evd evk filter candidates in + let newargsv = match filter with + | None -> (* optim *) argsv + | Some filter -> + let evi = Evd.find evd evk in + let subfilter = Filter.compose (evar_filter evi) filter in + Filter.filter_array subfilter argsv in + evd,(newevk,newargsv) + +(* Restrict an evar in the current evar_map *) +let restrict_evar evd evk filter candidates = + fst (restrict_evar_key evd evk filter candidates) + +(* Restrict an evar in the current evar_map *) +let restrict_instance evd evk filter argsv = + match filter with None -> argsv | Some filter -> + let evi = Evd.find evd evk in + Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv + +open Context.Rel.Declaration +let noccur_evar env evd evk c = + let cache = ref Int.Set.empty (* cache for let-ins *) in + let rec occur_rec check_types (k, env as acc) c = + match EConstr.kind evd c with + | Evar (evk',args' as ev') -> + if Evar.equal evk evk' then raise Occur + else (if check_types then + occur_rec false acc (existential_type evd ev'); + Array.iter (occur_rec check_types acc) args') + | Rel i when i > k -> + if not (Int.Set.mem (i-k) !cache) then + let decl = Environ.lookup_rel i env in + if check_types then + (cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr (get_type decl)))); + (match decl with + | LocalAssum _ -> () + | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr b))) + | Proj (p,c) -> occur_rec true acc c + | _ -> iter_with_full_binders evd (fun rd (k,env) -> (succ k, push_rel rd env)) + (occur_rec check_types) acc c + in + try occur_rec false (0,env) c; true with Occur -> false + +(***************************************) +(* Managing chains of local definitons *) +(***************************************) + +type alias = +| RelAlias of int +| VarAlias of Id.t + +let of_alias = function +| RelAlias n -> mkRel n +| VarAlias id -> mkVar id + +let to_alias sigma c = match EConstr.kind sigma c with +| Rel n -> Some (RelAlias n) +| Var id -> Some (VarAlias id) +| _ -> None + +let is_alias sigma c alias = match EConstr.kind sigma c, alias with +| Var id, VarAlias id' -> Id.equal id id' +| Rel n, RelAlias n' -> Int.equal n n' +| _ -> false + +let eq_alias a b = match a, b with +| RelAlias n, RelAlias m -> Int.equal m n +| VarAlias id1, VarAlias id2 -> Id.equal id1 id2 +| _ -> false + +type aliasing = EConstr.t option * alias list + +let empty_aliasing = None, [] +let make_aliasing c = Some c, [] +let push_alias (alias, l) a = (alias, a :: l) +let lift_aliasing n (alias, l) = + let map a = match a with + | VarAlias _ -> a + | RelAlias m -> RelAlias (m + n) + in + (Option.map (fun c -> lift n c) alias, List.map map l) + +type aliases = { + rel_aliases : aliasing Int.Map.t; + var_aliases : aliasing Id.Map.t; + (** Only contains [VarAlias] *) +} + +(* Expand rels and vars that are bound to other rels or vars so that + dependencies in variables are canonically associated to the most ancient + variable in its family of aliased variables *) + +let compute_var_aliases sign sigma = + let open Context.Named.Declaration in + List.fold_right (fun decl aliases -> + let id = get_id decl in + match decl with + | LocalDef (_,t,_) -> + (match EConstr.kind sigma t with + | Var id' -> + let aliases_of_id = + try Id.Map.find id' aliases with Not_found -> empty_aliasing in + Id.Map.add id (push_alias aliases_of_id (VarAlias id')) aliases + | _ -> + Id.Map.add id (make_aliasing t) aliases) + | LocalAssum _ -> aliases) + sign Id.Map.empty + +let compute_rel_aliases var_aliases rels sigma = + snd (List.fold_right + (fun decl (n,aliases) -> + (n-1, + match decl with + | LocalDef (_,t,u) -> + (match EConstr.kind sigma t with + | Var id' -> + let aliases_of_n = + try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in + Int.Map.add n (push_alias aliases_of_n (VarAlias id')) aliases + | Rel p -> + let aliases_of_n = + try Int.Map.find (p+n) aliases with Not_found -> empty_aliasing in + Int.Map.add n (push_alias aliases_of_n (RelAlias (p+n))) aliases + | _ -> + Int.Map.add n (make_aliasing (lift n (mkCast(t,DEFAULTcast,u)))) aliases) + | LocalAssum _ -> aliases) + ) + rels + (List.length rels,Int.Map.empty)) + +let make_alias_map env sigma = + (* We compute the chain of aliases for each var and rel *) + let var_aliases = compute_var_aliases (named_context env) sigma in + let rel_aliases = compute_rel_aliases var_aliases (rel_context env) sigma in + { var_aliases; rel_aliases } + +let lift_aliases n aliases = + if Int.equal n 0 then aliases else + let rel_aliases = + Int.Map.fold (fun p l -> Int.Map.add (p+n) (lift_aliasing n l)) + aliases.rel_aliases Int.Map.empty + in + { aliases with rel_aliases } + +let get_alias_chain_of sigma aliases x = match x with + | RelAlias n -> (try Int.Map.find n aliases.rel_aliases with Not_found -> empty_aliasing) + | VarAlias id -> (try Id.Map.find id aliases.var_aliases with Not_found -> empty_aliasing) + +let normalize_alias_opt_alias sigma aliases x = + match get_alias_chain_of sigma aliases x with + | _, [] -> None + | _, a :: _ -> Some a + +let normalize_alias_opt sigma aliases x = match to_alias sigma x with +| None -> None +| Some a -> normalize_alias_opt_alias sigma aliases a + +let normalize_alias sigma aliases x = + match normalize_alias_opt_alias sigma aliases x with + | Some a -> a + | None -> x + +let normalize_alias_var sigma var_aliases id = + let aliases = { var_aliases; rel_aliases = Int.Map.empty } in + match normalize_alias sigma aliases (VarAlias id) with + | VarAlias id -> id + | RelAlias _ -> assert false (** var only aliases to variables *) + +let extend_alias sigma decl { var_aliases; rel_aliases } = + let rel_aliases = + Int.Map.fold (fun n l -> Int.Map.add (n+1) (lift_aliasing 1 l)) + rel_aliases Int.Map.empty in + let rel_aliases = + match decl with + | LocalDef(_,t,_) -> + (match EConstr.kind sigma t with + | Var id' -> + let aliases_of_binder = + try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in + Int.Map.add 1 (push_alias aliases_of_binder (VarAlias id')) rel_aliases + | Rel p -> + let aliases_of_binder = + try Int.Map.find (p+1) rel_aliases with Not_found -> empty_aliasing in + Int.Map.add 1 (push_alias aliases_of_binder (RelAlias (p+1))) rel_aliases + | _ -> + Int.Map.add 1 (make_aliasing (lift 1 t)) rel_aliases) + | LocalAssum _ -> rel_aliases in + { var_aliases; rel_aliases } + +let expand_alias_once sigma aliases x = + match get_alias_chain_of sigma aliases x with + | None, [] -> None + | Some a, [] -> Some a + | _, l -> Some (of_alias (List.last l)) + +let expansions_of_var sigma aliases x = + let (_, l) = get_alias_chain_of sigma aliases x in + x :: List.rev l + +let expansion_of_var sigma aliases x = + match get_alias_chain_of sigma aliases x with + | None, [] -> (false, of_alias x) + | Some a, _ -> (true, a) + | None, a :: _ -> (true, of_alias a) + +let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with + | Rel n -> of_alias (normalize_alias sigma aliases (RelAlias n)) + | Var id -> of_alias (normalize_alias sigma aliases (VarAlias id)) + | _ -> + let self aliases c = expand_vars_in_term_using sigma aliases c in + map_constr_with_full_binders sigma (extend_alias sigma) self aliases t + +let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) + +let free_vars_and_rels_up_alias_expansion env sigma aliases c = + let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in + let acc3 = ref Int.Set.empty and acc4 = ref Id.Set.empty in + let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in + let is_in_cache depth = function + | RelAlias n -> Int.Set.mem (n-depth) !cache_rel + | VarAlias s -> Id.Set.mem s !cache_var + in + let put_in_cache depth = function + | RelAlias n -> cache_rel := Int.Set.add (n-depth) !cache_rel + | VarAlias s -> cache_var := Id.Set.add s !cache_var + in + let rec frec (aliases,depth) c = + match EConstr.kind sigma c with + | Rel _ | Var _ as ck -> + let ck = match ck with + | Rel n -> RelAlias n + | Var id -> VarAlias id + | _ -> assert false + in + if is_in_cache depth ck then () else begin + put_in_cache depth ck; + let expanded, c' = expansion_of_var sigma aliases ck in + (if expanded then (* expansion, hence a let-in *) + match ck with + | VarAlias id -> acc4 := Id.Set.add id !acc4 + | RelAlias n -> if n >= depth+1 then acc3 := Int.Set.add (n-depth) !acc3); + match EConstr.kind sigma c' with + | Var id -> acc2 := Id.Set.add id !acc2 + | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 + | _ -> frec (aliases,depth) c end + | Const _ | Ind _ | Construct _ -> + acc2 := Id.Set.union (vars_of_global env (fst @@ EConstr.destRef sigma c)) !acc2 + | _ -> + iter_with_full_binders sigma + (fun d (aliases,depth) -> (extend_alias sigma d aliases,depth+1)) + frec (aliases,depth) c + in + frec (aliases,0) c; + (!acc1,!acc2,!acc3,!acc4) + +(********************************) +(* Managing pattern-unification *) +(********************************) + +let expand_and_check_vars sigma aliases l = + let map a = match get_alias_chain_of sigma aliases a with + | None, [] -> Some a + | None, a :: _ -> Some a + | Some _, _ -> None + in + Option.List.map map l + +let alias_distinct l = + let rec check (rels, vars) = function + | [] -> true + | RelAlias n :: l -> + not (Int.Set.mem n rels) && check (Int.Set.add n rels, vars) l + | VarAlias id :: l -> + not (Id.Set.mem id vars) && check (rels, Id.Set.add id vars) l + in + check (Int.Set.empty, Id.Set.empty) l + +let get_actual_deps env evd aliases l t = + if occur_meta_or_existential evd t then + (* Probably no restrictions on allowed vars in presence of evars *) + l + else + (* Probably strong restrictions coming from t being evar-closed *) + let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion env evd aliases t in + List.filter (function + | VarAlias id -> Id.Set.mem id fv_ids + | RelAlias n -> Int.Set.mem n fv_rels + ) l + +open Context.Named.Declaration +let remove_instance_local_defs evd evk args = + let evi = Evd.find evd evk in + let len = Array.length args in + let rec aux sign i = match sign with + | [] -> + let () = assert (i = len) in [] + | LocalAssum _ :: sign -> + let () = assert (i < len) in + (Array.unsafe_get args i) :: aux sign (succ i) + | LocalDef _ :: sign -> + aux sign (succ i) + in + aux (evar_filtered_context evi) 0 + +(* Check if an applied evar "?X[args] l" is a Miller's pattern *) + +let find_unification_pattern_args env evd l t = + let aliases = make_alias_map env evd in + match expand_and_check_vars evd aliases l with + | Some l as x when alias_distinct (get_actual_deps env evd aliases l t) -> x + | _ -> None + +let is_unification_pattern_meta env evd nb m l t = + (* Variables from context and rels > nb are implicitly all there *) + (* so we need to be a rel <= nb *) + let map a = match EConstr.kind evd a with + | Rel n -> if n <= nb then Some (RelAlias n) else None + | _ -> None + in + match Option.List.map map l with + | Some l -> + begin match find_unification_pattern_args env evd l t with + | Some _ as x when not (occur_metavariable evd m t) -> x + | _ -> None + end + | None -> + None + +let is_unification_pattern_evar env evd (evk,args) l t = + match Option.List.map (fun c -> to_alias evd c) l with + | Some l when noccur_evar env evd evk t -> + let args = remove_instance_local_defs evd evk args in + let args = Option.List.map (fun c -> to_alias evd c) args in + begin match args with + | None -> None + | Some args -> + let n = List.length args in + match find_unification_pattern_args env evd (args @ l) t with + | Some l -> Some (List.skipn n l) + | _ -> None + end + | _ -> None + +let is_unification_pattern_pure_evar env evd (evk,args) t = + let is_ev = is_unification_pattern_evar env evd (evk,args) [] t in + match is_ev with + | None -> false + | Some _ -> true + +let is_unification_pattern (env,nb) evd f l t = + match EConstr.kind evd f with + | Meta m -> is_unification_pattern_meta env evd nb m l t + | Evar ev -> is_unification_pattern_evar env evd ev l t + | _ -> None + +(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)" + (pattern unification). It is assumed that l is made of rel's that + are distinct and not bound to aliases. *) +(* It is also assumed that c does not contain metas because metas + *implicitly* depend on Vars but lambda abstraction will not reflect this + dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should + return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) +let solve_pattern_eqn env sigma l c = + let c' = List.fold_right (fun a c -> + let c' = subst_term sigma (lift 1 (of_alias a)) (lift 1 c) in + match a with + (* Rem: if [a] links to a let-in, do as if it were an assumption *) + | RelAlias n -> + let open Context.Rel.Declaration in + let d = map_constr (lift n) (lookup_rel n env) in + mkLambda_or_LetIn d c' + | VarAlias id -> + let d = lookup_named id env in mkNamedLambda_or_LetIn d c' + ) + l c in + (* Warning: we may miss some opportunity to eta-reduce more since c' + is not in normal form *) + shrink_eta c' + +(*****************************************) +(* Refining/solving unification problems *) +(*****************************************) + +(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args], + * [make_projectable_subst ev args] builds the substitution [Gamma:=args]. + * If a variable and an alias of it are bound to the same instance, we skip + * the alias (we just use eq_constr -- instead of conv --, since anyway, + * only instances that are variables -- or evars -- are later considered; + * morever, we can bet that similar instances came at some time from + * the very same substitution. The removal of aliased duplicates is + * useful to ensure the uniqueness of a projection. +*) + +let make_projectable_subst aliases sigma evi args = + let sign = evar_filtered_context evi in + let evar_aliases = compute_var_aliases sign sigma in + let (_,full_subst,cstr_subst,_) = + List.fold_right_i + (fun i decl (args,all,cstrs,revmap) -> + match decl,args with + | LocalAssum ({binder_name=id},c), a::rest -> + let revmap = Id.Map.add id i revmap in + let cstrs = + let a',args = decompose_app_vect sigma a in + match EConstr.kind sigma a' with + | Construct cstr -> + let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in + Constrmap.add (fst cstr) ((args,id)::l) cstrs + | _ -> cstrs in + let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in + (rest,all,cstrs,revmap) + | LocalDef ({binder_name=id},c,_), a::rest -> + let revmap = Id.Map.add id i revmap in + (match EConstr.kind sigma c with + | Var id' -> + let idc = normalize_alias_var sigma evar_aliases id' in + let ic, sub = + try let ic = Id.Map.find idc revmap in ic, Int.Map.find ic all + with Not_found -> i, [] (* e.g. [idc] is a filtered variable: treat [id] as an assumption *) in + if List.exists (fun (c,_,_) -> EConstr.eq_constr sigma a c) sub then + (rest,all,cstrs,revmap) + else + let all = Int.Map.add ic ((a,normalize_alias_opt sigma aliases a,id)::sub) all in + (rest,all,cstrs,revmap) + | _ -> + let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in + (rest,all,cstrs,revmap)) + | _ -> anomaly (Pp.str "Instance does not match its signature.")) 0 + sign (Array.rev_to_list args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in + (full_subst,cstr_subst) + +(*------------------------------------* + * operations on the evar constraints * + *------------------------------------*) + +(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet + * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq. + * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)] + * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds. + *) + +let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = + let (evd, evar_in_env) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let t_in_env = whd_evar evd t_in_env in + let (evk, _) = destEvar evd evar_in_env in + let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in + let ctxt = named_context_of_val sign in + let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in + let evar_in_sign = mkEvar (evk, inst_in_sign) in + (evd,whd_evar evd evar_in_sign) + +(* We have x1..xq |- ?e1 : τ and had to solve something like + * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some + * ?e2[v1..vn], hence flexible. We had to go through k binders and now + * virtually have x1..xq, y1'..yk' | ?e1' : τ' and the equation + * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c. + * [materialize_evar Γ evd k (?e1[u1..uq]) τ'] extends Σ with the declaration + * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension + * of the context of e1 so that e1 can be instantiated by + * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']), + * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation + * ?e1'[u1..uq y1..yk] = c can be registered + * + * Note that, because invert_definition does not check types, we need to + * guess the types of y1'..yn' by inverting the types of y1..yn along the + * substitution u1..uq. + *) + +exception MorePreciseOccurCheckNeeeded + +let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = + if Evd.is_defined evd evk1 then + (* Some circularity somewhere (see e.g. #3209) *) + raise MorePreciseOccurCheckNeeeded; + let (evk1,args1) = destEvar evd (mkEvar (evk1,args1)) in + let evi1 = Evd.find_undefined evd evk1 in + let env1,rel_sign = env_rel_context_chop k env in + let sign1 = evar_hyps evi1 in + let filter1 = evar_filter evi1 in + let src = subterm_source evk1 evi1.evar_source in + let ids1 = List.map get_id (named_context_of_val sign1) in + let avoid = Environ.ids_of_named_context_val sign1 in + let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in + let open Context.Rel.Declaration in + let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = + List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> + let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in + let id = map_annot (fun na -> next_name_away na avoid) na in + let evd,t_in_sign = + let s = Retyping.get_sort_of env evd t_in_env in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in + define_evar_from_virtual_equation define_fun env evd src t_in_env + ty_t_in_sign sign filter inst_in_env in + let evd,d' = match d with + | LocalAssum _ -> evd, Context.Named.Declaration.LocalAssum (id,t_in_sign) + | LocalDef (_,b,_) -> + let evd,b = define_evar_from_virtual_equation define_fun env evd src b + t_in_sign sign filter inst_in_env in + evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in + (push_named_context_val d' sign, Filter.extend 1 filter, + (mkRel 1)::(List.map (lift 1) inst_in_env), + (mkRel 1)::(List.map (lift 1) inst_in_sign), + push_rel d env,evd,Id.Set.add id.binder_name avoid)) + rel_sign + (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,avoid) + in + let evd,ev2ty_in_sign = + let s = Retyping.get_sort_of env evd ty_in_env in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in + define_evar_from_virtual_equation define_fun env evd src ty_in_env + ty_t_in_sign sign2 filter2 inst2_in_env in + let (evd, ev2_in_sign) = + new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in + let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in + (evd, ev2_in_sign, ev2_in_env) + +let restrict_upon_filter evd evk p args = + let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in + let len = Array.length args in + Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) + +let check_evar_instance unify flags evd evk1 body = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> user_err (Pp.(str "Ill-typed evar instance")) + in + match unify flags TypeUnification evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + +(***************) +(* Unification *) + +(* Inverting constructors in instances (common when inferring type of match) *) + +let find_projectable_constructor env evd cstr k args cstr_subst = + try + let l = Constrmap.find cstr cstr_subst in + let args = Array.map (lift (-k)) args in + let l = + List.filter (fun (args',id) -> + (* is_conv is maybe too strong (and source of useless computation) *) + (* (at least expansion of aliases is needed) *) + Array.for_all2 (fun c1 c2 -> is_conv env evd c1 c2) args args') l in + List.map snd l + with Not_found -> + [] + +(* [find_projectable_vars env sigma y subst] finds all vars of [subst] + * that project on [y]. It is able to find solutions to the following + * two kinds of problems: + * + * - ?n[...;x:=y;...] = y + * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable + * + * (see test-suite/success/Fixpoint.v for an example of application of + * the second kind of problem). + * + * The seek for [y] is up to variable aliasing. In case of solutions that + * differ only up to aliasing, the binding that requires the less + * steps of alias reduction is kept. At the end, only one solution up + * to aliasing is kept. + * + * [find_projectable_vars] also unifies against evars that themselves mention + * [y] and recursively. + * + * In short, the following situations give the following solutions: + * + * problem evar ctxt soluce remark + * z1; z2:=z1 |- ?ev[z1;z2] = z1 y1:A; y2:=y1 y1 \ thanks to defs kept in + * z1; z2:=z1 |- ?ev[z1;z2] = z2 y1:A; y2:=y1 y2 / subst and preferring = + * z1; z2:=z1 |- ?ev[z1] = z2 y1:A y1 thanks to expand_var + * z1; z2:=z1 |- ?ev[z2] = z1 y1:A y1 thanks to expand_var + * z3 |- ?ev[z3;z3] = z3 y1:A; y2:=y1 y2 see make_projectable_subst + * + * Remark: [find_projectable_vars] assumes that identical instances of + * variables in the same set of aliased variables are already removed (see + * [make_projectable_subst]) + *) + +type evar_projection = +| ProjectVar +| ProjectEvar of EConstr.existential * evar_info * Id.t * evar_projection + +exception NotUnique +exception NotUniqueInType of (Id.t * evar_projection) list + +let rec assoc_up_to_alias sigma aliases y yc = function + | [] -> raise Not_found + | (c,cc,id)::l -> + if is_alias sigma c y then id + else + match l with + | _ :: _ -> assoc_up_to_alias sigma aliases y yc l + | [] -> + (* Last chance, we reason up to alias conversion *) + match (normalize_alias_opt sigma aliases c) with + | Some cc when eq_alias yc cc -> id + | _ -> if is_alias sigma c yc then id else raise Not_found + +let rec find_projectable_vars with_evars aliases sigma y subst = + let yc = normalize_alias sigma aliases y in + let is_projectable idc idcl (subst1,subst2 as subst') = + (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *) + try + let id = assoc_up_to_alias sigma aliases y yc idcl in + (id,ProjectVar)::subst1,subst2 + with Not_found -> + (* Then test if [idc] is (indirectly) bound in [subst] to some evar *) + (* projectable on [y] *) + if with_evars then + let f (c,_,id) = isEvar sigma c in + let idcl' = List.filter f idcl in + match idcl' with + | [c,_,id] -> + begin + let (evk,argsv as t) = destEvar sigma c in + let evi = Evd.find sigma evk in + let subst,_ = make_projectable_subst aliases sigma evi argsv in + let l = find_projectable_vars with_evars aliases sigma y subst in + match l with + | [id',p] -> (subst1,(id,ProjectEvar (t,evi,id',p))::subst2) + | _ -> subst' + end + | [] -> subst' + | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance.") + else + subst' in + let subst1,subst2 = Int.Map.fold is_projectable subst ([],[]) in + (* We return the substitution with ProjectVar first (from most + recent to oldest var), followed by ProjectEvar (from most recent + to oldest var too) *) + subst1 @ subst2 + +(* [filter_solution] checks if one and only one possible projection exists + * among a set of solutions to a projection problem *) + +let filter_solution = function + | [] -> raise Not_found + | (id,p)::_::_ -> raise NotUnique + | [id,p] -> (mkVar id, p) + +let project_with_effects aliases sigma effects t subst = + let c, p = + filter_solution (find_projectable_vars false aliases sigma t subst) in + effects := p :: !effects; + c + +open Context.Named.Declaration +let rec find_solution_type evarenv = function + | (id,ProjectVar)::l -> get_type (lookup_named id evarenv) + | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv) + | (id,ProjectEvar _)::l -> find_solution_type evarenv l + | [] -> assert false + +(* In case the solution to a projection problem requires the instantiation of + * subsidiary evars, [do_projection_effects] performs them; it + * also try to instantiate the type of those subsidiary evars if their + * type is an evar too. + * + * Note: typing creates new evar problems, which induces a recursive dependency + * with [define]. To avoid a too large set of recursive functions, we + * pass [define] to [do_projection_effects] as a parameter. + *) + +let rec do_projection_effects unify flags define_fun env ty evd = function + | ProjectVar -> evd + | ProjectEvar ((evk,argsv),evi,id,p) -> + let evd = check_evar_instance unify flags evd evk (mkVar id) in + let evd = Evd.define evk (EConstr.mkVar id) evd in + (* TODO: simplify constraints involving evk *) + let evd = do_projection_effects unify flags define_fun env ty evd p in + let ty = whd_all env evd (Lazy.force ty) in + if not (isSort evd ty) then + (* Don't try to instantiate if a sort because if evar_concl is an + evar it may commit to a univ level which is not the right + one (however, regarding coercions, because t is obtained by + unif, we know that no coercion can be inserted) *) + let subst = make_pure_subst evi argsv in + let ty' = replace_vars subst evi.evar_concl in + if isEvar evd ty' then define_fun env evd (Some false) (destEvar evd ty') ty else evd + else + evd + +(* Assuming Σ; Γ, y1..yk |- c, [invert_arg_from_subst Γ k Σ [x1:=u1..xn:=un] c] + * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid. + * The strategy is to imitate the structure of c and then to invert + * the variables of c (i.e. rels or vars of Γ) using the algorithm + * implemented by project_with_effects/find_projectable_vars. + * It returns either a unique solution or says whether 0 or more than + * 1 solutions is found. + * + * Precondition: Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un + * Postcondition: if φ(x1..xn) is returned then + * Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) + * + * The effects correspond to evars instantiated while trying to project. + * + * [invert_arg_from_subst] is used on instances of evars. Since the + * evars are flexible, these instances are potentially erasable. This + * is why we don't investigate whether evars in the instances of evars + * are unifiable, to the contrary of [invert_definition]. + *) + +type projectibility_kind = + | NoUniqueProjection + | UniqueProjection of EConstr.constr * evar_projection list + +type projectibility_status = + | CannotInvert + | Invertible of projectibility_kind + +let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = + let effects = ref [] in + let rec aux k t = + match EConstr.kind evd t with + | Rel i when i>k0+k -> aux' k (RelAlias (i-k)) + | Var id -> aux' k (VarAlias id) + | _ -> map_with_binders evd succ aux k t + and aux' k t = + try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders + with Not_found -> + match expand_alias_once evd aliases t with + | None -> raise Not_found + | Some c -> aux k (lift k c) in + try + let c = aux 0 c_in_env_extended_with_k_binders in + Invertible (UniqueProjection (c,!effects)) + with + | Not_found -> CannotInvert + | NotUnique -> Invertible NoUniqueProjection + +let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = + let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in + match res with + | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c) + -> + CannotInvert + | _ -> + res + +exception NotEnoughInformationToInvert + +let extract_unique_projection = function +| Invertible (UniqueProjection (c,_)) -> c +| _ -> + (* For instance, there are evars with non-invertible arguments and *) + (* we cannot arbitrarily restrict these evars before knowing if there *) + (* will really be used; it can also be due to some argument *) + (* (typically a rel) that is not inversible and that cannot be *) + (* inverted either because it is needed for typing the conclusion *) + (* of the evar to project *) + raise NotEnoughInformationToInvert + +let extract_candidates sols = + try + UpdateWith + (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols) + with Exit -> + NoUpdate + +let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = + let evi = Evd.find_undefined evd evk in + let subst,_ = make_projectable_subst aliases evd evi argsv in + let invert arg = + let p = invert_arg fullenv evd aliases k evk subst arg in + extract_unique_projection p + in + Array.map invert args' + +(* Redefines an evar with a smaller context (i.e. it may depend on less + * variables) such that c becomes closed. + * Example: in "fun (x:?1) (y:list ?2[x]) => x = y :> ?3[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. + * + * If "hyps |- ?e : T" and "filter" selects a subset hyps' of hyps then + * [do_restrict_hyps evd ?e filter] sets ?e:=?e'[hyps'] and returns ?e' + * such that "hyps' |- ?e : T" + *) + +let set_of_evctx l = + List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l + +let filter_effective_candidates evd evi filter candidates = + match filter with + | None -> candidates + | Some filter -> + let ids = set_of_evctx (Filter.filter_list filter (evar_context evi)) in + List.filter (fun a -> Id.Set.subset (collect_vars evd a) ids) candidates + +let filter_candidates evd evk filter candidates_update = + let evi = Evd.find_undefined evd evk in + let candidates = match candidates_update with + | NoUpdate -> evi.evar_candidates + | UpdateWith c -> Some c + in + match candidates with + | None -> NoUpdate + | Some l -> + let l' = filter_effective_candidates evd evi filter l in + if List.length l = List.length l' && candidates_update = NoUpdate then + NoUpdate + else + UpdateWith l' + +(* Given a filter refinement for the evar [evk], restrict it so that + dependencies are preserved *) + +let closure_of_filter evd evk = function + | None -> None + | Some filter -> + let evi = Evd.find_undefined evd evk in + let vars = collect_vars evd (evar_concl evi) in + let test b decl = b || Id.Set.mem (get_id decl) vars || + match decl with + | LocalAssum _ -> + false + | LocalDef (_,c,_) -> + not (isRel evd c || isVar evd c) + in + let newfilter = Filter.map_along test filter (evar_context evi) in + (* Now ensure that restriction is at least what is was originally *) + let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in + if Filter.equal newfilter (evar_filter evi) then None else Some newfilter + +(* The filter is assumed to be at least stronger than the original one *) +let restrict_hyps evd evk filter candidates = + (* What to do with dependencies? + Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y. + - If y is in a non-erasable position in C(x,y) (i.e. it is not below an + occurrence of x in the hnf of C), then z should be removed too. + - If y is in a non-erasable position in T(x,y,z) then the problem is + unsolvable. + Computing whether y is erasable or not may be costly and the + interest for this early detection in practice is not obvious. We let + it for future work. In any case, thanks to the use of filters, the whole + (unrestricted) context remains consistent. *) + let candidates = filter_candidates evd evk (Some filter) candidates in + let typablefilter = closure_of_filter evd evk (Some filter) in + (typablefilter,candidates) + +exception EvarSolvedWhileRestricting of evar_map * EConstr.constr + +let do_restrict_hyps evd (evk,args as ev) filter candidates = + let filter,candidates = match filter with + | None -> None,candidates + | Some filter -> restrict_hyps evd evk filter candidates in + match candidates,filter with + | UpdateWith [], _ -> user_err Pp.(str "Not solvable.") + | UpdateWith [nc],_ -> + let evd = Evd.define evk nc evd in + raise (EvarSolvedWhileRestricting (evd,mkEvar ev)) + | NoUpdate, None -> evd,ev + | _ -> restrict_applied_evar evd ev filter candidates + +(* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *) +(* ?e is assumed to have no candidates *) + +let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = + let rhs = expand_vars_in_term env evd rhs in + let filter a = match EConstr.kind evd a with + | Rel n -> not (noccurn evd n rhs) + | Var id -> + local_occur_var evd id rhs + || List.exists (fun (id', _) -> Id.equal id id') sols + | _ -> true + in + let filter = restrict_upon_filter evd evk filter argsv in + (* Keep only variables that occur in rhs *) + (* This is not safe: is the variable is a local def, its body *) + (* may contain references to variables that are removed, leading to *) + (* an ill-formed context. We would actually need a notion of filter *) + (* that says that the body is hidden. Note that expand_vars_in_term *) + (* expands only rels and vars aliases, not rels or vars bound to an *) + (* arbitrary complex term *) + let filter = closure_of_filter evd evk filter in + let candidates = extract_candidates sols in + match candidates with + | NoUpdate -> + (* We made an approximation by not expanding a local definition *) + let evd,ev = restrict_applied_evar evd ev filter NoUpdate in + let pb = (pbty,env,mkEvar ev,rhs) in + add_conv_oriented_pb pb evd + | UpdateWith c -> + restrict_evar evd evk filter (UpdateWith c) + +(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic + * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]: + * - if there are at most one φj for each vj s.t. vj = φj(u1..un), + * we first restrict ?e2 to the subset v_k1..v_kq of the vj that are + * inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)] + * (this is a case of pattern-unification) + * - symmetrically if there are at most one ψj for each uj s.t. + * uj = ψj(v1..vp), + * - otherwise, each position i s.t. ui does not occur in v1..vp has to + * be restricted and similarly for the vi, and we leave the equation + * as an open equation (performed by [postpone_evar]) + * + * Warning: the notion of unique φj is relative to some given class + * of unification problems + * + * Note: argument f is the function used to instantiate evars. + *) + +let filter_compatible_candidates unify flags env evd evi args rhs c = + let c' = instantiate_evar_array evi c args in + match unify flags TermUnification env evd Reduction.CONV rhs c' with + | Success evd -> Some (c,evd) + | UnifFailure _ -> None + +(* [restrict_candidates ... filter ev1 ev2] restricts the candidates + of ev1, removing those not compatible with the filter, as well as + those not convertible to some candidate of ev2 *) + +exception DoesNotPreserveCandidateRestriction + +let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2) = + let evi1 = Evd.find evd evk1 in + let evi2 = Evd.find evd evk2 in + match evi1.evar_candidates, evi2.evar_candidates with + | _, None -> filter_candidates evd evk1 filter1 NoUpdate + | None, Some _ -> raise DoesNotPreserveCandidateRestriction + | Some l1, Some l2 -> + let l1 = filter_effective_candidates evd evi1 filter1 l1 in + let l1' = List.filter (fun c1 -> + let c1' = instantiate_evar_array evi1 c1 argsv1 in + let filter c2 = + let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in + match compatibility with + | None -> false + | Some _ -> true + in + let filtered = List.filter filter l2 in + match filtered with [] -> false | _ -> true) l1 in + if Int.equal (List.length l1) (List.length l1') then NoUpdate + else UpdateWith l1' + +exception CannotProject of evar_map * EConstr.existential + +(* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U. + Can ?n be instantiated by a term u depending essentially on xi such that the + FV(u[x1:=t1..xn:=tn]) are in the set U? + - If ti is a variable, it has to be in U. + - If ti is a constructor, its parameters cannot be erased even if u + matches on it, so we have to discard ti if the parameters + contain variables not in U. + - If ti is rigid, we have to discard it if it contains variables in U. + + Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...] + then, occurrences of ?m in the ti can be seen, like variables, as occurrences + of subterms to eventually discard so as to be allowed to keep ti. +*) + +let rec is_constrainable_in top env evd k (ev,(fv_rels,fv_ids) as g) t = + let f,args = decompose_app_vect evd t in + match EConstr.kind evd f with + | Construct ((ind,_),u) -> + let n = Inductiveops.inductive_nparams env ind in + if n > Array.length args then true (* We don't try to be more clever *) + else + let params = fst (Array.chop n args) in + Array.for_all (is_constrainable_in false env evd k g) params + | Ind _ -> Array.for_all (is_constrainable_in false env evd k g) args + | Prod (na,t1,t2) -> is_constrainable_in false env evd k g t1 && is_constrainable_in false env evd k g t2 + | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*) + | Var id -> Id.Set.mem id fv_ids + | Rel n -> n <= k || Int.Set.mem n fv_rels + | Sort _ -> true + | _ -> (* We don't try to be more clever *) true + +let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_rels,let_ids) t = + match to_alias evd t with + | Some t -> + let expanded, t' = expansion_of_var evd aliases t in + if expanded then + (* t is a local definition, we keep it only if appears in the list *) + (* of let-in variables effectively occurring on the right-hand side, *) + (* which is the only reason to keep it when inverting arguments *) + match t with + | VarAlias id -> Id.Set.mem id let_ids + | RelAlias n -> Int.Set.mem n let_rels + else begin match t with + | VarAlias id -> Id.Set.mem id fv_ids + | RelAlias n -> n <= k || Int.Set.mem n fv_rels + end + | None -> + (* t is an instance for a proper variable; we filter it along *) + (* the free variables allowed to occur *) + (not force || noccur_evar env evd ev t) && is_constrainable_in true env evd k (ev,(fv_rels,fv_ids)) t + +exception EvarSolvedOnTheFly of evar_map * EConstr.constr + +(* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on + the common domain of definition *) +let project_evar_on_evar force unify flags env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = + (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) + let fvs2 = free_vars_and_rels_up_alias_expansion env evd aliases (mkEvar ev2) in + let filter1 = restrict_upon_filter evd evk1 + (has_constrainable_free_vars env evd aliases force k2 evk2 fvs2) + argsv1 in + let candidates1 = + try restrict_candidates unify flags env evd filter1 ev1 ev2 + with DoesNotPreserveCandidateRestriction -> + let evd,ev1' = do_restrict_hyps evd ev1 filter1 NoUpdate in + raise (CannotProject (evd,ev1')) in + let evd,(evk1',args1 as ev1') = + try do_restrict_hyps evd ev1 filter1 candidates1 + with EvarSolvedWhileRestricting (evd,ev1) -> + raise (EvarSolvedOnTheFly (evd,ev1)) in + (* Only try pruning on variable substitutions, postpone otherwise. *) + (* Rules out non-linear instances. *) + if Option.is_empty pbty && is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then + try + evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1) + with NotEnoughInformationToInvert -> + raise (CannotProject (evd,ev1')) + else + raise (CannotProject (evd,ev1')) + +let update_evar_info ev1 ev2 evd = + (* We update the source of obligation evars during evar-evar unifications. *) + let loc, evs1 = evar_source ev1 evd in + let evi = Evd.find evd ev2 in + Evd.add evd ev2 {evi with evar_source = loc, evs1} + +let solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 (evk2,_ as ev2) = + try + let evd,body = project_evar_on_evar force unify flags env evd aliases 0 pbty ev1 ev2 in + let evd' = Evd.define_with_evar evk2 body evd in + let evd' = + if is_obligation_evar evd evk2 then + update_evar_info evk2 (fst (destEvar evd' body)) evd' + else evd' + in + check_evar_instance unify flags evd' evk2 body + with EvarSolvedOnTheFly (evd,c) -> + f env evd pbty ev2 c + +let opp_problem = function None -> None | Some b -> Some (not b) + +let preferred_orientation evd evk1 evk2 = + if is_obligation_evar evd evk1 then true + else if is_obligation_evar evd evk2 then false + else true + +let solve_evar_evar_aux force f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let aliases = make_alias_map env evd in + let frozen_ev1 = Evar.Set.mem evk1 flags.frozen_evars in + let frozen_ev2 = Evar.Set.mem evk2 flags.frozen_evars in + if preferred_orientation evd evk1 evk2 then + try if not frozen_ev1 then + solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 + else raise (CannotProject (evd,ev2)) + with CannotProject (evd,ev2) -> + try if not frozen_ev2 then + solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 + else raise (CannotProject (evd,ev1)) + with CannotProject (evd,ev1) -> + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + else + try if not frozen_ev2 then + solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 + else raise (CannotProject (evd,ev1)) + with CannotProject (evd,ev1) -> + try if not frozen_ev1 then + solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 + else raise (CannotProject (evd,ev2)) + with CannotProject (evd,ev2) -> + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + +(** Precondition: evk1 is not frozen *) +let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let pbty = if force then None else pbty in + let evi = Evd.find evd evk1 in + let downcast evk t evd = downcast evk t evd in + let evd = + try + (* ?X : ΠΔ. Type i = ?Y : ΠΔ'. Type j. + The body of ?X and ?Y just has to be of type ΠΔ. Type k for some k <= i, j. *) + let evienv = Evd.evar_env evi in + let concl1 = EConstr.Unsafe.to_constr evi.evar_concl in + let ctx1, i = Reduction.dest_arity evienv concl1 in + let ctx1 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx1 in + let evi2 = Evd.find evd evk2 in + let evi2env = Evd.evar_env evi2 in + let concl2 = EConstr.Unsafe.to_constr evi2.evar_concl in + let ctx2, j = Reduction.dest_arity evi2env concl2 in + let ctx2 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx2 in + let ui, uj = univ_of_sort i, univ_of_sort j in + if i == j || Evd.check_eq evd ui uj + then (* Shortcut, i = j *) + evd + else if Evd.check_leq evd ui uj then + let t2 = it_mkProd_or_LetIn (mkSort i) ctx2 in + downcast evk2 t2 evd + else if Evd.check_leq evd uj ui then + let t1 = it_mkProd_or_LetIn (mkSort j) ctx1 in + downcast evk1 t1 evd + else + let evd, k = Evd.new_sort_variable univ_flexible_alg evd in + let t1 = it_mkProd_or_LetIn (mkSort k) ctx1 in + let t2 = it_mkProd_or_LetIn (mkSort k) ctx2 in + let evd = Evd.set_leq_sort env (Evd.set_leq_sort env evd k i) k j in + downcast evk2 t2 (downcast evk1 t1 evd) + with Reduction.NotArity -> + evd in + solve_evar_evar_aux force f unify flags env evd pbty ev1 ev2 + +(* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint + * definitions. We try to unify the ti with the ui pairwise. The pairs + * that don't unify are discarded (i.e. ?e is redefined so that it does not + * depend on these args). *) + +let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = + let evdref = ref evd in + let eq_constr c1 c2 = match EConstr.eq_constr_universes env !evdref c1 c2 with + | None -> false + | Some cstr -> + try evdref := Evd.add_universe_constraints !evdref cstr; true + with UniversesDiffer -> false + in + if Array.equal eq_constr argsv1 argsv2 then !evdref else + (* Filter and restrict if needed *) + let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in + let untypedfilter = + restrict_upon_filter evd evk + (fun (a1,a2) -> unify flags TermUnification env evd Reduction.CONV a1 a2) args in + let candidates = filter_candidates evd evk untypedfilter NoUpdate in + let filter = closure_of_filter evd evk untypedfilter in + let evd',ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in + let frozen = Evar.Set.mem evk flags.frozen_evars in + if Evar.equal (fst ev1) evk && (frozen || can_drop) then + (* No refinement needed *) evd' + else + (* either progress, or not allowed to drop, e.g. to preserve possibly *) + (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *) + (* if e can depend on x until ?y is not resolved, or, conversely, we *) + (* don't know if ?y has to be unified with ?y, until e is resolved *) + if frozen then + (* We cannot prune a frozen evar *) + add_conv_oriented_pb (pbty,env,mkEvar (evk, argsv1),mkEvar (evk,argsv2)) evd + else + let argsv2 = restrict_instance evd' evk filter argsv2 in + let ev2 = (fst ev1,argsv2) in + (* Leave a unification problem *) + add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd' + +(* If the evar can be instantiated by a finite set of candidates known + in advance, we check which of them apply *) + +exception NoCandidates +exception IncompatibleCandidates + +let solve_candidates unify flags env evd (evk,argsv) rhs = + let evi = Evd.find evd evk in + match evi.evar_candidates with + | None -> raise NoCandidates + | Some l -> + let l' = + List.map_filter + (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in + match l' with + | [] -> raise IncompatibleCandidates + | [c,evd] -> + (* solve_candidates might have been called recursively in the mean *) + (* time and the evar been solved by the filtering process *) + if Evd.is_undefined evd evk then + let evd' = Evd.define evk c evd in + check_evar_instance unify flags evd' evk c + else evd + | l when List.length l < List.length l' -> + let candidates = List.map fst l in + restrict_evar evd evk None (UpdateWith candidates) + | l -> evd + +let occur_evar_upto_types sigma n c = + let c = EConstr.Unsafe.to_constr c in + let seen = ref Evar.Set.empty in + (* FIXME: Is that supposed to be evar-insensitive? *) + let rec occur_rec c = match Constr.kind c with + | Evar (sp,_) when Evar.equal sp n -> raise Occur + | Evar (sp,args as e) -> + if Evar.Set.mem sp !seen then + Array.iter occur_rec args + else ( + seen := Evar.Set.add sp !seen; + Option.iter occur_rec (existential_opt_value0 sigma e); + occur_rec (Evd.existential_type0 sigma e)) + | _ -> Constr.iter occur_rec c + in + try occur_rec c; false with Occur -> true + +let instantiate_evar unify flags evd evk body = + (* Check instance freezing the evar to be defined, as + checking could involve the same evar definition problem again otherwise *) + let flags = { flags with frozen_evars = Evar.Set.add evk flags.frozen_evars } in + let evd' = check_evar_instance unify flags evd evk body in + Evd.define evk body evd' + +(* We try to instantiate the evar assuming the body won't depend + * on arguments that are not Rels or Vars, or appearing several times + * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) + * + * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem + * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs" + * where only Rel's and Var's are relevant in subst + * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is + * not in the scope of ?ev. For instance, the problem + * "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because + * ?1 would be instantiated by y which is not in the scope of ?1. + * 4) We try to "project" the term if the process of imitation fails + * and that only one projection is possible + * + * Note: we don't assume rhs in normal form, it may fail while it would + * have succeeded after some reductions. + * + * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] c] + * Precondition: Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un + * Postcondition: if φ(x1..xn) is returned then + * Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) + *) + +exception NotInvertibleUsingOurAlgorithm of EConstr.constr +exception NotEnoughInformationToProgress of (Id.t * evar_projection) list +exception NotEnoughInformationEvarEvar of EConstr.constr +exception OccurCheckIn of evar_map * EConstr.constr +exception MetaOccurInBodyInternal + +let rec invert_definition unify flags choose imitate_defs + env evd pbty (evk,argsv as ev) rhs = + let aliases = make_alias_map env evd in + let evdref = ref evd in + let progress = ref false in + let evi = Evd.find evd evk in + let subst,cstr_subst = make_projectable_subst aliases evd evi argsv in + + (* Projection *) + let project_variable t = + (* Evar/Var problem: unifiable iff variable projectable from ev subst *) + try + let sols = find_projectable_vars true aliases !evdref t subst in + let c, p = match sols with + | [] -> raise Not_found + | [id,p] -> (mkVar id, p) + | (id,p)::_ -> + if choose then (mkVar id, p) else raise (NotUniqueInType sols) + in + let ty = lazy (Retyping.get_type_of env !evdref (of_alias t)) in + let evd = do_projection_effects unify flags (evar_define unify flags ~choose) env ty !evdref p in + evdref := evd; + c + with + | Not_found -> raise (NotInvertibleUsingOurAlgorithm (of_alias t)) + | NotUniqueInType sols -> + if not !progress then + raise (NotEnoughInformationToProgress sols); + (* No unique projection but still restrict to where it is possible *) + (* materializing is necessary, but is restricting useful? *) + let ty = find_solution_type (evar_filtered_env evi) sols in + let ty' = instantiate_evar_array evi ty argsv in + let (evd,evar,(evk',argsv' as ev')) = + materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in + let ts = expansions_of_var evd aliases t in + let test c = isEvar evd c || List.exists (is_alias evd c) ts in + let filter = restrict_upon_filter evd evk test argsv' in + let filter = closure_of_filter evd evk' filter in + let candidates = extract_candidates sols in + let evd = match candidates with + | NoUpdate -> + let evd, ev'' = restrict_applied_evar evd ev' filter NoUpdate in + add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',of_alias t) evd + | UpdateWith _ -> + restrict_evar evd evk' filter candidates + in + evdref := evd; + evar in + + let rec imitate (env',k as envk) t = + match EConstr.kind !evdref t with + | Rel i when i>k -> + let open Context.Rel.Declaration in + (match Environ.lookup_rel (i-k) env' with + | LocalAssum _ -> project_variable (RelAlias (i-k)) + | LocalDef (_,b,_) -> + try project_variable (RelAlias (i-k)) + with NotInvertibleUsingOurAlgorithm _ when imitate_defs -> + imitate envk (lift i (EConstr.of_constr b))) + | Var id -> + (match Environ.lookup_named id env' with + | LocalAssum _ -> project_variable (VarAlias id) + | LocalDef (_,b,_) -> + try project_variable (VarAlias id) + with NotInvertibleUsingOurAlgorithm _ when imitate_defs -> + imitate envk (EConstr.of_constr b)) + | LetIn (na,b,u,c) -> + imitate envk (subst1 b c) + | Evar (evk',args' as ev') -> + if Evar.equal evk evk' then raise (OccurCheckIn (evd,rhs)); + (* Evar/Evar problem (but left evar is virtual) *) + let aliases = lift_aliases k aliases in + (try + let ev = (evk,Array.map (lift k) argsv) in + let evd,body = project_evar_on_evar false unify flags env' !evdref aliases k None ev' ev in + evdref := evd; + body + with + | EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t + | CannotProject (evd,ev') -> + if not !progress then + raise (NotEnoughInformationEvarEvar t); + (* Make the virtual left evar real *) + let ty = get_type_of env' evd t in + let (evd,evar'',ev'') = + materialize_evar (evar_define unify flags ~choose) env' evd k ev ty in + (* materialize_evar may instantiate ev' by another evar; adjust it *) + let (evk',args' as ev') = normalize_evar evd ev' in + let evd = + (* Try to project (a restriction of) the left evar ... *) + try + let evd,body = project_evar_on_evar false unify flags env' evd aliases 0 None ev'' ev' in + let evd = Evd.define evk' body evd in + check_evar_instance unify flags evd evk' body + with + | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) + | CannotProject (evd,ev'') -> + (* ... or postpone the problem *) + add_conv_oriented_pb (None,env',mkEvar ev'',mkEvar ev') evd in + evdref := evd; + evar'') + | _ -> + progress := true; + match + let c,args = decompose_app_vect !evdref t in + match EConstr.kind !evdref c with + | Construct (cstr,u) when noccur_between !evdref 1 k t -> + (* This is common case when inferring the return clause of match *) + (* (currently rudimentary: we do not treat the case of multiple *) + (* possible inversions; we do not treat overlap with a possible *) + (* alternative inversion of the subterms of the constructor, etc)*) + (match find_projectable_constructor env evd cstr k args cstr_subst with + | _::_ as l -> Some (List.map mkVar l) + | _ -> None) + | _ -> None + with + | Some l -> + let ty = get_type_of env' !evdref t in + let candidates = + try + let t = + map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + imitate envk t in + (* Less dependent solutions come last *) + l@[t] + with e when CErrors.noncritical e -> l in + (match candidates with + | [x] -> x + | _ -> + let (evd,evar'',ev'') = + materialize_evar (evar_define unify flags ~choose) env' !evdref k ev ty in + evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates); + evar'') + | None -> + (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) + map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + imitate envk t + in + let rhs = whd_beta evd rhs (* heuristic *) in + let fast rhs = + let filter_ctxt = evar_filtered_context evi in + let names = ref Id.Set.empty in + let rec is_id_subst ctxt s = + match ctxt, s with + | (decl :: ctxt'), (c :: s') -> + let id = get_id decl in + names := Id.Set.add id !names; + isVarId evd id c && is_id_subst ctxt' s' + | [], [] -> true + | _ -> false + in + is_id_subst filter_ctxt (Array.to_list argsv) && + closed0 evd rhs && + Id.Set.subset (collect_vars evd rhs) !names + in + let body = + if fast rhs then nf_evar evd rhs (* FIXME? *) + else + let t' = imitate (env,0) rhs in + if !progress then + (recheck_applications unify flags (evar_env evi) evdref t'; t') + else t' + in (!evdref,body) + +(* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is + * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said, + * [define] tries to find an instance lhs such that + * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in + * context "hyps" and not referring to itself. + * ev is assumed not to be frozen. + *) + +and evar_define unify flags ?(choose=false) ?(imitate_defs=true) env evd pbty (evk,argsv as ev) rhs = + match EConstr.kind evd rhs with + | Evar (evk2,argsv2 as ev2) -> + if Evar.equal evk evk2 then + solve_refl ~can_drop:choose + (test_success unify) flags env evd pbty evk argsv argsv2 + else + solve_evar_evar ~force:choose + (evar_define unify flags) unify flags env evd pbty ev ev2 + | _ -> + try solve_candidates unify flags env evd ev rhs + with NoCandidates -> + try + let (evd',body) = invert_definition unify flags choose imitate_defs env evd pbty ev rhs in + if occur_meta evd' body then raise MetaOccurInBodyInternal; + (* invert_definition may have instantiate some evars of rhs with evk *) + (* so we recheck acyclicity *) + if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); + (* needed only if an inferred type *) + let evd', body = refresh_universes pbty env evd' body in + instantiate_evar unify flags evd' evk body + with + | NotEnoughInformationToProgress sols -> + postpone_non_unique_projection env evd pbty ev sols rhs + | NotEnoughInformationEvarEvar t -> + add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd + | MorePreciseOccurCheckNeeeded -> + add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) evd + | NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e -> + raise e + | OccurCheckIn (evd,rhs) -> + (* last chance: rhs actually reduces to ev *) + let c = whd_all env evd rhs in + match EConstr.kind evd c with + | Evar (evk',argsv2) when Evar.equal evk evk' -> + solve_refl (fun flags _b env sigma pb c c' -> is_fconv pb env sigma c c') flags + env evd pbty evk argsv argsv2 + | _ -> + raise (OccurCheckIn (evd,rhs)) + +(* 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 + * 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 evd lev (pbty,_,t1,t2) = + (try Evar.Set.mem (head_evar evd t1) lev with NoHeadEvar -> false) || + (try Evar.Set.mem (head_evar evd t2) lev with NoHeadEvar -> false) + +let reconsider_unif_constraints unify flags evd = + let (evd,pbs) = extract_changed_conv_pbs evd (status_changed evd) in + List.fold_left + (fun p (pbty,env,t1,t2 as x) -> + match p with + | Success evd -> + (match unify flags TermUnification env evd pbty t1 t2 with + | Success _ as x -> x + | UnifFailure (i,e) -> UnifFailure (i,CannotSolveConstraint (x,e))) + | UnifFailure _ as x -> x) + (Success evd) + pbs + +(* Tries to solve problem t1 = t2. + * Precondition: t1 is an uninstantiated 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 unify flags ?(choose=false) ?(imitate_defs=true) + env evd (pbty,(evk1,args1 as ev1),t2) = + try + let t2 = whd_betaiota evd t2 in (* includes whd_evar *) + let evd = evar_define unify flags ~choose ~imitate_defs env evd pbty ev1 t2 in + reconsider_unif_constraints unify flags evd + with + | NotInvertibleUsingOurAlgorithm t -> + UnifFailure (evd,NotClean (ev1,env,t)) + | OccurCheckIn (evd,rhs) -> + UnifFailure (evd,OccurCheck (evk1,rhs)) + | MetaOccurInBodyInternal -> + UnifFailure (evd,MetaOccurInBody evk1) + | IllTypedInstance (env,t,u) -> + UnifFailure (evd,InstanceNotSameType (evk1,env,t,u)) + | IncompatibleCandidates -> + UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2)) + diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli new file mode 100644 index 0000000000..ebf8230bbd --- /dev/null +++ b/pretyping/evarsolve.mli @@ -0,0 +1,134 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open EConstr +open Evd +open Environ + +type alias + +val of_alias : alias -> EConstr.t + +type unify_flags = { + modulo_betaiota : bool; + (* Enable beta-iota reductions during unification *) + open_ts : TransparentState.t; + (* Enable delta reduction according to open_ts for open terms *) + closed_ts : TransparentState.t; + (* Enable delta reduction according to closed_ts for closed terms (when calling conversion) *) + subterm_ts : TransparentState.t; + (* Enable delta reduction according to subterm_ts for selection of subterms during higher-order + unifications. *) + frozen_evars : Evar.Set.t; + (* Frozen evars are treated like rigid variables during unification: they can not be instantiated. *) + allow_K_at_toplevel : bool; + (* During higher-order unifications, allow to produce K-redexes: i.e. to produce + an abstraction for an unused argument *) + with_cs : bool + (* Enable canonical structure resolution during unification *) +} + +type unification_result = + | Success of evar_map + | UnifFailure of evar_map * Pretype_errors.unification_error + +val is_success : unification_result -> bool + +(** Replace the vars and rels that are aliases to other vars and rels by + their representative that is most ancient in the context *) +val expand_vars_in_term : env -> evar_map -> constr -> constr + +(** One might want to use different conversion strategies for types and terms: + e.g. preventing delta reductions when doing term unifications but allowing + arbitrary delta conversion when checking the types of evar instances. *) + +type unification_kind = + | TypeUnification + | TermUnification + +(** A unification function parameterized by: + - unification flags + - the kind of unification + - environment + - sigma + - conversion problem + - the two terms to unify. *) +type unifier = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> unification_result + +(** A conversion function: parameterized by the kind of unification, + environment, sigma, conversion problem and the two terms to convert. + Conversion is not allowed to instantiate evars contrary to unification. *) +type conversion_check = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> bool + +(** [instantiate_evar unify flags env sigma ev c] defines the evar [ev] with [c], + checking that the type of [c] is unifiable with [ev]'s declared type first. + + Preconditions: + - [ev] does not occur in [c]. + - [c] does not contain any Meta(_) + *) + +val instantiate_evar : unifier -> unify_flags -> evar_map -> + Evar.t -> constr -> evar_map + +(** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), + possibly solving related unification problems, possibly leaving open + some problems that cannot be solved in a unique way (except if choose is + true); fails if the instance is not valid for the given [ev] *) + +val evar_define : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> + env -> evar_map -> bool option -> existential -> constr -> evar_map + + +val refresh_universes : + ?status:Evd.rigid -> + ?onlyalg:bool (* Only algebraic universes *) -> + ?refreshset:bool -> + (* Also refresh Prop and Set universes, so that the returned type can be any supertype + of the original type *) + bool option (* direction: true for levels lower than the existing levels *) -> + env -> evar_map -> types -> evar_map * types + +val solve_refl : ?can_drop:bool -> conversion_check -> unify_flags -> env -> evar_map -> + bool option -> Evar.t -> constr array -> constr array -> evar_map + +val solve_evar_evar : ?force:bool -> + (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> + unifier -> unify_flags -> + env -> evar_map -> bool option -> existential -> existential -> evar_map + +val solve_simple_eqn : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> env -> evar_map -> + bool option * existential * constr -> unification_result + +val reconsider_unif_constraints : unifier -> unify_flags -> evar_map -> unification_result + +val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> + constr -> alias list option + +val is_unification_pattern : env * int -> evar_map -> constr -> constr list -> + constr -> alias list option + +val solve_pattern_eqn : env -> evar_map -> alias list -> constr -> constr + +val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool + +exception IllTypedInstance of env * types * types + +(* May raise IllTypedInstance if types are not convertible *) +val check_evar_instance : unifier -> unify_flags -> + evar_map -> Evar.t -> constr -> evar_map + +val remove_instance_local_defs : + evar_map -> Evar.t -> 'a array -> 'a list + +val get_type_of_refresh : + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml new file mode 100644 index 0000000000..7019cdf046 --- /dev/null +++ b/pretyping/find_subterm.ml @@ -0,0 +1,187 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open CErrors +open Names +open Locus +open EConstr +open Termops +open Pretype_errors + +module NamedDecl = Context.Named.Declaration + +(** Processing occurrences *) + +type occurrence_error = + | InvalidOccurrence of int list + | IncorrectInValueOccurrence of Id.t + +let explain_invalid_occurrence l = + let l = List.sort_uniquize Int.compare l in + str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") + ++ prlist_with_sep spc int l ++ str "." + +let explain_incorrect_in_value_occurrence id = + Id.print id ++ str " has no value." + +let explain_occurrence_error = function + | InvalidOccurrence l -> explain_invalid_occurrence l + | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id + +let error_occurrences_error e = + user_err (explain_occurrence_error e) + +let error_invalid_occurrence occ = + error_occurrences_error (InvalidOccurrence occ) + +let check_used_occurrences nbocc (nowhere_except_in,locs) = + let rest = List.filter (fun o -> o >= nbocc) locs in + match rest with + | [] -> () + | _ -> error_occurrences_error (InvalidOccurrence rest) + +let proceed_with_occurrences f occs x = + match occs with + | NoOccurrences -> x + | occs -> + let plocs = Locusops.convert_occs occs in + assert (List.for_all (fun x -> x >= 0) (snd plocs)); + let (nbocc,x) = f 1 x in + check_used_occurrences nbocc plocs; + x + +(** Applying a function over a named_declaration with an hypothesis + location request *) + +let map_named_declaration_with_hyploc f hyploc acc decl = + let open Context.Named.Declaration in + let f acc typ = + let acc, typ = f (Some (NamedDecl.get_id decl, hyploc)) acc typ in + acc, typ + in + match decl,hyploc with + | LocalAssum (id,_), InHypValueOnly -> + error_occurrences_error (IncorrectInValueOccurrence id.Context.binder_name) + | LocalAssum (id,typ), _ -> + let acc,typ = f acc typ in acc, LocalAssum (id,typ) + | LocalDef (id,body,typ), InHypTypeOnly -> + let acc,typ = f acc typ in acc, LocalDef (id,body,typ) + | LocalDef (id,body,typ), InHypValueOnly -> + let acc,body = f acc body in acc, LocalDef (id,body,typ) + | LocalDef (id,body,typ), InHyp -> + let acc,body = f acc body in + let acc,typ = f acc typ in + acc, LocalDef (id,body,typ) + +(** Finding a subterm up to some testing function *) + +exception SubtermUnificationError of subterm_unification_error + +exception NotUnifiable of (EConstr.t * EConstr.t * unification_error) option + +type 'a testing_function = { + match_fun : 'a -> EConstr.constr -> 'a; + merge_fun : 'a -> 'a -> 'a; + mutable testing_state : 'a; + mutable last_found : position_reporting option +} + +(* Find subterms using a testing function, but only at a list of + locations or excluding a list of locations; in the occurrences list + (b,l), b=true means no occurrence except the ones in l and b=false, + means all occurrences except the ones in l *) + +let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = + let (nowhere_except_in,locs) = Locusops.convert_occs occs in + let maxocc = List.fold_right max locs 0 in + let pos = ref occ in + let nested = ref false in + let add_subst t subst = + try + test.testing_state <- test.merge_fun subst test.testing_state; + test.last_found <- Some ((cl,!pos),t) + with NotUnifiable e when not like_first -> + let lastpos = Option.get test.last_found in + raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in + let rec substrec k t = + if nowhere_except_in && !pos > maxocc then t else + try + let subst = test.match_fun test.testing_state t in + if Locusops.is_selected !pos occs then + (if !nested then begin + (* in case it is nested but not later detected as unconvertible, + as when matching "id _" in "id (id 0)" *) + let lastpos = Option.get test.last_found in + raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,None)) + end; + add_subst t subst; incr pos; + (* Check nested matching subterms *) + if not (Locusops.is_all_occurrences occs) && occs != Locus.NoOccurrences then + begin nested := true; ignore (subst_below k t); nested := false end; + (* Do the effective substitution *) + Vars.lift k (bywhat ())) + else + (incr pos; subst_below k t) + with NotUnifiable _ -> + subst_below k t + and subst_below k t = + map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t + in + let t' = substrec 0 t in + (!pos, t') + +let replace_term_occ_modulo evd occs test bywhat t = + let occs',like_first = + match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in + proceed_with_occurrences + (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t + +let replace_term_occ_decl_modulo evd occs test bywhat d = + let (plocs,hyploc),like_first = + match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in + proceed_with_occurrences + (map_named_declaration_with_hyploc + (replace_term_occ_gen_modulo evd plocs like_first test bywhat) + hyploc) + plocs d + +(** Finding an exact subterm *) + +let make_eq_univs_test env evd c = + { match_fun = (fun evd c' -> + match EConstr.eq_constr_universes_proj env evd c c' with + | None -> raise (NotUnifiable None) + | Some cst -> + try Evd.add_universe_constraints evd cst + with Evd.UniversesDiffer -> raise (NotUnifiable None) + ); + merge_fun = (fun evd _ -> evd); + testing_state = evd; + last_found = None +} + +let subst_closed_term_occ env evd occs c t = + let test = make_eq_univs_test env evd c in + let bywhat () = mkRel 1 in + let t' = replace_term_occ_modulo evd occs test bywhat t in + t', test.testing_state + +let subst_closed_term_occ_decl env evd occs c d = + let test = make_eq_univs_test env evd c in + let (plocs,hyploc),like_first = + match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in + let bywhat () = mkRel 1 in + proceed_with_occurrences + (map_named_declaration_with_hyploc + (fun _ -> replace_term_occ_gen_modulo evd plocs like_first test bywhat None) + hyploc) plocs d, + test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli new file mode 100644 index 0000000000..9ba63b4f52 --- /dev/null +++ b/pretyping/find_subterm.mli @@ -0,0 +1,70 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Locus +open Evd +open Pretype_errors +open Environ +open EConstr + +(** Finding subterms, possibly up to some unification function, + possibly at some given occurrences *) + +exception NotUnifiable of (constr * constr * unification_error) option + +exception SubtermUnificationError of subterm_unification_error + +(** A testing function is typically a unification function returning a + substitution or failing with a NotUnifiable error, together with a + function to merge substitutions and an initial substitution; + last_found is used for error messages and it has to be initialized + with None. *) + +type 'a testing_function = { + match_fun : 'a -> constr -> 'a; + merge_fun : 'a -> 'a -> 'a; + mutable testing_state : 'a; + mutable last_found : position_reporting option +} + +(** This is the basic testing function, looking for exact matches of a + closed term *) +val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function + +(** [replace_term_occ_modulo occl test mk c] looks in [c] for subterm + modulo a testing function [test] and replaces successfully + matching subterms at the indicated occurrences [occl] with [mk + ()]; it turns a NotUnifiable exception raised by the testing + function into a SubtermUnificationError. *) +val replace_term_occ_modulo : evar_map -> occurrences or_like_first -> + 'a testing_function -> (unit -> constr) -> constr -> constr + +(** [replace_term_occ_decl_modulo] is similar to + [replace_term_occ_modulo] but for a named_declaration. *) +val replace_term_occ_decl_modulo : + evar_map -> + (occurrences * hyp_location_flag) or_like_first -> + 'a testing_function -> (unit -> constr) -> + named_declaration -> named_declaration + +(** [subst_closed_term_occ occl c d] replaces occurrences of + closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), + unifying universes which results in a set of constraints. *) +val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> + constr -> constr -> constr * evar_map + +(** [subst_closed_term_occ_decl evd occl c decl] replaces occurrences of + closed [c] at positions [occl] by [Rel 1] in [decl]. *) +val subst_closed_term_occ_decl : env -> evar_map -> + (occurrences * hyp_location_flag) or_like_first -> + constr -> named_declaration -> named_declaration * evar_map + +(** Miscellaneous *) +val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/geninterp.ml b/pretyping/geninterp.ml new file mode 100644 index 0000000000..32152ad0e4 --- /dev/null +++ b/pretyping/geninterp.ml @@ -0,0 +1,103 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Genarg + +module TacStore = Store.Make () + +(** Dynamic toplevel values *) + +module ValT = Dyn.Make () + +module Val = +struct + + type 'a typ = 'a ValT.tag + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a typ * 'a -> t + + let eq = ValT.eq + let repr = ValT.repr + let create = ValT.create + + let pr : type a. a typ -> Pp.t = fun t -> Pp.str (repr t) + + let typ_list = ValT.create "list" + let typ_opt = ValT.create "option" + let typ_pair = ValT.create "pair" + + let rec inject : type a. a tag -> a -> t = fun tag x -> match tag with + | Base t -> Dyn (t, x) + | List tag -> Dyn (typ_list, List.map (fun x -> inject tag x) x) + | Opt tag -> Dyn (typ_opt, Option.map (fun x -> inject tag x) x) + | Pair (tag1, tag2) -> + Dyn (typ_pair, (inject tag1 (fst x), inject tag2 (snd x))) + +end + +module ValTMap = ValT.Map + +module ValReprObj = +struct + type ('raw, 'glb, 'top) obj = 'top Val.tag + let name = "valrepr" + let default _ = None +end + +module ValRepr = Register(ValReprObj) + +let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function +| ListArg t -> Val.List (val_tag t) +| OptArg t -> Val.Opt (val_tag t) +| PairArg (t1, t2) -> Val.Pair (val_tag t1, val_tag t2) +| ExtraArg s -> ValRepr.obj (ExtraArg s) + +let val_tag = function Topwit t -> val_tag t + +let register_val0 wit tag = + let tag = match tag with + | None -> + let name = match wit with + | ExtraArg s -> ArgT.repr s + | _ -> assert false + in + Val.Base (Val.create name) + | Some tag -> tag + in + ValRepr.register0 wit tag + +(** Interpretation functions *) + +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } + +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t + +module InterpObj = +struct + type ('raw, 'glb, 'top) obj = ('glb, Val.t) interp_fun + let name = "interp" + let default _ = None +end + +module Interp = Register(InterpObj) + +let interp = Interp.obj + +let register_interp0 = Interp.register0 diff --git a/pretyping/geninterp.mli b/pretyping/geninterp.mli new file mode 100644 index 0000000000..49d874289d --- /dev/null +++ b/pretyping/geninterp.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Interpretation functions for generic arguments and interpreted Ltac + values. *) + +open Names +open Genarg + +(** {6 Dynamic toplevel values} *) + +module Val : +sig + type 'a typ + + val create : string -> 'a typ + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a typ * 'a -> t + + val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option + val repr : 'a typ -> string + val pr : 'a typ -> Pp.t + + val typ_list : t list typ + val typ_opt : t option typ + val typ_pair : (t * t) typ + + val inject : 'a tag -> 'a -> t + +end + +module ValTMap (Value : Dyn.ValueS) : + Dyn.MapS with type 'a key = 'a Val.typ and type 'a value = 'a Value.t + +(** Dynamic types for toplevel values. While the generic types permit to relate + objects at various levels of interpretation, toplevel values are wearing + their own type regardless of where they came from. This allows to use the + same runtime representation for several generic types. *) + +val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag +(** Retrieve the dynamic type associated to a toplevel genarg. *) + +val register_val0 : ('raw, 'glb, 'top) genarg_type -> 'top Val.tag option -> unit +(** Register the representation of a generic argument. If no tag is given as + argument, a new fresh tag with the same name as the argument is associated + to the generic type. *) + +(** {6 Interpretation functions} *) + +module TacStore : Store.S + +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } + +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t + +val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, Val.t) interp_fun + +val register_interp0 : + ('raw, 'glb, 'top) genarg_type -> ('glb, Val.t) interp_fun -> unit diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml new file mode 100644 index 0000000000..e76eb2a7de --- /dev/null +++ b/pretyping/globEnv.ml @@ -0,0 +1,199 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Pp +open CErrors +open Names +open Environ +open EConstr +open Evarutil +open Termops +open Vars +open Ltac_pretype + +(** This files provides a level of abstraction for the kind of + environment used for type inference (so-called pretyping); in + particular: + - it supports that term variables can be interpreted as Ltac + variables pointing to the effective expected name + - it incrementally and lazily computes the renaming of rel + variables used to build purely-named evar contexts +*) + +type t = { + static_env : env; + (** For locating indices *) + renamed_env : env; + (** For name management *) + extra : ext_named_context Lazy.t; + (** Delay the computation of the evar extended environment *) + lvar : ltac_var_map; +} + +let make ~hypnaming env sigma lvar = + let get_extra env sigma = + let avoid = Environ.ids_of_named_context_val (Environ.named_context_val env) in + Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context ~hypnaming sigma d acc) + (rel_context env) ~init:(empty_csubst, avoid, named_context env) in + { + static_env = env; + renamed_env = env; + extra = lazy (get_extra env sigma); + lvar = lvar; + } + +let env env = env.static_env + +let vars_of_env env = + Id.Set.union (Id.Map.domain env.lvar.ltac_genargs) (vars_of_env env.static_env) + +let ltac_interp_id { ltac_idents ; ltac_genargs } id = + try Id.Map.find id ltac_idents + with Not_found -> + if Id.Map.mem id ltac_genargs then + user_err (str "Ltac variable" ++ spc () ++ Id.print id ++ + spc () ++ str "is not bound to an identifier." ++ + spc () ++str "It cannot be used in a binder.") + else id + +let ltac_interp_name lvar = Nameops.Name.map (ltac_interp_id lvar) + +let push_rel ~hypnaming sigma d env = + let d' = Context.Rel.Declaration.map_name (ltac_interp_name env.lvar) d in + let env = { + static_env = push_rel d env.static_env; + renamed_env = push_rel d' env.renamed_env; + extra = lazy (push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d' (Lazy.force env.extra)); + lvar = env.lvar; + } in + d', env + +let push_rel_context ~hypnaming ?(force_names=false) sigma ctx env = + let open Context.Rel.Declaration in + let ctx' = List.Smart.map (map_name (ltac_interp_name env.lvar)) ctx in + let ctx' = if force_names then Namegen.name_context env.renamed_env sigma ctx' else ctx' in + let env = { + static_env = push_rel_context ctx env.static_env; + renamed_env = push_rel_context ctx' env.renamed_env; + extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d acc) ctx' (Lazy.force env.extra)); + lvar = env.lvar; + } in + ctx', env + +let push_rec_types ~hypnaming sigma (lna,typarray) env = + let open Context.Rel.Declaration in + let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in + let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e ~hypnaming in (e,d)) env ctxt in + Array.map get_annot ctx, env + +let new_evar env sigma ?src ?naming typ = + let open Context.Named.Declaration in + let inst_vars = List.map (get_id %> mkVar) (named_context env.renamed_env) in + let inst_rels = List.rev (rel_list 0 (nb_rel env.renamed_env)) in + let (subst, _, nc) = Lazy.force env.extra in + let typ' = csubst_subst subst typ in + let instance = inst_rels @ inst_vars in + let sign = val_of_named_context nc in + new_evar_instance sign sigma typ' ?src ?naming instance + +let new_type_evar env sigma ~src = + let sigma, s = Evd.new_sort_variable Evd.univ_flexible_alg sigma in + new_evar env sigma ~src (EConstr.mkSort s) + +let hide_variable env expansion id = + let lvar = env.lvar in + if Id.Map.mem id lvar.ltac_genargs then + let lvar = match expansion with + | Name id' -> + (* We are typically in a situation [match id return P with ... end] + which we interpret as [match id' as id' return P with ... end], + with [P] interpreted in an environment where [id] is bound to [id']. + The variable is already bound to [id'], so nothing to do *) + lvar + | _ -> + (* We are typically in a situation [match id return P with ... end] + with [id] bound to a non-variable term [c]. We interpret as + [match c as id return P with ... end], and hides [id] while + interpreting [P], since it has become a binder and cannot be anymore be + substituted by a variable coming from the Ltac substitution. *) + { lvar with + ltac_uconstrs = Id.Map.remove id lvar.ltac_uconstrs; + ltac_constrs = Id.Map.remove id lvar.ltac_constrs; + ltac_genargs = Id.Map.remove id lvar.ltac_genargs } in + { env with lvar } + else + env + +let protected_get_type_of env sigma c = + try Retyping.get_type_of ~lax:true env sigma c + with Retyping.RetypeError _ -> + user_err + (str "Cannot reinterpret " ++ quote (Termops.Internal.print_constr_env env sigma c) ++ + str " in the current environment.") + +let invert_ltac_bound_name env id0 id = + try mkRel (pi1 (lookup_rel_id id (rel_context env.static_env))) + with Not_found -> + user_err (str "Ltac variable " ++ Id.print id0 ++ + str " depends on pattern variable name " ++ Id.print id ++ + str " which is not bound in current context.") + +let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_judgment = + (* Check if [id] is an ltac variable *) + try + let (ids,c) = Id.Map.find id env.lvar.ltac_constrs in + let subst = List.map (invert_ltac_bound_name env id) ids in + let c = substl subst c in + sigma, { uj_val = c; uj_type = protected_get_type_of env.renamed_env sigma c } + with Not_found -> + try + let {closure;term} = Id.Map.find id env.lvar.ltac_uconstrs in + let lvar = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = Id.Map.empty; } + in + (* spiwack: I'm catching [Not_found] potentially too eagerly + here, as the call to the main pretyping function is caught + inside the try but I want to avoid refactoring this function + too much for now. *) + typing_fun {env with lvar} term + with Not_found -> + (* Check if [id] is a ltac variable not bound to a term *) + (* and build a nice error message *) + if Id.Map.mem id env.lvar.ltac_genargs then begin + let Geninterp.Val.Dyn (typ, _) = Id.Map.find id env.lvar.ltac_genargs in + user_err ?loc + (str "Variable " ++ Id.print id ++ str " should be bound to a term but is \ + bound to a " ++ Geninterp.Val.pr typ ++ str ".") + end; + raise Not_found + +let interp_ltac_id env id = ltac_interp_id env.lvar id + +module ConstrInterpObj = +struct + type ('r, 'g, 't) obj = + unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + let name = "constr_interp" + let default _ = None +end + +module ConstrInterp = Genarg.Register(ConstrInterpObj) + +let register_constr_interp0 = ConstrInterp.register0 + +let interp_glob_genarg env poly sigma ty arg = + let open Genarg in + let GenArg (Glbwit tag, arg) = arg in + let interp = ConstrInterp.obj tag in + interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli new file mode 100644 index 0000000000..cdd36bbba6 --- /dev/null +++ b/pretyping/globEnv.mli @@ -0,0 +1,89 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open Evd +open EConstr +open Ltac_pretype +open Evarutil + +(** To embed constr in glob_constr *) + +val register_constr_interp0 : + ('r, 'g, 't) Genarg.genarg_type -> + (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + +(** {6 Pretyping name management} *) + +(** The following provides a level of abstraction for the kind of + environment used for type inference (so-called pretyping); in + particular: + - it supports that term variables can be interpreted as Ltac + variables pointing to the effective expected name + - it incrementally and lazily computes the renaming of rel + variables used to build purely-named evar contexts +*) + +(** Type of environment extended with naming and ltac interpretation data *) + +type t + +(** Build a pretyping environment from an ltac environment *) + +val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t + +(** Export the underlying environement *) + +val env : t -> env + +val vars_of_env : t -> Id.Set.t + +(** Push to the environment, returning the declaration(s) with interpreted names *) + +val push_rel : hypnaming:naming_mode -> evar_map -> rel_declaration -> t -> rel_declaration * t +val push_rel_context : hypnaming:naming_mode -> ?force_names:bool -> evar_map -> rel_context -> t -> rel_context * t +val push_rec_types : hypnaming:naming_mode -> evar_map -> Name.t Context.binder_annot array * constr array -> t -> Name.t Context.binder_annot array * t + +(** Declare an evar using renaming information *) + +val new_evar : t -> evar_map -> ?src:Evar_kinds.t Loc.located -> + ?naming:Namegen.intro_pattern_naming_expr -> constr -> evar_map * constr + +val new_type_evar : t -> evar_map -> src:Evar_kinds.t Loc.located -> evar_map * constr + +(** [hide_variable env na id] tells to hide the binding of [id] in + the ltac environment part of [env] and to additionally rebind + it to [id'] in case [na] is some [Name id']. It is useful e.g. + for the dual status of [y] as term and binder. This is the case + of [match y return p with ... end] which implicitly denotes + [match z as z return p with ... end] when [y] is bound to a + variable [z] and [match t as y return p with ... end] when [y] + is bound to a non-variable term [t]. In the latter case, the + binding of [y] to [t] should be hidden in [p]. *) + +val hide_variable : t -> Name.t -> Id.t -> t + +(** In case a variable is not bound by a term binder, look if it has + an interpretation as a term in the ltac_var_map *) + +val interp_ltac_variable : ?loc:Loc.t -> (t -> Glob_term.glob_constr -> evar_map * unsafe_judgment) -> + t -> evar_map -> Id.t -> evar_map * unsafe_judgment + +(** Interp an identifier as an ltac variable bound to an identifier, + or as the identifier itself if not bound to an ltac variable *) + +val interp_ltac_id : t -> Id.t -> Id.t + +(** Interpreting a generic argument, typically a "ltac:(...)", taking + into account the possible renaming *) + +val interp_glob_genarg : t -> bool -> evar_map -> constr -> + Genarg.glob_generic_argument -> constr * evar_map diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml new file mode 100644 index 0000000000..85b9faac77 --- /dev/null +++ b/pretyping/glob_ops.ml @@ -0,0 +1,582 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open CAst +open Names +open Nameops +open Globnames +open Glob_term +open Evar_kinds + +(* Untyped intermediate terms, after ASTs and before constr. *) + +let cases_pattern_loc c = c.CAst.loc + +let alias_of_pat pat = DAst.with_val (function + | PatVar name -> name + | PatCstr(_,_,name) -> name + ) pat + +let set_pat_alias id = DAst.map (function + | PatVar Anonymous -> PatVar (Name id) + | PatCstr (cstr,patl,Anonymous) -> PatCstr (cstr,patl,Name id) + | pat -> assert false) + +let cases_predicate_names tml = + List.flatten (List.map (function + | (tm,(na,None)) -> [na] + | (tm,(na,Some {v=(_,nal)})) -> na::nal) tml) + +let mkGApp ?loc p t = DAst.make ?loc @@ + match DAst.get p with + | GApp (f,l) -> GApp (f,l@[t]) + | _ -> GApp (p,[t]) + +let map_glob_decl_left_to_right f (na,k,obd,ty) = + let comp1 = Option.map f obd in + let comp2 = f ty in + (na,k,comp1,comp2) + + +let glob_sort_eq g1 g2 = let open Glob_term in match g1, g2 with +| GSProp, GSProp +| GProp, GProp +| GSet, GSet -> true +| GType l1, GType l2 -> + List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.qualid_eq x y && Int.equal m n)) l1 l2 +| (GSProp|GProp|GSet|GType _), _ -> false + +let glob_sort_family = let open Sorts in function +| GSProp -> InSProp +| GProp -> InProp +| GSet -> InSet +| GType _ -> InType + +let binding_kind_eq bk1 bk2 = match bk1, bk2 with + | Decl_kinds.Explicit, Decl_kinds.Explicit -> true + | Decl_kinds.Implicit, Decl_kinds.Implicit -> true + | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false + +let case_style_eq s1 s2 = let open Constr in match s1, s2 with + | LetStyle, LetStyle -> true + | IfStyle, IfStyle -> true + | LetPatternStyle, LetPatternStyle -> true + | MatchStyle, MatchStyle -> true + | RegularStyle, RegularStyle -> true + | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false + +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with + | PatVar na1, PatVar na2 -> Name.equal na1 na2 + | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> + eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Name.equal na1 na2 + | (PatVar _ | PatCstr _), _ -> false + +let cast_type_eq eq t1 t2 = match t1, t2 with + | CastConv t1, CastConv t2 -> eq t1 t2 + | CastVM t1, CastVM t2 -> eq t1 t2 + | CastCoerce, CastCoerce -> true + | CastNative t1, CastNative t2 -> eq t1 t2 + | (CastConv _ | CastVM _ | CastCoerce | CastNative _), _ -> false + +let matching_var_kind_eq k1 k2 = match k1, k2 with +| FirstOrderPatVar ido1, FirstOrderPatVar ido2 -> Id.equal ido1 ido2 +| SecondOrderPatVar id1, SecondOrderPatVar id2 -> Id.equal id1 id2 +| (FirstOrderPatVar _ | SecondOrderPatVar _), _ -> false + +let tomatch_tuple_eq f (c1, p1) (c2, p2) = + let eqp {CAst.v=(i1, na1)} {CAst.v=(i2, na2)} = + eq_ind i1 i2 && List.equal Name.equal na1 na2 + in + let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in + f c1 c2 && eq_pred p1 p2 + +and cases_clause_eq f {CAst.v=(id1, p1, c1)} {CAst.v=(id2, p2, c2)} = + List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && f c1 c2 + +let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && + Option.equal f c1 c2 && f t1 t2 + +let fix_kind_eq k1 k2 = match k1, k2 with + | GFix (a1, i1), GFix (a2, i2) -> + Int.equal i1 i2 && Array.equal (Option.equal Int.equal) a1 a2 + | GCoFix i1, GCoFix i2 -> Int.equal i1 i2 + | (GFix _ | GCoFix _), _ -> false + +let instance_eq f (x1,c1) (x2,c2) = + Id.equal x1 x2 && f c1 c2 + +let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with + | GRef (gr1, _), GRef (gr2, _) -> GlobRef.equal gr1 gr2 + | GVar id1, GVar id2 -> Id.equal id1 id2 + | GEvar (id1, arg1), GEvar (id2, arg2) -> + Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 + | GPatVar k1, GPatVar k2 -> matching_var_kind_eq k1 k2 + | GApp (f1, arg1), GApp (f2, arg2) -> + f f1 f2 && List.equal f arg1 arg2 + | GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) -> + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2 + | GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) -> + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2 + | GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) -> + Name.equal na1 na2 && f b1 b2 && Option.equal f t1 t2 && f c1 c2 + | GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) -> + case_style_eq st1 st2 && Option.equal f c1 c2 && + List.equal (tomatch_tuple_eq f) tp1 tp2 && + List.equal (cases_clause_eq f) cl1 cl2 + | GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) -> + List.equal Name.equal na1 na2 && Name.equal n1 n2 && + Option.equal f p1 p2 && f c1 c2 && f t1 t2 + | GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) -> + f m1 m2 && Name.equal pat1 pat2 && + Option.equal f p1 p2 && f c1 c2 && f t1 t2 + | GRec (kn1, id1, decl1, t1, c1), GRec (kn2, id2, decl2, t2, c2) -> + fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 && + Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && + Array.equal f c1 c2 && Array.equal f t1 t2 + | GSort s1, GSort s2 -> glob_sort_eq s1 s2 + | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> + Option.equal (==) gn1 gn2 (* Only thing sensible *) && + Namegen.intro_pattern_naming_eq nam1 nam2 + | GCast (c1, t1), GCast (c2, t2) -> + f c1 c2 && cast_type_eq f t1 t2 + | GInt i1, GInt i2 -> Uint63.equal i1 i2 + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | + GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ | + GInt _), _ -> false + +let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c + +(** Mapping [cast_type] *) + +let map_cast_type f = function + | CastConv a -> CastConv (f a) + | CastVM a -> CastVM (f a) + | CastCoerce -> CastCoerce + | CastNative a -> CastNative (f a) + +let smartmap_cast_type f c = + match c with + | CastConv a -> let a' = f a in if a' == a then c else CastConv a' + | CastVM a -> let a' = f a in if a' == a then c else CastVM a' + | CastCoerce -> CastCoerce + | CastNative a -> let a' = f a in if a' == a then c else CastNative a' + +let map_glob_constr_left_to_right f = DAst.map (function + | GApp (g,args) -> + let comp1 = f g in + let comp2 = Util.List.map_left f args in + GApp (comp1,comp2) + | GLambda (na,bk,ty,c) -> + let comp1 = f ty in + let comp2 = f c in + GLambda (na,bk,comp1,comp2) + | GProd (na,bk,ty,c) -> + let comp1 = f ty in + let comp2 = f c in + GProd (na,bk,comp1,comp2) + | GLetIn (na,b,t,c) -> + let comp1 = f b in + let compt = Option.map f t in + let comp2 = f c in + GLetIn (na,comp1,compt,comp2) + | GCases (sty,rtntypopt,tml,pl) -> + let comp1 = Option.map f rtntypopt in + let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in + let comp3 = Util.List.map_left (CAst.map (fun (idl,p,c) -> (idl,p,f c))) pl in + GCases (sty,comp1,comp2,comp3) + | GLetTuple (nal,(na,po),b,c) -> + let comp1 = Option.map f po in + let comp2 = f b in + let comp3 = f c in + GLetTuple (nal,(na,comp1),comp2,comp3) + | GIf (c,(na,po),b1,b2) -> + let comp1 = Option.map f po in + let comp2 = f b1 in + let comp3 = f b2 in + GIf (f c,(na,comp1),comp2,comp3) + | GRec (fk,idl,bl,tyl,bv) -> + let comp1 = Array.map (Util.List.map_left (map_glob_decl_left_to_right f)) bl in + let comp2 = Array.map f tyl in + let comp3 = Array.map f bv in + GRec (fk,idl,comp1,comp2,comp3) + | GCast (c,k) -> + let comp1 = f c in + let comp2 = map_cast_type f k in + GCast (comp1,comp2) + | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) as x -> x + ) + +let map_glob_constr = map_glob_constr_left_to_right + +let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt + +let fold_glob_constr f acc = DAst.with_val (function + | GVar _ -> acc + | GApp (c,args) -> List.fold_left f (f acc c) args + | GLambda (_,_,b,c) | GProd (_,_,b,c) -> + f (f acc b) c + | GLetIn (_,b,t,c) -> + f (Option.fold_left f (f acc b) t) c + | GCases (_,rtntypopt,tml,pl) -> + let fold_pattern acc {CAst.v=(idl,p,c)} = f acc c in + List.fold_left fold_pattern + (List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml)) + pl + | GLetTuple (_,rtntyp,b,c) -> + f (f (fold_return_type f acc rtntyp) b) c + | GIf (c,rtntyp,b1,b2) -> + f (f (f (fold_return_type f acc rtntyp) c) b1) b2 + | GRec (_,_,bl,tyl,bv) -> + let acc = Array.fold_left + (List.fold_left (fun acc (na,k,bbd,bty) -> + f (Option.fold_left f acc bbd) bty)) acc bl in + Array.fold_left f (Array.fold_left f acc tyl) bv + | GCast (c,k) -> + let acc = match k with + | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in + f acc c + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) -> acc + ) +let fold_return_type_with_binders f g v acc (na,tyopt) = + Option.fold_left (f (Name.fold_right g na v)) acc tyopt + +let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function + | GVar _ -> acc + | GApp (c,args) -> List.fold_left (f v) (f v acc c) args + | GLambda (na,_,b,c) | GProd (na,_,b,c) -> + f (Name.fold_right g na v) (f v acc b) c + | GLetIn (na,b,t,c) -> + f (Name.fold_right g na v) (Option.fold_left (f v) (f v acc b) t) c + | GCases (_,rtntypopt,tml,pl) -> + let fold_pattern acc {v=(idl,p,c)} = f (List.fold_right g idl v) acc c in + let fold_tomatch (v',acc) (tm,(na,onal)) = + ((if rtntypopt = None then v' else + Option.fold_left (fun v'' {v=(_,nal)} -> List.fold_right (Name.fold_right g) nal v'') + (Name.fold_right g na v') onal), + f v acc tm) in + let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in + let acc = Option.fold_left (f v') acc rtntypopt in + List.fold_left fold_pattern acc pl + | GLetTuple (nal,rtntyp,b,c) -> + f (List.fold_right (Name.fold_right g) nal v) + (f v (fold_return_type_with_binders f g v acc rtntyp) b) c + | GIf (c,rtntyp,b1,b2) -> + f v (f v (f v (fold_return_type_with_binders f g v acc rtntyp) c) b1) b2 + | GRec (_,idl,bll,tyl,bv) -> + let v' = Array.fold_right g idl v in + let f' i acc fid = + let v,acc = + List.fold_left + (fun (v,acc) (na,k,bbd,bty) -> + (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty)) + (v,acc) + bll.(i) in + f v' (f v acc tyl.(i)) (bv.(i)) in + Array.fold_left_i f' acc idl + | GCast (c,k) -> + let acc = match k with + | CastConv t | CastVM t | CastNative t -> f v acc t | CastCoerce -> acc in + f v acc c + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) -> acc)) + +let iter_glob_constr f = fold_glob_constr (fun () -> f) () + +let occur_glob_constr id = + let rec occur barred acc c = match DAst.get c with + | GVar id' -> Id.equal id id' + | _ -> + (* [g] looks if [id] appears in a binding position, in which + case, we don't have to look in the corresponding subterm *) + let g id' barred = barred || Id.equal id id' in + let f barred acc c = acc || not barred && occur false acc c in + fold_glob_constr_with_binders g f barred acc c in + occur false false + +let free_glob_vars = + let rec vars bound vs c = match DAst.get c with + | GVar id' -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs + | _ -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in + fun rt -> + let vs = vars Id.Set.empty Id.Set.empty rt in + vs + +let glob_visible_short_qualid c = + let rec aux acc c = match DAst.get c with + | GRef (c,_) -> + let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in + let dir,id = Libnames.repr_qualid qualid in + if DirPath.is_empty dir then Id.Set.add id acc else acc + | _ -> + fold_glob_constr aux acc c + in aux Id.Set.empty c + +let warn_variable_collision = + let open Pp in + CWarnings.create ~name:"variable-collision" ~category:"ltac" + (fun name -> + strbrk "Collision between bound variables of name " ++ Id.print name) + +let add_and_check_ident id set = + if Id.Set.mem id set then warn_variable_collision id; + Id.Set.add id set + +let bound_glob_vars = + let rec vars bound = + fold_glob_constr_with_binders + (fun id () -> bound := add_and_check_ident id !bound) + (fun () () -> vars bound) + () () + in + fun rt -> + let bound = ref Id.Set.empty in + vars bound rt; + !bound + +(** Mapping of names in binders *) + +(* spiwack: I used a smart-style kind of mapping here, because the + operation will be the identity almost all of the time (with any + term outside of Ltac to begin with). But to be honest, there would + probably be no significant penalty in doing reallocation as + pattern-matching expressions are usually rather small. *) + +let map_inpattern_binders f ({loc;v=(id,nal)} as x) = + let r = CList.Smart.map f nal in + if r == nal then x + else CAst.make ?loc (id,r) + +let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple = + let r = Option.Smart.map (fun p -> map_inpattern_binders f p) inp in + if r == inp then x + else c,(f na, r) + +let rec map_case_pattern_binders f = DAst.map (function + | PatVar na as x -> + let r = f na in + if r == na then x + else PatVar r + | PatCstr (c,ps,na) as x -> + let rna = f na in + let rps = + CList.Smart.map (fun p -> map_case_pattern_binders f p) ps + in + if rna == na && rps == ps then x + else PatCstr(c,rps,rna) + ) + +let map_cases_branch_binders f ({CAst.loc;v=(il,cll,rhs)} as x) : cases_clause = + (* spiwack: not sure if I must do something with the list of idents. + It is intended to be a superset of the free variable of the + right-hand side, if I understand correctly. But I'm not sure when + or how they are used. *) + let r = List.Smart.map (fun cl -> map_case_pattern_binders f cl) cll in + if r == cll then x + else CAst.make ?loc (il,r,rhs) + +let map_pattern_binders f tomatch branches = + CList.Smart.map (fun tm -> map_tomatch_binders f tm) tomatch, + CList.Smart.map (fun br -> map_cases_branch_binders f br) branches + +(** /mapping of names in binders *) + +let map_tomatch f (c,pp) : tomatch_tuple = f c , pp + +let map_cases_branch f = + CAst.map (fun (il,cll,rhs) -> (il , cll , f rhs)) + +let map_pattern f tomatch branches = + List.map (fun tm -> map_tomatch f tm) tomatch, + List.map (fun br -> map_cases_branch f br) branches + +let loc_of_glob_constr c = c.CAst.loc + +(**********************************************************************) +(* Alpha-renaming *) + +exception UnsoundRenaming + +let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l +let test_id l id = if collide_id l id then raise UnsoundRenaming +let test_na l na = Name.iter (test_id l) na + +let update_subst na l = + let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in + let l' = Name.fold_right Id.List.remove_assoc na l in + Name.fold_right + (fun id _ -> + if in_range id l' then + let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in + Name id', (id,id')::l + else na,l) + na (na,l) + +let rename_var l id = + try + let id' = Id.List.assoc id l in + (* Check that no other earlier binding hide the one found *) + let _,(id'',_) = List.extract_first (fun (_,id) -> Id.equal id id') l in + if Id.equal id id'' then id' else raise UnsoundRenaming + with Not_found -> + if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming + else id + +let force c = DAst.make ?loc:c.CAst.loc (DAst.get c) + +let rec rename_glob_vars l c = force @@ DAst.map_with_loc (fun ?loc -> function + | GVar id as r -> + let id' = rename_var l id in + if id == id' then r else GVar id' + | GRef (VarRef id,_) as r -> + if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming + else r + | GProd (na,bk,t,c) -> + let na',l' = update_subst na l in + GProd (na',bk,rename_glob_vars l t,rename_glob_vars l' c) + | GLambda (na,bk,t,c) -> + let na',l' = update_subst na l in + GLambda (na',bk,rename_glob_vars l t,rename_glob_vars l' c) + | GLetIn (na,b,t,c) -> + let na',l' = update_subst na l in + GLetIn (na',rename_glob_vars l b,Option.map (rename_glob_vars l) t,rename_glob_vars l' c) + (* Lazy strategy: we fail if a collision with renaming occurs, rather than renaming further *) + | GCases (ci,po,tomatchl,cls) -> + let test_pred_pat (na,ino) = + test_na l na; Option.iter (fun {v=(_,nal)} -> List.iter (test_na l) nal) ino in + let test_clause idl = List.iter (test_id l) idl in + let po = Option.map (rename_glob_vars l) po in + let tomatchl = Util.List.map_left (fun (tm,x) -> test_pred_pat x; (rename_glob_vars l tm,x)) tomatchl in + let cls = Util.List.map_left (CAst.map (fun (idl,p,c) -> test_clause idl; (idl,p,rename_glob_vars l c))) cls in + GCases (ci,po,tomatchl,cls) + | GLetTuple (nal,(na,po),c,b) -> + List.iter (test_na l) (na::nal); + GLetTuple (nal,(na,Option.map (rename_glob_vars l) po), + rename_glob_vars l c,rename_glob_vars l b) + | GIf (c,(na,po),b1,b2) -> + test_na l na; + GIf (rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po), + rename_glob_vars l b1,rename_glob_vars l b2) + | GRec (k,idl,decls,bs,ts) -> + Array.iter (test_id l) idl; + GRec (k,idl, + Array.map (List.map (fun (na,k,bbd,bty) -> + test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls, + Array.map (rename_glob_vars l) bs, + Array.map (rename_glob_vars l) ts) + | _ -> DAst.get (map_glob_constr (rename_glob_vars l) c) + ) c + +(**********************************************************************) +(* Conversion from glob_constr to cases pattern, if possible *) + +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + +let rec cases_pattern_of_glob_constr env na c = + (* Forcing evaluation to ensure that the possible raising of + Not_found is not delayed *) + let c = DAst.force c in + DAst.map (function + | GVar id -> + begin match na with + | Name _ -> + (* Unable to manage the presence of both an alias and a variable *) + raise Not_found + | Anonymous -> PatVar (Name id) + end + | GHole (_,_,_) -> PatVar na + | GRef (ConstructRef cstr,_) -> PatCstr (cstr,[],na) + | GApp (c, l) -> + begin match DAst.get c with + | GRef (ConstructRef cstr,_) -> + let nparams = Inductiveops.inductive_nparams env (fst cstr) in + let _,l = List.chop nparams l in + PatCstr (cstr,List.map (cases_pattern_of_glob_constr env Anonymous) l,na) + | _ -> raise Not_found + end + | GLetIn (Name id as na',b,None,e) when is_gvar id e && na = Anonymous -> + (* A canonical encoding of aliases *) + DAst.get (cases_pattern_of_glob_constr env na' b) + | _ -> raise Not_found + ) c + +open Declarations +open Context + +(* Keep only patterns which are not bound to a local definitions *) +let drop_local_defs params decls args = + let decls = List.skipn (Rel.length params) (List.rev decls) in + let rec aux decls args = + match decls, args with + | [], [] -> [] + | Rel.Declaration.LocalDef _ :: decls, pat :: args -> + begin + match DAst.get pat with + | PatVar Anonymous -> aux decls args + | _ -> raise Not_found (* The pattern is used, one cannot drop it *) + end + | Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args + | _ -> assert false in + aux decls args + +let add_patterns_for_params_remove_local_defs env (ind,j) l = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nparams = mib.Declarations.mind_nparams in + let l = + if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then + (* Optimisation *) l + else + let (ctx, _) = mip.mind_nf_lc.(j - 1) in + drop_local_defs mib.mind_params_ctxt ctx l in + Util.List.addn nparams (DAst.make @@ PatVar Anonymous) l + +let add_alias ?loc na c = + match na with + | Anonymous -> c + | Name id -> GLetIn (na,DAst.make ?loc c,None,DAst.make ?loc (GVar id)) + +(* Turn a closed cases pattern into a glob_constr *) +let rec glob_constr_of_cases_pattern_aux env isclosed x = DAst.map_with_loc (fun ?loc -> function + | PatCstr (cstr,[],na) -> add_alias ?loc na (GRef (ConstructRef cstr,None)) + | PatCstr (cstr,l,na) -> + let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in + let l = add_patterns_for_params_remove_local_defs env cstr l in + add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux env isclosed) l)) + | PatVar (Name id) when not isclosed -> + GVar id + | PatVar Anonymous when not isclosed -> + GHole (Evar_kinds.QuestionMark { + Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Define false; + },Namegen.IntroAnonymous,None) + | _ -> raise Not_found + ) x + +let glob_constr_of_closed_cases_pattern env p = match DAst.get p with + | PatCstr (cstr,l,na) -> + let loc = p.CAst.loc in + na,glob_constr_of_cases_pattern_aux env true (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) + | _ -> + raise Not_found + +let glob_constr_of_cases_pattern env p = glob_constr_of_cases_pattern_aux env false p + +(* This has to be in some file... *) + +open Ltac_pretype + +let empty_lvar : ltac_var_map = { + ltac_constrs = Id.Map.empty; + ltac_uconstrs = Id.Map.empty; + ltac_idents = Id.Map.empty; + ltac_genargs = Id.Map.empty; +} diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli new file mode 100644 index 0000000000..df902a8fa7 --- /dev/null +++ b/pretyping/glob_ops.mli @@ -0,0 +1,108 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Glob_term + +(** Equalities *) + +val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool + +val glob_sort_family : 'a glob_sort_gen -> Sorts.family + +val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool + +val alias_of_pat : 'a cases_pattern_g -> Name.t + +val set_pat_alias : Id.t -> 'a cases_pattern_g -> 'a cases_pattern_g + +val cast_type_eq : ('a -> 'a -> bool) -> + 'a cast_type -> 'a cast_type -> bool + +val glob_constr_eq : 'a glob_constr_g -> 'a glob_constr_g -> bool + +(** Mapping [cast_type] *) + +val map_cast_type : ('a -> 'b) -> 'a cast_type -> 'b cast_type +val smartmap_cast_type : ('a -> 'a) -> 'a cast_type -> 'a cast_type + +(** Operations on [glob_constr] *) + +val cases_pattern_loc : 'a cases_pattern_g -> Loc.t option + +val cases_predicate_names : 'a tomatch_tuples_g -> Name.t list + +(** Apply one argument to a glob_constr *) +val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g -> 'a glob_constr_g + +val map_glob_constr : + (glob_constr -> glob_constr) -> glob_constr -> glob_constr + +(** Ensure traversal from left to right *) +val map_glob_constr_left_to_right : + (glob_constr -> glob_constr) -> glob_constr -> glob_constr + +val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit + +val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) -> + glob_constr -> glob_constr -> bool + +val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a +val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b +val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit +val occur_glob_constr : Id.t -> 'a glob_constr_g -> bool +val free_glob_vars : 'a glob_constr_g -> Id.Set.t +val bound_glob_vars : glob_constr -> Id.Set.t +(* Obsolete *) +val loc_of_glob_constr : 'a glob_constr_g -> Loc.t option +val glob_visible_short_qualid : 'a glob_constr_g -> Id.Set.t + +(* Renaming free variables using a renaming map; fails with + [UnsoundRenaming] if applying the renaming would introduce + collision, as in, e.g., renaming [P x y] using substitution [(x,y)]; + inner alpha-conversion done only for forall, fun, let but + not for cases and fix *) + +exception UnsoundRenaming +val rename_var : (Id.t * Id.t) list -> Id.t -> Id.t +val rename_glob_vars : (Id.t * Id.t) list -> 'a glob_constr_g -> 'a glob_constr_g + +(** [map_pattern_binders f m c] applies [f] to all the binding names + in a pattern-matching expression ({!Glob_term.GCases}) represented + here by its relevant components [m] and [c]. It is used to + interpret Ltac-bound names both in pretyping and printing of + terms. *) +val map_pattern_binders : (Name.t -> Name.t) -> + tomatch_tuples -> cases_clauses -> (tomatch_tuples*cases_clauses) + +(** [map_pattern f m c] applies [f] to the return predicate and the + right-hand side of a pattern-matching expression + ({!Glob_term.GCases}) represented here by its relevant components + [m] and [c]. *) +val map_pattern : (glob_constr -> glob_constr) -> + tomatch_tuples -> cases_clauses -> (tomatch_tuples*cases_clauses) + +(** Conversion from glob_constr to cases pattern, if possible + + Evaluation is forced. + Take the current alias as parameter, + @raise Not_found if translation is impossible *) +val cases_pattern_of_glob_constr : Environ.env -> Name.t -> 'a glob_constr_g -> 'a cases_pattern_g + +val glob_constr_of_closed_cases_pattern : Environ.env -> 'a cases_pattern_g -> Name.t * 'a glob_constr_g + +(** A canonical encoding of cases pattern into constr such that + composed with [cases_pattern_of_glob_constr Anonymous] gives identity *) +val glob_constr_of_cases_pattern : Environ.env -> 'a cases_pattern_g -> 'a glob_constr_g + +val add_patterns_for_params_remove_local_defs : Environ.env -> constructor -> + 'a cases_pattern_g list -> 'a cases_pattern_g list + +val empty_lvar : Ltac_pretype.ltac_var_map diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml new file mode 100644 index 0000000000..02cb294f6d --- /dev/null +++ b/pretyping/glob_term.ml @@ -0,0 +1,135 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Untyped intermediate terms *) + +(** [glob_constr] comes after [constr_expr] and before [constr]. + + Resolution of names, insertion of implicit arguments placeholder, + and notations are done, but coercions, inference of implicit + arguments and pattern-matching compilation are not. *) + +open Names +open Decl_kinds + +type existential_name = Id.t + +(** Sorts *) + +type 'a glob_sort_gen = + | GSProp (** representation of [SProp] literal *) + | GProp (** representation of [Prop] literal *) + | GSet (** representation of [Set] literal *) + | GType of 'a (** representation of [Type] literal *) + +type 'a universe_kind = + | UAnonymous + | UUnknown + | UNamed of 'a + +type level_info = Libnames.qualid universe_kind +type glob_level = level_info glob_sort_gen +type glob_constraint = glob_level * Univ.constraint_type * glob_level + +type sort_info = (Libnames.qualid * int) option list +type glob_sort = sort_info glob_sort_gen + +type glob_recarg = int option + +and glob_fix_kind = + | GFix of (glob_recarg array * int) + | GCoFix of int + +(** Casts *) + +type 'a cast_type = + | CastConv of 'a + | CastVM of 'a + | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *) + | CastNative of 'a + +(** The kind of patterns that occurs in "match ... with ... end" + + locs here refers to the ident's location, not whole pat *) +type 'a cases_pattern_r = + | PatVar of Name.t + | PatCstr of constructor * 'a cases_pattern_g list * Name.t + (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) +and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t + +type cases_pattern = [ `any ] cases_pattern_g + +(** Representation of an internalized (or in other words globalized) term. *) +type 'a glob_constr_r = + | GRef of GlobRef.t * glob_level list option + (** An identifier that represents a reference to an object defined + either in the (global) environment or in the (local) context. *) + | GVar of Id.t + (** An identifier that cannot be regarded as "GRef". + Bound variables are typically represented this way. *) + | GEvar of existential_name * (Id.t * 'a glob_constr_g) list + | GPatVar of Evar_kinds.matching_var_kind (** Used for patterns only *) + | GApp of 'a glob_constr_g * 'a glob_constr_g list + | GLambda of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GProd of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GLetIn of Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g + | GCases of Constr.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g + (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) + | GLetTuple of Name.t list * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GIf of 'a glob_constr_g * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GRec of glob_fix_kind * Id.t array * 'a glob_decl_g list array * + 'a glob_constr_g array * 'a glob_constr_g array + | GSort of glob_sort + | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option + | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type + | GInt of Uint63.t +and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t + +and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g + +and 'a predicate_pattern_g = + Name.t * (inductive * Name.t list) CAst.t option + (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) + +and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) + +and 'a tomatch_tuples_g = 'a tomatch_tuple_g list + +and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) CAst.t +(** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables + of [t] are members of [il]. *) + +and 'a cases_clauses_g = 'a cases_clause_g list + +type glob_constr = [ `any ] glob_constr_g +type tomatch_tuple = [ `any ] tomatch_tuple_g +type tomatch_tuples = [ `any ] tomatch_tuples_g +type cases_clause = [ `any ] cases_clause_g +type cases_clauses = [ `any ] cases_clauses_g +type glob_decl = [ `any ] glob_decl_g +type predicate_pattern = [ `any ] predicate_pattern_g + +type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr + +type 'a disjunctive_cases_clause_g = (Id.t list * 'a cases_pattern_g list list * 'a glob_constr_g) CAst.t +type 'a disjunctive_cases_clauses_g = 'a disjunctive_cases_clause_g list +type 'a cases_pattern_disjunction_g = 'a cases_pattern_g list + +type disjunctive_cases_clause = [ `any ] disjunctive_cases_clause_g +type disjunctive_cases_clauses = [ `any ] disjunctive_cases_clauses_g +type cases_pattern_disjunction = [ `any ] cases_pattern_disjunction_g + +type 'a extended_glob_local_binder_r = + | GLocalAssum of Name.t * binding_kind * 'a glob_constr_g + | GLocalDef of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g option + | GLocalPattern of ('a cases_pattern_disjunction_g * Id.t list) * Id.t * binding_kind * 'a glob_constr_g +and 'a extended_glob_local_binder_g = ('a extended_glob_local_binder_r, 'a) DAst.t + +type extended_glob_local_binder = [ `any ] extended_glob_local_binder_g diff --git a/pretyping/heads.ml b/pretyping/heads.ml new file mode 100644 index 0000000000..ef27ca9b4e --- /dev/null +++ b/pretyping/heads.ml @@ -0,0 +1,114 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Constr +open Vars +open Environ +open Context.Named.Declaration + +(** Characterization of the head of a term *) + +(* We only compute an approximation to ensure the computation is not + arbitrary long (e.g. the head constant of [h] defined to be + [g (fun x -> phi(x))] where [g] is [fun f => g O] does not launch + the evaluation of [phi(0)] and the head of [h] is declared unknown). *) + +type rigid_head_kind = +| RigidParameter of Constant.t (* a Const without body. Module substitution may instantiate it with something else. *) +| RigidOther (* a Var without body, inductive, product, sort, projection *) + +type head_approximation = +| RigidHead of rigid_head_kind +| ConstructorHead +| FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) +| NotImmediatelyComputableHead + +(* FIXME: maybe change interface here *) +let rec compute_head env = function + | EvalConstRef cst -> + let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in + (match body with + | None -> RigidHead (RigidParameter cst) + | Some c -> kind_of_head env c) + | EvalVarRef id -> + (match lookup_named id env with + | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> + kind_of_head env c + | _ -> RigidHead RigidOther) + +and kind_of_head env t = + let rec aux k l t b = match kind (Reduction.whd_betaiotazeta env t) with + | Rel n when n > k -> NotImmediatelyComputableHead + | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) + | Var id -> + (try on_subterm k l b (compute_head env (EvalVarRef id)) + with Not_found -> + (* a goal variable *) + match lookup_named id env with + | LocalDef (_,c,_) -> aux k l c b + | LocalAssum _ -> NotImmediatelyComputableHead) + | Const (cst,_) -> + (try on_subterm k l b (compute_head env (EvalConstRef cst)) + with Not_found -> + CErrors.anomaly + Pp.(str "constant not found in kind_of_head: " ++ + Names.Constant.print cst ++ + str ".")) + | Construct _ | CoFix _ -> + if b then NotImmediatelyComputableHead else ConstructorHead + | Sort _ | Ind _ | Prod _ -> RigidHead RigidOther + | Cast (c,_,_) -> aux k l c b + | Lambda (_,_,c) -> + begin match l with + | [] -> + let () = assert (not b) in + aux (k + 1) [] c b + | h :: l -> aux k l (subst1 h c) b + end + | LetIn _ -> assert false + | Meta _ | Evar _ -> NotImmediatelyComputableHead + | App (c,al) -> aux k (Array.to_list al @ l) c b + | Proj (p,c) -> RigidHead RigidOther + + | Case (_,_,c,_) -> aux k [] c true + | Int _ -> ConstructorHead + | Fix ((i,j),_) -> + let n = i.(j) in + try aux k [] (List.nth l n) true + with Failure _ -> FlexibleHead (k + n + 1, k + n + 1, 0, true) + and on_subterm k l with_case = function + | FlexibleHead (n,i,q,with_subcase) -> + let m = List.length l in + let k',rest,a = + if n > m then + (* eta-expansion *) + let a = + if i <= m then + (* we pick the head in the existing arguments *) + lift (n-m) (List.nth l (i-1)) + else + (* we pick the head in the added arguments *) + mkRel (n-i+1) in + k+n-m,[],a + else + (* enough arguments to [cst] *) + k,List.skipn n l,List.nth l (i-1) in + let l' = List.make q (mkMeta 0) @ rest in + aux k' l' a (with_subcase || with_case) + | ConstructorHead when with_case -> NotImmediatelyComputableHead + | x -> x + in aux 0 [] t false + +let is_rigid env t = + match kind_of_head env t with + | RigidHead _ | ConstructorHead -> true + | _ -> false diff --git a/pretyping/heads.mli b/pretyping/heads.mli new file mode 100644 index 0000000000..e5f9967590 --- /dev/null +++ b/pretyping/heads.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Environ + +(** This module is about the computation of an approximation of the + head symbol of defined constants and local definitions; it + provides the function to compute the head symbols and a table to + store the heads *) + +(** [is_rigid] tells if some term is known to ultimately reduce to a term + with a rigid head symbol *) + +val is_rigid : env -> constr -> bool diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml new file mode 100644 index 0000000000..7615a17514 --- /dev/null +++ b/pretyping/indrec.ml @@ -0,0 +1,638 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* File initially created by Christine Paulin, 1996 *) + +(* This file builds various inductive schemes *) + +open Pp +open CErrors +open Util +open Names +open Libnames +open Globnames +open Nameops +open Term +open Constr +open Context +open Vars +open Namegen +open Declarations +open Declareops +open Inductive +open Inductiveops +open Environ +open Reductionops +open Context.Rel.Declaration + +type dep_flag = bool + +(* Errors related to recursors building *) +type recursion_scheme_error = + | NotAllowedCaseAnalysis of (*isrec:*) bool * Sorts.t * pinductive + | NotMutualInScheme of inductive * inductive + | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive + +exception RecursionSchemeError of env * recursion_scheme_error + +let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na +let name_assumption env = function +| LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env t) na, t) +| LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env c) na, c, t) + +let mkLambda_or_LetIn_name env d b = mkLambda_or_LetIn (name_assumption env d) b +let mkProd_or_LetIn_name env d b = mkProd_or_LetIn (name_assumption env d) b +let mkLambda_name env (n,a,b) = mkLambda_or_LetIn_name env (LocalAssum (n,a)) b +let mkProd_name env (n,a,b) = mkProd_or_LetIn_name env (LocalAssum (n,a)) b +let it_mkProd_or_LetIn_name env b l = List.fold_left (fun c d -> mkProd_or_LetIn_name env d c) b l +let it_mkLambda_or_LetIn_name env b l = List.fold_left (fun c d -> mkLambda_or_LetIn_name env d c) b l + +let make_prod_dep dep env = if dep then mkProd_name env else mkProd +let mkLambda_string s r t c = mkLambda (make_annot (Name (Id.of_string s)) r, t, c) + + +(*******************************************) +(* Building curryfied elimination *) +(*******************************************) + +let is_private mib = + match mib.mind_private with + | Some true -> true + | _ -> false + +let check_privacy_block mib = + if is_private mib then + user_err (str"case analysis on a private inductive type") + +(**********************************************************************) +(* Building case analysis schemes *) +(* Christine Paulin, 1996 *) + +let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = + let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in + let indf = make_ind_family(pind, Context.Rel.to_extended_list mkRel 0 lnamespar) in + let constrs = get_constructors env indf in + let projs = get_projections env ind in + let relevance = Sorts.relevance_of_sort_family kind in + + let () = if Option.is_empty projs then check_privacy_block mib in + let () = + if not (Sorts.List.mem kind (elim_sorts specif)) then + raise + (RecursionSchemeError + (env, NotAllowedCaseAnalysis (false, fst (UnivGen.fresh_sort_in_family kind), pind))) + in + let ndepar = mip.mind_nrealdecls + 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 rec add_branch env k = + if Int.equal k (Array.length mip.mind_consnames) then + let nbprod = k+1 in + + let indf' = lift_inductive_family nbprod indf in + let arsign,sort = get_arity env indf' in + let r = Sorts.relevance_of_sort_family sort in + let depind = build_dependent_inductive env indf' in + let deparsign = LocalAssum (make_annot Anonymous r,depind)::arsign in + + let rci = relevance in + let ci = make_case_info env (fst pind) rci RegularStyle in + let pbody = + appvect + (mkRel (ndepar + nbprod), + if dep then Context.Rel.to_extended_vect mkRel 0 deparsign + else Context.Rel.to_extended_vect mkRel 1 arsign) in + let p = + it_mkLambda_or_LetIn_name env' + ((if dep then mkLambda_name env' else mkLambda) + (make_annot Anonymous r,depind,pbody)) + arsign + in + let obj = + match projs with + | None -> mkCase (ci, lift ndepar p, mkRel 1, + Termops.rel_vect ndepar k) + | Some ps -> + let term = + mkApp (mkRel 2, + Array.map + (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in + if dep then + let ty = mkApp (mkRel 3, [| mkRel 1 |]) in + mkCast (term, DEFAULTcast, ty) + else term + in + it_mkLambda_or_LetIn_name env' obj deparsign + else + let cs = lift_constructor (k+1) constrs.(k) in + let t = build_branch_type env sigma dep (mkRel (k+1)) cs in + mkLambda_string "f" relevance t + (add_branch (push_rel (LocalAssum (make_annot Anonymous relevance, t)) env) (k+1)) + in + let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg sigma kind in + let typP = make_arity env' sigma dep indf s in + let typP = EConstr.Unsafe.to_constr typP in + let c = + it_mkLambda_or_LetIn_name env + (mkLambda_string "P" Sorts.Relevant typP + (add_branch (push_rel (LocalAssum (make_annot Anonymous Sorts.Relevant,typP)) env') 0)) lnamespar + in + (sigma, c) + +(* check if the type depends recursively on one of the inductive scheme *) + +(**********************************************************************) +(* Building the recursive elimination *) +(* Christine Paulin, 1996 *) + +(* + * 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_allnolet_stack env sigma (EConstr.of_constr p) in + let p' = EConstr.Unsafe.to_constr p' in + let largs = List.map EConstr.Unsafe.to_constr largs in + match kind p' with + | Prod (n,t,c) -> + let d = LocalAssum (n,t) in + make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,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), Context.Rel.to_extended_list mkRel 0 sign)|] + else + base + | _ -> + let t' = whd_all env sigma (EConstr.of_constr p) in + let t' = EConstr.Unsafe.to_constr t' in + if Constr.equal p' t' then assert false + else prec env i sign t' + in + prec env 0 [] + in + let rec process_constr env i c recargs nhyps li = + if nhyps > 0 then match kind 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 _ -> (None,rest) + | _ -> (None, rest)) + in + (match optionpos with + | None -> + make_prod env + (n,t, + process_constr (push_rel (LocalAssum (n,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 (LocalAssum (n,t)) env in + let t_0 = process_pos env' dep' nP (lift 1 t) in + let r_0 = Retyping.relevance_of_type env' sigma (EConstr.of_constr t_0) in + make_prod_dep (dep || dep') env + (n,t, + mkArrow t_0 r_0 + (process_constr + (push_rel (LocalAssum (make_annot Anonymous n.binder_relevance,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 (LocalDef (n,b,t)) env) + (i+1) c_0 recargs (nhyps-1) li) + | _ -> assert false + else + if dep then + let realargs = List.rev_map (fun k -> mkRel (i-k)) li in + let params = List.map (lift i) vargs in + let co = applist (mkConstructU 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 (nparrec,fvect,decF) f cstr recargs = + let process_pos env fk = + let rec prec env i hyps p = + let p',largs = whd_allnolet_stack env sigma (EConstr.of_constr p) in + let p' = EConstr.Unsafe.to_constr p' in + let largs = List.map EConstr.Unsafe.to_constr largs in + match kind p' with + | Prod (n,t,c) -> + let d = LocalAssum (n,t) in + mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) + | Ind _ -> + let realargs = List.skipn nparrec largs + and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect mkRel 0 hyps) in + applist(lift i fk,realargs@[arg]) + | _ -> + let t' = whd_all env sigma (EConstr.of_constr p) in + let t' = EConstr.Unsafe.to_constr t' in + if Constr.equal t' p' then assert false + else prec env i hyps t' + in + prec env 0 [] + in + (* ici, cstrprods est la liste des produits du constructeur instantié *) + let rec process_constr env i f = function + | (LocalAssum (n,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 -> + mkLambda_name env + (n,t,process_constr (push_rel d env) (i+1) + (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (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 + mkLambda_name env + (n,t,process_constr env' (i+1) + (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) + (cprest,rest))) + | (LocalDef (n,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 (Pp.str "process_constr.") + + in + process_constr env 0 f (List.rev cstr.cs_args, recargs) + +(* Main function *) +let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + let evdref = ref sigma in + let lnonparrec,lnamesparrec = + Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in + let nrec = List.length listdepkind in + let depPvec = + Array.make mib.mind_ntypes (None : (bool * constr) option) in + let _ = + let rec + assign k = function + | [] -> () + | ((indi,u),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 + (* recarg information for non recursive parameters *) + let rec recargparn l n = + if Int.equal n 0 then l else recargparn (mk_norec::l) (n-1) in + let recargpar = recargparn [] (nparams-nparrec) in + let make_one_rec p = + let makefix nbconstruct = + let rec mrec i ln lrelevance ltyp ldef = function + | ((indi,u),mibi,mipi,dep,target_sort)::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 = Context.Rel.to_extended_list mkRel (nrec+nbconstruct) lnamesparrec in + let indf = make_ind_family((indi,u),args) in + + let arsign,s = get_arity env indf in + let r = Sorts.relevance_of_sort_family s in + let depind = build_dependent_inductive env indf in + let deparsign = LocalAssum (make_annot Anonymous r,depind)::arsign in + + let nonrecpar = Context.Rel.length lnonparrec in + let larsign = Context.Rel.length deparsign in + let ndepar = larsign - nonrecpar in + let dect = larsign+nrec+nbconstruct in + + (* 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' = Context.Rel.to_extended_list mkRel (dect+nrec) lnamesparrec in + let args'' = Context.Rel.to_extended_list mkRel ndepar lnonparrec in + let indf' = make_ind_family((indi,u),args'@args'') in + + let branches = + let constrs = get_constructors env indf' in + let fi = Termops.rel_vect (dect-i-nctyi) nctyi in + let vecfi = Array.map + (fun f -> appvect (f, Context.Rel.to_extended_vect mkRel ndepar lnonparrec)) + fi + in + Array.map3 + (make_rec_branch_arg env !evdref + (nparrec,depPvec,larsign)) + vecfi constrs (dest_subterms recargsvec.(tyi)) + in + + let j = (match depPvec.(tyi) with + | Some (_,c) when isRel c -> destRel c + | _ -> assert false) + in + + (* Predicate in the context of the case *) + + let depind' = build_dependent_inductive env indf' in + let arsign',s = get_arity env indf' in + let r = Sorts.relevance_of_sort_family s in + let deparsign' = LocalAssum (make_annot Anonymous r,depind')::arsign' in + + let pargs = + let nrpar = Context.Rel.to_extended_list mkRel (2*ndepar) lnonparrec + and nrar = if dep then Context.Rel.to_extended_list mkRel 0 deparsign' + else Context.Rel.to_extended_list mkRel 1 arsign' + in nrpar@nrar + + in + + (* body of i-th component of the mutual fixpoint *) + let target_relevance = Sorts.relevance_of_sort_family target_sort in + let deftyi = + let rci = target_relevance in + let ci = make_case_info env indi rci RegularStyle in + let concl = applist (mkRel (dect+j+ndepar),pargs) in + let pred = + it_mkLambda_or_LetIn_name env + ((if dep then mkLambda_name env else mkLambda) + (make_annot Anonymous r,depind',concl)) + arsign' + in + let obj = + Inductiveops.make_case_or_project env !evdref indf ci (EConstr.of_constr pred) + (EConstr.mkRel 1) (Array.map EConstr.of_constr branches) + in + let obj = EConstr.to_constr !evdref obj in + it_mkLambda_or_LetIn_name env obj + (Termops.lift_rel_context nrec deparsign) + in + + (* type of i-th component of the mutual fixpoint *) + + let typtyi = + let concl = + let pargs = if dep then Context.Rel.to_extended_vect mkRel 0 deparsign + else Context.Rel.to_extended_vect mkRel 1 arsign + in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) + in it_mkProd_or_LetIn_name env + concl + deparsign + in + mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (target_relevance::lrelevance) (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 lrelevance = CArray.rev_of_list lrelevance in + let names = Array.map (fun r -> make_annot (Name(Id.of_string "F")) r) lrelevance in + mkFix ((fixn,p),(names,fixtyi,fixdef)) + in + mrec 0 [] [] [] [] + in + let rec make_branch env i = function + | ((indi,u),mibi,mipi,dep,sfam)::rest -> + let tyi = snd indi in + let nconstr = Array.length mipi.mind_consnames in + let rec onerec env j = + if Int.equal j nconstr then + make_branch env (i+j) rest + else + let recarg = (dest_subterms recargsvec.(tyi)).(j) in + let recarg = recargpar@recarg in + let vargs = Context.Rel.to_extended_list mkRel (nrec+i+j) lnamesparrec in + let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in + let p_0 = + type_rec_branch + true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg + in + let r_0 = Sorts.relevance_of_sort_family sfam in + mkLambda_string "f" r_0 p_0 + (onerec (push_rel (LocalAssum (make_annot Anonymous r_0,p_0)) env) (j+1)) + in onerec env 0 + | [] -> + makefix i listdepkind + in + let rec put_arity env i = function + | ((indi,u),_,_,dep,kinds)::rest -> + let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list mkRel i lnamesparrec) in + let s = + let sigma, res = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg !evdref kinds in + evdref := sigma; res + in + let typP = make_arity env !evdref dep indf s in + let typP = EConstr.Unsafe.to_constr typP in + mkLambda_string "P" Sorts.Relevant typP + (put_arity (push_rel (LocalAssum (anonR,typP)) env) (i+1) rest) + | [] -> + make_branch env 0 listdepkind + in + + (* Body on make_one_rec *) + let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in + + if force_mutual || (mis_is_recursive_subset + (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) + mipi.mind_recargs) + then + let env' = push_rel_context lnamesparrec env in + it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) + lnamesparrec + else + let evd = !evdref in + let (evd, c) = mis_make_case_com dep env evd (indi,u) (mibi,mipi) kind in + evdref := evd; c + in + (* Body of mis_make_indrec *) + !evdref, List.init nrec make_one_rec + +(**********************************************************************) +(* This builds elimination predicate for Case tactic *) + +let build_case_analysis_scheme env sigma pity dep kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + if dep && not (Inductiveops.has_dependent_elim mib) then + raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (false, fst pity))); + mis_make_case_com dep env sigma pity (mib,mip) kind + +let is_in_prop mip = + match inductive_sort_family mip with + | InProp -> true + | _ -> false + +let build_case_analysis_scheme_default env sigma pity kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + let dep = not (is_in_prop mip || not (Inductiveops.has_dependent_elim mib)) in + mis_make_case_com dep env sigma pity (mib,mip) kind + +(**********************************************************************) +(* [modify_sort_scheme s rec] replaces the sort of the scheme + [rec] by [s] *) + +let change_sort_arity sort = + let rec drec a = match kind a with + | Cast (c,_,_) -> drec c + | Prod (n,t,c) -> let s, c' = drec c in s, mkProd (n, t, c') + | LetIn (n,b,t,c) -> let s, c' = drec c in s, mkLetIn (n,b,t,c') + | Sort s -> s, mkSort sort + | _ -> assert false + in + drec + +(* Change the sort in the type of an inductive definition, builds the + corresponding eta-expanded term *) +let weaken_sort_scheme env evd set sort npars term ty = + let evdref = ref evd in + let rec drec np elim = + match kind elim with + | Prod (n,t,c) -> + if Int.equal np 0 then + let osort, t' = change_sort_arity sort t in + evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) env !evdref sort osort; + 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 ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type.") + in + let ty, term = drec npars ty in + !evdref, ty, term + +(**********************************************************************) +(* Interface to build complex Scheme *) +(* Check inductive types only occurs once +(otherwise we obtain a meaning less scheme) *) + +let check_arities env listdepkind = + let _ = List.fold_left + (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> + let kelim = elim_sorts (mibi,mipi) in + if not (Sorts.List.mem kind kelim) then raise + (RecursionSchemeError + (env, NotAllowedCaseAnalysis (true, fst (UnivGen.fresh_sort_in_family kind),(mind,u)))) + else if Int.List.mem ni ln then raise + (RecursionSchemeError (env, NotMutualInScheme (mind,mind))) + else ni::ln) + [] listdepkind + in true + +let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function + | ((mind,u),dep,s)::lrecspec -> + let (mib,mip) = lookup_mind_specif env mind in + if dep && not (Inductiveops.has_dependent_elim mib) then + raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (true, mind))); + let (sp,tyi) = mind in + let listdepkind = + ((mind,u),mib,mip,dep,s):: + (List.map + (function ((mind',u'),dep',s') -> + let (sp',_) = mind' in + if MutInd.equal sp sp' then + let (mibi',mipi') = lookup_mind_specif env mind' in + ((mind',u'),mibi',mipi',dep',s') + else + raise (RecursionSchemeError (env, NotMutualInScheme (mind,mind')))) + lrecspec) + in + let _ = check_arities env listdepkind in + mis_make_indrec env sigma ~force_mutual listdepkind mib u + | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types.") + +let build_induction_scheme env sigma pind dep kind = + let (mib,mip) = lookup_mind_specif env (fst pind) in + if dep && not (Inductiveops.has_dependent_elim mib) then + raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (true, fst pind))); + let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in + sigma, List.hd l + +(*s Eliminations. *) + +let elimination_suffix = function + | InSProp -> "_sind" + | InProp -> "_ind" + | InSet -> "_rec" + | InType -> "_rect" + +let case_suffix = "_case" + +let make_elimination_ident id s = add_suffix id (elimination_suffix s) + +(* Look up function for the default elimination constant *) + +let lookup_eliminator env ind_sp s = + let kn,i = ind_sp in + let mpu = KerName.modpath @@ MutInd.user kn in + let mpc = KerName.modpath @@ MutInd.canonical kn in + let ind_id = (lookup_mind kn env).mind_packets.(i).mind_typename in + let id = add_suffix ind_id (elimination_suffix s) in + let l = Label.of_id id in + let knu = KerName.make mpu l in + let knc = KerName.make mpc l in + (* Try first to get an eliminator defined in the same section as the *) + (* inductive type *) + try + let cst = Constant.make knu knc in + let _ = lookup_constant cst env in + ConstRef cst + with Not_found -> + (* Then try to get a user-defined eliminator in some other places *) + (* using short name (e.g. for "eq_rec") *) + try Nametab.locate (qualid_of_ident id) + with Not_found -> + user_err ~hdr:"default_elim" + (strbrk "Cannot find the elimination combinator " ++ + Id.print id ++ strbrk ", the elimination of the inductive definition " ++ + Nametab.pr_global_env Id.Set.empty (IndRef ind_sp) ++ + strbrk " on sort " ++ Sorts.pr_sort_family s ++ + strbrk " is probably not allowed.") diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli new file mode 100644 index 0000000000..8eb571a8be --- /dev/null +++ b/pretyping/indrec.mli @@ -0,0 +1,69 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Environ +open Evd + +(** Errors related to recursors building *) + +type recursion_scheme_error = + | NotAllowedCaseAnalysis of (*isrec:*) bool * Sorts.t * pinductive + | NotMutualInScheme of inductive * inductive + | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive + +exception RecursionSchemeError of env * recursion_scheme_error + +(** Eliminations *) + +type dep_flag = bool + +(** Build a case analysis elimination scheme in some sort family *) + +val build_case_analysis_scheme : env -> Evd.evar_map -> pinductive -> + dep_flag -> Sorts.family -> evar_map * Constr.t + +(** Build a dependent case elimination predicate unless type is in Prop + or is a recursive record with primitive projections. *) + +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + Sorts.family -> evar_map * Constr.t + +(** Builds a recursive induction scheme (Peano-induction style) in the same + sort family as the inductive family; it is dependent if not in Prop + or a recursive record with primitive projections. *) + +val build_induction_scheme : env -> evar_map -> pinductive -> + dep_flag -> Sorts.family -> evar_map * constr + +(** Builds mutual (recursive) induction schemes *) + +val build_mutual_induction_scheme : + env -> evar_map -> ?force_mutual:bool -> + (pinductive * dep_flag * Sorts.family) list -> evar_map * constr list + +(** Scheme combinators *) + +(** [weaken_sort_scheme env sigma eq s n c t] derives by subtyping from [c:t] + whose conclusion is quantified on [Type i] at position [n] of [t] a + scheme quantified on sort [s]. [set] asks for [s] be declared equal to [i], + otherwise just less or equal to [i]. *) + +val weaken_sort_scheme : env -> evar_map -> bool -> Sorts.t -> int -> constr -> types -> + evar_map * types * constr + +(** Recursor names utilities *) + +val lookup_eliminator : env -> inductive -> Sorts.family -> GlobRef.t +val elimination_suffix : Sorts.family -> string +val make_elimination_ident : Id.t -> Sorts.family -> Id.t + +val case_suffix : string diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml new file mode 100644 index 0000000000..b1c98da2c7 --- /dev/null +++ b/pretyping/inductiveops.ml @@ -0,0 +1,726 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Util +open Names +open Univ +open Term +open Constr +open Vars +open Context +open Termops +open Declarations +open Declareops +open Environ +open Reductionops +open Context.Rel.Declaration + +(* The following three functions are similar to the ones defined in + Inductive, but they expect an env *) + +let type_of_inductive env (ind,u) = + let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in + Typeops.check_hyps_inclusion env mkInd ind mib.mind_hyps; + Inductive.type_of_inductive env (specif,u) + +(* Return type as quoted by the user *) +let type_of_constructor env (cstr,u) = + let (mib,_ as specif) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + Typeops.check_hyps_inclusion env mkConstruct cstr mib.mind_hyps; + Inductive.type_of_constructor (cstr,u) specif + +(* Return constructor types in user form *) +let type_of_constructors env (ind,u as indu) = + let specif = Inductive.lookup_mind_specif env ind in + Inductive.type_of_constructors indu specif + +(* Return constructor types in normal form *) +let arities_of_constructors env (ind,u as indu) = + let specif = Inductive.lookup_mind_specif env ind in + Inductive.arities_of_constructors indu specif + +(* [inductive_family] = [inductive_instance] applied to global parameters *) +type inductive_family = pinductive * constr list + +let make_ind_family (mis, params) = (mis,params) +let dest_ind_family (mis,params) : inductive_family = (mis,params) + +let map_ind_family f (mis,params) = (mis, List.map f params) + +let liftn_inductive_family n d = map_ind_family (liftn n d) +let lift_inductive_family n = liftn_inductive_family n 1 + +let substnl_ind_family l n = map_ind_family (substnl l n) + +let relevance_of_inductive_family env ((ind,_),_ : inductive_family) = + Inductive.relevance_of_inductive env ind + +type inductive_type = IndType of inductive_family * EConstr.constr list + +let make_ind_type (indf, realargs) = IndType (indf,realargs) +let dest_ind_type (IndType (indf,realargs)) = (indf,realargs) + +let map_inductive_type f (IndType (indf, realargs)) = + let f' c = EConstr.Unsafe.to_constr (f (EConstr.of_constr c)) in + IndType (map_ind_family f' indf, List.map f realargs) + +let liftn_inductive_type n d = map_inductive_type (EConstr.Vars.liftn n d) +let lift_inductive_type n = liftn_inductive_type n 1 + +let substnl_ind_type l n = map_inductive_type (EConstr.Vars.substnl l n) + +let relevance_of_inductive_type env (IndType (indf, _)) = + relevance_of_inductive_family env indf + +let mkAppliedInd (IndType ((ind,params), realargs)) = + let open EConstr in + let ind = on_snd EInstance.make ind in + applist (mkIndU ind, (List.map EConstr.of_constr params)@realargs) + +(* Does not consider imbricated or mutually recursive types *) +let mis_is_recursive_subset listind rarg = + let one_is_rec rvec = + List.exists + (fun ra -> + match dest_recarg ra with + | Mrec (_,i) -> Int.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 (List.interval 0 (mib.mind_ntypes - 1)) + mip.mind_recargs + +let mis_nf_constructor_type ((ind,u),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 = mkIndU (((fst ind),ntypes-k-1),u) in + if j > nconstr then user_err Pp.(str "Not enough constructors in the type."); + let (ctx, cty) = specif.(j - 1) in + substl (List.init ntypes make_Ik) (subst_instance_constr u (Term.it_mkProd_or_LetIn cty ctx)) + +(* Number of constructors *) + +let nconstructors env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + Array.length mip.mind_consnames + +let nconstructors_env env ind = nconstructors env ind +[@@ocaml.deprecated "Alias for Inductiveops.nconstructors"] + +(* Arity of constructors excluding parameters, excluding local defs *) + +let constructors_nrealargs env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_consnrealargs + +let constructors_nrealargs_env env ind = constructors_nrealargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealargs"] + +(* Arity of constructors excluding parameters, including local defs *) + +let constructors_nrealdecls env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_consnrealdecls + +let constructors_nrealdecls_env env ind = constructors_nrealdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealdecls"] + +(* Arity of constructors including parameters, excluding local defs *) + +let constructor_nallargs env (ind,j) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_consnrealargs.(j-1) + mib.mind_nparams + +let constructor_nallargs_env env (indsp,j) = constructor_nallargs env (indsp,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nallargs"] + +(* Arity of constructors including params, including local defs *) + +let constructor_nalldecls env (ind,j) = (* TOCHANGE en decls *) + let (mib,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) + +let constructor_nalldecls_env env (indsp,j) = constructor_nalldecls env (indsp,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nalldecls"] + +(* Arity of constructors excluding params, excluding local defs *) + +let constructor_nrealargs env (ind,j) = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_consnrealargs.(j-1) + +let constructor_nrealargs_env env (ind,j) = constructor_nrealargs env (ind,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealargs"] + +(* Arity of constructors excluding params, including local defs *) + +let constructor_nrealdecls env (ind,j) = (* TOCHANGE en decls *) + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_consnrealdecls.(j-1) + +let constructor_nrealdecls_env env (ind,j) = constructor_nrealdecls env (ind,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] + +(* Length of arity, excluding params, excluding local defs *) + +let inductive_nrealargs env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_nrealargs + +let inductive_nrealargs_env env ind = inductive_nrealargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealargs"] + +(* Length of arity, excluding params, including local defs *) + +let inductive_nrealdecls env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_nrealdecls + +let inductive_nrealdecls_env env ind = inductive_nrealdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealdecls"] + +(* Full length of arity (w/o local defs) *) + +let inductive_nallargs env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + mib.mind_nparams + mip.mind_nrealargs + +let inductive_nallargs_env env ind = inductive_nallargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nallargs"] + +(* Length of arity (w/o local defs) *) + +let inductive_nparams env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + mib.mind_nparams + +let inductive_nparams_env env ind = inductive_nparams env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparams"] + +(* Length of arity (with local defs) *) + +let inductive_nparamdecls env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Context.Rel.length mib.mind_params_ctxt + +let inductive_nparamdecls_env env ind = inductive_nparamdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparamsdecls"] + +(* Full length of arity (with local defs) *) + +let inductive_nalldecls env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls + +let inductive_nalldecls_env env ind = inductive_nalldecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nalldecls"] + +(* Others *) + +let inductive_paramdecls env (ind,u) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Inductive.inductive_paramdecls (mib,u) + +let inductive_paramdecls_env env (ind,u) = inductive_paramdecls env (ind,u) +[@@ocaml.deprecated "Alias for Inductiveops.inductive_paramsdecls"] + +let inductive_alldecls env (ind,u) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Vars.subst_instance_context u mip.mind_arity_ctxt + +let inductive_alldecls_env env (ind,u) = inductive_alldecls env (ind,u) +[@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] + +let constructor_has_local_defs env (indsp,j) = + let (mib,mip) = Inductive.lookup_mind_specif env indsp in + let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in + let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in + not (Int.equal l1 l2) + +let inductive_has_local_defs env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in + let l2 = mib.mind_nparams + mip.mind_nrealargs in + not (Int.equal l1 l2) + +let allowed_sorts env (kn,i as ind) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_kelim + +let has_dependent_elim mib = + match mib.mind_record with + | PrimRecord _ -> mib.mind_finite == BiFinite + | NotRecord | FakeRecord -> true + +(* Annotation for cases *) +let make_case_info env ind r style = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let ind_tags = + Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in + let cstr_tags = + Array.map2 (fun (d, _) n -> + Context.Rel.to_tags (List.firstn n d)) + mip.mind_nf_lc mip.mind_consnrealdecls in + let print_info = { ind_tags; cstr_tags; style } in + { ci_ind = ind; + ci_npar = mib.mind_nparams; + ci_cstr_ndecls = mip.mind_consnrealdecls; + ci_cstr_nargs = mip.mind_consnrealargs; + ci_relevance = r; + ci_pp_info = print_info } + +(*s Useful functions *) + +type constructor_summary = { + cs_cstr : pconstructor; + cs_params : constr list; + cs_nargs : int; + cs_args : Constr.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 +} + +(* Accept either all parameters or only recursively uniform ones *) +let instantiate_params t params sign = + let nnonrecpar = Context.Rel.nhyps sign - List.length params in + (* Adjust the signature if recursively non-uniform parameters are not here *) + let _,sign = context_chop nnonrecpar sign in + let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in + let subst = subst_of_rel_context_instance sign params in + substl subst t + +let get_constructor ((ind,u as indu),mib,mip,params) j = + assert (j <= Array.length mip.mind_consnames); + let typi = mis_nf_constructor_type (indu,mib,mip) j in + let ctx = Vars.subst_instance_context u mib.mind_params_ctxt in + let typi = instantiate_params typi params ctx in + let (args,ccl) = decompose_prod_assum typi in + let (_,allargs) = decompose_app ccl in + let vargs = List.skipn (List.length params) allargs in + { cs_cstr = (ith_constructor_of_inductive ind j,u); + cs_params = params; + cs_nargs = Context.Rel.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 (fst ind) in + Array.init (Array.length mip.mind_consnames) + (fun j -> get_constructor (ind,mib,mip,params) (j+1)) + +let get_projections = Environ.get_projections + +let make_case_or_project env sigma indf ci pred c branches = + let open EConstr in + let projs = get_projections env (fst (fst indf)) in + match projs with + | None -> (mkCase (ci, pred, c, branches)) + | Some ps -> + assert(Array.length branches == 1); + let na, ty, t = destLambda sigma pred in + let () = + let (ind, _), _ = dest_ind_family indf in + let mib, _ = Inductive.lookup_mind_specif env ind in + if (* dependent *) not (Vars.noccurn sigma 1 t) && + not (has_dependent_elim mib) then + user_err ~hdr:"make_case_or_project" + Pp.(str"Dependent case analysis not allowed" ++ + str" on inductive type " ++ Termops.Internal.print_constr_env env sigma (mkInd ind)) + in + let branch = branches.(0) in + let ctx, br = decompose_lam_n_assum sigma (Array.length ps) branch in + let n, len, ctx = + List.fold_right + (fun decl (i, j, ctx) -> + match decl with + | LocalAssum (na, ty) -> + let t = mkProj (Projection.make ps.(i) true, mkRel j) in + (i + 1, j + 1, LocalDef (na, t, Vars.liftn 1 j ty) :: ctx) + | LocalDef (na, b, ty) -> + (i, j + 1, LocalDef (na, Vars.liftn 1 j b, Vars.liftn 1 j ty) :: ctx)) + ctx (0, 1, []) + in + mkLetIn (na, c, ty, it_mkLambda_or_LetIn (Vars.liftn 1 (Array.length ps + 1) br) ctx) + +(* substitution in a signature *) + +let substnl_rel_context subst n sign = + let rec aux n = function + | d::sign -> substnl_decl subst n d :: aux (n+1) sign + | [] -> [] + in List.rev (aux n (List.rev sign)) + +let substl_rel_context subst = substnl_rel_context subst 0 + +let get_arity env ((ind,u),params) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let parsign = + (* Dynamically detect if called with an instance of recursively + uniform parameter only or also of recursively non-uniform + parameters *) + let nparams = List.length params in + if Int.equal nparams mib.mind_nparams then + mib.mind_params_ctxt + else begin + assert (Int.equal nparams mib.mind_nparams_rec); + let nnonrecparamdecls = mib.mind_nparams - mib.mind_nparams_rec in + snd (Termops.context_chop nnonrecparamdecls mib.mind_params_ctxt) + end in + let parsign = Vars.subst_instance_context u parsign in + let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in + let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in + let subst = subst_of_rel_context_instance parsign params in + let arsign = Vars.subst_instance_context u arsign in + (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) + +(* Functions to build standard types related to inductive *) +let build_dependent_constructor cs = + applist + (mkConstructU cs.cs_cstr, + (List.map (lift cs.cs_nargs) cs.cs_params) + @(Context.Rel.to_extended_list mkRel 0 cs.cs_args)) + +let build_dependent_inductive env ((ind, params) as indf) = + let arsign,_ = get_arity env indf in + let nrealargs = List.length arsign in + applist + (mkIndU ind, + (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list mkRel 0 arsign)) + +(* builds the arity of an elimination predicate in sort [s] *) + +let make_arity_signature env sigma dep indf = + let (arsign,s) = get_arity env indf in + let r = Sorts.relevance_of_sort_family s in + let anon = make_annot Anonymous r in + let arsign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) arsign in + if dep then + (* We need names everywhere *) + Namegen.name_context env sigma + ((LocalAssum (anon,EConstr.of_constr (build_dependent_inductive env indf)))::arsign) + (* Costly: would be better to name once for all at definition time *) + else + (* No need to enforce names *) + arsign + +let make_arity env sigma dep indf s = + let open EConstr in + it_mkProd_or_LetIn (mkSort s) (make_arity_signature env sigma dep indf) + +(* [p] is the predicate and [cs] a constructor summary *) +let build_branch_type env sigma dep p cs = + let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in + if dep then + EConstr.Unsafe.to_constr (Namegen.it_mkProd_or_LetIn_name env sigma + (EConstr.of_constr (applist (base,[build_dependent_constructor cs]))) + (List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) cs.cs_args)) + else + Term.it_mkProd_or_LetIn base cs.cs_args + +(**************************************************) + +(** From a rel context describing the constructor arguments, + build an expansion function. + The term built is expecting to be substituted first by + a substitution of the form [params, x : ind params] *) +let compute_projections env (kn, i as ind) = + let open Term in + let mib = Environ.lookup_mind kn env in + let u = make_abstract_instance (Declareops.inductive_polymorphic_context mib) in + let x = match mib.mind_record with + | NotRecord | FakeRecord -> + anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") + | PrimRecord info -> + let id, _, _, _ = info.(i) in + make_annot (Name id) mib.mind_packets.(i).mind_relevance + in + let pkt = mib.mind_packets.(i) in + let { mind_nparams = nparamargs; mind_params_ctxt = params } = mib in + let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in + let ctx, cty = pkt.mind_nf_lc.(0) in + let rctx, _ = decompose_prod_assum (substl subst (Term.it_mkProd_or_LetIn cty ctx)) in + let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in + (* We build a substitution smashing the lets in the record parameters so + that typechecking projections requires just a substitution and not + matching with a parameter context. *) + let indty = + (* [ty] = [Ind inst] is typed in context [params] *) + let inst = Context.Rel.to_extended_vect mkRel 0 paramslet in + let indu = mkIndU (ind, u) in + let ty = mkApp (indu, inst) in + (* [Ind inst] is typed in context [params-wo-let] *) + ty + in + let projections decl (proj_arg, j, pbs, subst) = + match decl with + | LocalDef (na,c,t) -> + (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) + let c = liftn 1 j c in + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I |- c(params,proj1 x,..,projj x)] *) + let c1 = substl subst c in + (* From [params, x:I |- subst:field1,..,fieldj] + to [params, x:I |- subst:field1,..,fieldj+1] where [subst] + is represented with instance of field1 last *) + let subst = c1 :: subst in + (proj_arg, j+1, pbs, subst) + | LocalAssum (na,t) -> + match na.binder_name with + | Name id -> + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab in + (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) + let t = liftn 1 j t in + (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *) + (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] + to [params, x:I |- t(proj1 x,..,projj x)] *) + let ty = substl subst t in + let term = mkProj (Projection.make kn true, mkRel 1) in + let fterm = mkProj (Projection.make kn false, mkRel 1) in + let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in + let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in + let body = (etab, etat) in + (proj_arg + 1, j + 1, body :: pbs, fterm :: subst) + | Anonymous -> + anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") + in + let (_, _, pbs, subst) = + List.fold_right projections ctx (0, 1, [], []) + in + Array.rev_of_list pbs + +(**************************************************) + +let extract_mrectype sigma t = + let open EConstr in + let (t, l) = decompose_app sigma t in + match EConstr.kind sigma t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +let find_mrectype_vect env sigma c = + let (t, l) = Termops.decompose_app_vect sigma (whd_all env sigma c) in + match EConstr.kind sigma t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +let find_mrectype env sigma c = + let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v) + +let find_rectype env sigma c = + let open EConstr in + let (t, l) = decompose_app sigma (whd_all env sigma c) in + match EConstr.kind sigma t with + | Ind (ind,u) -> + let (mib,mip) = Inductive.lookup_mind_specif env ind in + if mib.mind_nparams > List.length l then raise Not_found; + let l = List.map EConstr.Unsafe.to_constr l in + let (par,rargs) = List.chop mib.mind_nparams l in + let indu = (ind, EInstance.kind sigma u) in + IndType((indu, par),List.map EConstr.of_constr rargs) + | _ -> raise Not_found + +let find_inductive env sigma c = + let open EConstr in + let (t, l) = decompose_app sigma (whd_all env sigma c) in + match EConstr.kind sigma t with + | Ind ind + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> CoFinite -> + let l = List.map EConstr.Unsafe.to_constr l in + (ind, l) + | _ -> raise Not_found + +let find_coinductive env sigma c = + let open EConstr in + let (t, l) = decompose_app sigma (whd_all env sigma c) in + match EConstr.kind sigma t with + | Ind ind + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == CoFinite -> + let l = List.map EConstr.Unsafe.to_constr l in + (ind, l) + | _ -> raise Not_found + + +(***********************************************) +(* find appropriate names for pattern variables. Useful in the Case + and Inversion (case_then_using et case_nodep_then_using) tactics. *) + +let is_predicate_explicitly_dep env sigma pred arsign = + let rec srec env pval arsign = + let pv' = whd_all env sigma pval in + match EConstr.kind sigma pv', arsign with + | Lambda (na,t,b), (LocalAssum _)::arsign -> + srec (push_rel_assum (na, t) env) b arsign + | Lambda (na,_,t), _ -> + + (* The following code has an impact on the introduction names + given by the tactics "case" and "inversion": when the + elimination is not dependent, "case" uses Anonymous for + inductive types in Prop and names created by mkProd_name for + inductive types in Set/Type while "inversion" uses anonymous + for inductive types both in Prop and Set/Type !! + + Previously, whether names were created or not relied on + whether the predicate created in Indrec.make_case_com had a + dependent arity or not. To avoid different predicates + printed the same in v8, all predicates built in indrec.ml + got a dependent arity (Aug 2004). The new way to decide + whether names have to be created or not is to use an + Anonymous or Named variable to enforce the expected + dependency status (of course, Anonymous implies non + dependent, but not conversely). + + From Coq > 8.2, using or not the effective dependency of + the predicate is parametrable! *) + + begin match na.binder_name with + | Anonymous -> false + | Name _ -> true + end + + | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate.") + in + srec env (EConstr.of_constr pred) arsign + +let is_elim_predicate_explicitly_dependent env sigma pred indf = + let arsign,_ = get_arity env indf in + is_predicate_explicitly_dep env sigma pred arsign + +let set_names env sigma n brty = + let open EConstr in + let (ctxt,cl) = decompose_prod_n_assum sigma n brty in + EConstr.Unsafe.to_constr (Namegen.it_mkProd_or_LetIn_name env sigma cl ctxt) + +let set_pattern_names env sigma ind brv = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let arities = + Array.map + (fun (d, _) -> List.length d - mib.mind_nparams) + mip.mind_nf_lc in + Array.map2 (set_names env sigma) arities brv + +let type_case_branches_with_names env sigma indspec p c = + let (ind,args) = indspec in + let args = List.map EConstr.Unsafe.to_constr args in + let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in + let nparams = mib.mind_nparams in + let (params,realargs) = List.chop nparams args in + let lbrty = Inductive.build_branches_type ind specif params p in + (* Build case type *) + let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in + (* Adjust names *) + if is_elim_predicate_explicitly_dependent env sigma p (ind,params) then + (set_pattern_names env sigma (fst ind) (Array.map EConstr.of_constr lbrty), conclty) + else (lbrty, conclty) + +(* Type of Case predicates *) +let arity_of_case_predicate env (ind,params) dep k = + let arsign,s = get_arity env (ind,params) in + let r = Sorts.relevance_of_sort_family s in + let mind = build_dependent_inductive env (ind,params) in + let concl = if dep then mkArrow mind r (mkSort k) else mkSort k in + Term.it_mkProd_or_LetIn concl arsign + +(***********************************************) +(* Inferring the sort of parameters of a polymorphic inductive type + knowing the sort of the conclusion *) + + +(* Compute the inductive argument types: replace the sorts + that appear in the type of the inductive by the sort of the + conclusion, and the other ones by fresh universes. *) +let rec instantiate_universes env evdref scl is = function + | (LocalDef _ as d)::sign, exp -> + d :: instantiate_universes env evdref scl is (sign, exp) + | d::sign, None::exp -> + d :: instantiate_universes env evdref scl is (sign, exp) + | (LocalAssum (na,ty))::sign, Some l::exp -> + let ctx,_ = Reduction.dest_arity env ty in + let u = Univ.Universe.make l in + let s = + (* Does the sort of parameter [u] appear in (or equal) + the sort of inductive [is] ? *) + if univ_level_mem l is then + scl (* constrained sort: replace by scl *) + else + (* unconstrained sort: replace by fresh universe *) + let evm, s = Evd.new_sort_variable Evd.univ_flexible !evdref in + let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in + evdref := evm; s + in + (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp) + | sign, [] -> sign (* Uniform parameters are exhausted *) + | [], _ -> assert false + +let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = + match mip.mind_arity with + | RegularArity s -> sigma, EConstr.of_constr (subst_instance_constr u s.mind_user_arity) + | TemplateArity ar -> + let _,scl = splay_arity env sigma conclty in + let scl = EConstr.ESorts.kind sigma scl in + let ctx = List.rev mip.mind_arity_ctxt in + let evdref = ref sigma in + let ctx = + instantiate_universes + env evdref scl ar.template_level (ctx,ar.template_param_levels) in + !evdref, EConstr.of_constr (mkArity (List.rev ctx,scl)) + +let type_of_projection_constant env (p,u) = + let pty = lookup_projection p env in + Vars.subst_instance_constr u pty + +let type_of_projection_knowing_arg env sigma p c ty = + let c = EConstr.Unsafe.to_constr c in + let IndType(pars,realargs) = + try find_rectype env sigma ty + with Not_found -> + raise (Invalid_argument "type_of_projection_knowing_arg_type: not an inductive type") + in + let (_,u), pars = dest_ind_family pars in + substl (c :: List.rev pars) (type_of_projection_constant env (p,u)) + +(***********************************************) +(* Guard condition *) + +(* A function which checks that a term well typed verifies both + syntactic conditions *) + +let control_only_guard env sigma c = + let c = Evarutil.nf_evar sigma c in + let check_fix_cofix e c = + (* [c] has already been normalized upfront *) + let c = EConstr.Unsafe.to_constr c in + match kind c with + | CoFix (_,(_,_,_) as cofix) -> + Inductive.check_cofix e cofix + | Fix fix -> + Inductive.check_fix e fix + | _ -> () + in + let rec iter env c = + check_fix_cofix env c; + EConstr.iter_with_full_binders sigma EConstr.push_rel iter env c + in + iter env c diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli new file mode 100644 index 0000000000..cfc650938e --- /dev/null +++ b/pretyping/inductiveops.mli @@ -0,0 +1,222 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Declarations +open Environ +open Evd + +(** The following three functions are similar to the ones defined in + Inductive, but they expect an env *) + +val type_of_inductive : env -> pinductive -> types + +(** Return type as quoted by the user *) +val type_of_constructor : env -> pconstructor -> types +val type_of_constructors : env -> pinductive -> types array + +(** Return constructor types in normal form *) +val arities_of_constructors : env -> pinductive -> types array + +(** An inductive type with its parameters (transparently supports + reasoning either with only recursively uniform parameters or with all + parameters including the recursively non-uniform ones *) +type inductive_family +val make_ind_family : inductive Univ.puniverses * constr list -> inductive_family +val dest_ind_family : inductive_family -> inductive Univ.puniverses * 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 + +val relevance_of_inductive_family : env -> inductive_family -> Sorts.relevance + +(** An inductive type with its parameters and real arguments *) +type inductive_type = IndType of inductive_family * EConstr.constr list +val make_ind_type : inductive_family * EConstr.constr list -> inductive_type +val dest_ind_type : inductive_type -> inductive_family * EConstr.constr list +val map_inductive_type : (EConstr.constr -> EConstr.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 : EConstr.constr list -> int -> inductive_type -> inductive_type + +val relevance_of_inductive_type : env -> inductive_type -> Sorts.relevance + +val mkAppliedInd : inductive_type -> EConstr.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 : + pinductive * mutual_inductive_body * one_inductive_body -> int -> constr + +(** {6 Extract information from an inductive name} *) + +(** @return number of constructors *) +val nconstructors : env -> inductive -> int +val nconstructors_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.nconstructors"] + +(** @return arity of constructors excluding parameters, excluding local defs *) +val constructors_nrealargs : env -> inductive -> int array +val constructors_nrealargs_env : env -> inductive -> int array +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealargs"] + +(** @return arity of constructors excluding parameters, including local defs *) +val constructors_nrealdecls : env -> inductive -> int array +val constructors_nrealdecls_env : env -> inductive -> int array +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealdecls"] + +(** @return the arity, excluding params, excluding local defs *) +val inductive_nrealargs : env -> inductive -> int +val inductive_nrealargs_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealargs"] + +(** @return the arity, excluding params, including local defs *) +val inductive_nrealdecls : env -> inductive -> int +val inductive_nrealdecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealdecls"] + +(** @return the arity, including params, excluding local defs *) +val inductive_nallargs : env -> inductive -> int +val inductive_nallargs_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nallargs"] + +(** @return the arity, including params, including local defs *) +val inductive_nalldecls : env -> inductive -> int +val inductive_nalldecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nalldecls"] + +(** @return nb of params without local defs *) +val inductive_nparams : env -> inductive -> int +val inductive_nparams_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparams"] + +(** @return nb of params with local defs *) +val inductive_nparamdecls : env -> inductive -> int +val inductive_nparamdecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparamsdecls"] + +(** @return params context *) +val inductive_paramdecls : env -> pinductive -> Constr.rel_context +val inductive_paramdecls_env : env -> pinductive -> Constr.rel_context +[@@ocaml.deprecated "Alias for Inductiveops.inductive_paramsdecl"] + +(** @return full arity context, hence with letin *) +val inductive_alldecls : env -> pinductive -> Constr.rel_context +val inductive_alldecls_env : env -> pinductive -> Constr.rel_context +[@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] + +(** {7 Extract information from a constructor name} *) + +(** @return param + args without letin *) +val constructor_nallargs : env -> constructor -> int +val constructor_nallargs_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nallargs"] + +(** @return param + args with letin *) +val constructor_nalldecls : env -> constructor -> int +val constructor_nalldecls_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nalldecls"] + +(** @return args without letin *) +val constructor_nrealargs : env -> constructor -> int +val constructor_nrealargs_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealargs"] + +(** @return args with letin *) +val constructor_nrealdecls : env -> constructor -> int +val constructor_nrealdecls_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] + +(** Is there local defs in params or args ? *) +val constructor_has_local_defs : env -> constructor -> bool +val inductive_has_local_defs : env -> inductive -> bool + +val allowed_sorts : env -> inductive -> Sorts.family list + +(** (Co)Inductive records with primitive projections do not have eta-conversion, + hence no dependent elimination. *) +val has_dependent_elim : mutual_inductive_body -> bool + +(** Primitive projections *) +val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> + EConstr.t -> EConstr.types -> types + +(** Extract information from an inductive family *) + +type constructor_summary = { + cs_cstr : pconstructor; (* internal name of the constructor plus universes *) + cs_params : constr list; (* parameters of the constructor in current ctx *) + cs_nargs : int; (* length of arguments signature (letin included) *) + cs_args : Constr.rel_context; (* signature of the arguments (letin included) *) + cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *) +} +val lift_constructor : int -> constructor_summary -> constructor_summary +val get_constructor : + pinductive * mutual_inductive_body * one_inductive_body * constr list -> + int -> constructor_summary +val get_constructors : env -> inductive_family -> constructor_summary array + +(** [get_arity] returns the arity of the inductive family instantiated + with the parameters; if recursively non-uniform parameters are not + part of the inductive family, they appears in the arity *) +val get_arity : env -> inductive_family -> Constr.rel_context * Sorts.family + +val build_dependent_constructor : constructor_summary -> constr +val build_dependent_inductive : env -> inductive_family -> constr +val make_arity_signature : env -> evar_map -> bool -> inductive_family -> EConstr.rel_context +val make_arity : env -> evar_map -> bool -> inductive_family -> Sorts.t -> EConstr.types +val build_branch_type : env -> evar_map -> bool -> constr -> constructor_summary -> types + +(** Raise [Not_found] if not given a valid inductive type *) +val extract_mrectype : evar_map -> EConstr.t -> (inductive * EConstr.EInstance.t) * EConstr.constr list +val find_mrectype : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * EConstr.constr list +val find_mrectype_vect : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * EConstr.constr array +val find_rectype : env -> evar_map -> EConstr.types -> inductive_type +val find_inductive : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * constr list +val find_coinductive : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * constr list + +(********************) + +(** Builds the case predicate arity (dependent or not) *) +val arity_of_case_predicate : + env -> inductive_family -> bool -> Sorts.t -> types + +val type_case_branches_with_names : + env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> types array * types + +(** Annotation for cases *) +val make_case_info : env -> inductive -> Sorts.relevance -> case_style -> case_info + +(** Make a case or substitute projections if the inductive type is a record + with primitive projections. + Fail with an error if the elimination is dependent while the + inductive type does not allow dependent elimination. *) +val make_case_or_project : + env -> evar_map -> inductive_family -> case_info -> + (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr + +(*i Compatibility +val make_default_case_info : env -> case_style -> inductive -> case_info +i*) + +val compute_projections : Environ.env -> inductive -> (constr * types) array +(** Given a primitive record type, for every field computes the eta-expanded + projection and its type. *) + +(********************) + +val type_of_inductive_knowing_conclusion : + env -> evar_map -> Inductive.mind_specif Univ.puniverses -> EConstr.types -> evar_map * EConstr.types + +(********************) +val control_only_guard : env -> Evd.evar_map -> EConstr.types -> unit diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml new file mode 100644 index 0000000000..fefc15dfb2 --- /dev/null +++ b/pretyping/inferCumulativity.ml @@ -0,0 +1,221 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Reduction +open Declarations +open Constr +open Univ +open Util + +(** Throughout this module we modify a map [variances] from local + universes to [Variance.t]. It starts as a trivial mapping to + [Irrelevant] and every time we encounter a local universe we + restrict it accordingly. *) + +let infer_level_eq u variances = + if LMap.mem u variances + then LMap.set u Variance.Invariant variances + else variances + +let infer_level_leq u variances = + match LMap.find u variances with + | exception Not_found -> variances + | varu -> LMap.set u (Variance.sup varu Variance.Covariant) variances + +let infer_generic_instance_eq variances u = + Array.fold_left (fun variances u -> infer_level_eq u variances) + variances (Instance.to_array u) + +let variance_pb cv_pb var = + let open Variance in + match cv_pb, var with + | _, Irrelevant -> Irrelevant + | _, Invariant -> Invariant + | CONV, Covariant -> Invariant + | CUMUL, Covariant -> Covariant + +let infer_cumulative_ind_instance cv_pb mind_variance variances u = + Array.fold_left2 (fun variances varu u -> + match LMap.find u variances with + | exception Not_found -> variances + | varu' -> + LMap.set u (Variance.sup varu' (variance_pb cv_pb varu)) variances) + variances mind_variance (Instance.to_array u) + +let infer_inductive_instance cv_pb env variances ind nargs u = + let mind = Environ.lookup_mind (fst ind) env in + match mind.mind_variance with + | None -> infer_generic_instance_eq variances u + | Some mind_variance -> + if not (Int.equal (inductive_cumulativity_arguments (mind,snd ind)) nargs) + then infer_generic_instance_eq variances u + else infer_cumulative_ind_instance cv_pb mind_variance variances u + +let infer_constructor_instance_eq env variances ((mi,ind),ctor) nargs u = + let mind = Environ.lookup_mind mi env in + match mind.mind_variance with + | None -> infer_generic_instance_eq variances u + | Some _ -> + if not (Int.equal (constructor_cumulativity_arguments (mind,ind,ctor)) nargs) + then infer_generic_instance_eq variances u + else variances (* constructors are convertible at common supertype *) + +let infer_sort cv_pb variances s = + match cv_pb with + | CONV -> + LSet.fold infer_level_eq (Universe.levels (Sorts.univ_of_sort s)) variances + | CUMUL -> + LSet.fold infer_level_leq (Universe.levels (Sorts.univ_of_sort s)) variances + +let infer_table_key infos variances c = + let open Names in + match c with + | ConstKey (_, u) -> + infer_generic_instance_eq variances u + | VarKey _ | RelKey _ -> variances + +let whd_stack (infos, tab) hd stk = CClosure.whd_stack infos tab hd stk + +let rec infer_fterm cv_pb infos variances hd stk = + Control.check_for_interrupt (); + let hd,stk = whd_stack infos hd stk in + let open CClosure in + match fterm_of hd with + | FAtom a -> + begin match kind a with + | Sort s -> infer_sort cv_pb variances s + | Meta _ -> infer_stack infos variances stk + | _ -> assert false + end + | FEvar ((_,args),e) -> + let variances = infer_stack infos variances stk in + infer_vect infos variances (Array.map (mk_clos e) args) + | FRel _ -> infer_stack infos variances stk + | FInt _ -> infer_stack infos variances stk + | FFlex fl -> + let variances = infer_table_key infos variances fl in + infer_stack infos variances stk + | FProj (_,c) -> + let variances = infer_fterm CONV infos variances c [] in + infer_stack infos variances stk + | FLambda _ -> + let (_,ty,bd) = destFLambda mk_clos hd in + let variances = infer_fterm CONV infos variances ty [] in + infer_fterm CONV infos variances bd [] + | FProd (_,dom,codom,e) -> + let variances = infer_fterm CONV infos variances dom [] in + infer_fterm cv_pb infos variances (mk_clos (Esubst.subs_lift e) codom) [] + | FInd (ind, u) -> + let variances = + if Instance.is_empty u then variances + else + let nargs = stack_args_size stk in + infer_inductive_instance cv_pb (info_env (fst infos)) variances ind nargs u + in + infer_stack infos variances stk + | FConstruct (ctor,u) -> + let variances = + if Instance.is_empty u then variances + else + let nargs = stack_args_size stk in + infer_constructor_instance_eq (info_env (fst infos)) variances ctor nargs u + in + infer_stack infos variances stk + | FFix ((_,(_,tys,cl)),e) | FCoFix ((_,(_,tys,cl)),e) -> + let n = Array.length cl in + let variances = infer_vect infos variances (Array.map (mk_clos e) tys) in + let le = Esubst.subs_liftn n e in + let variances = infer_vect infos variances (Array.map (mk_clos le) cl) in + infer_stack infos variances stk + + (* Removed by whnf *) + | FLOCKED | FCaseT _ | FLetIn _ | FApp _ | FLIFT _ | FCLOS _ -> assert false + +and infer_stack infos variances (stk:CClosure.stack) = + match stk with + | [] -> variances + | z :: stk -> + let open CClosure in + let variances = match z with + | Zapp v -> infer_vect infos variances v + | Zproj _ -> variances + | Zfix (fx,a) -> + let variances = infer_fterm CONV infos variances fx [] in + infer_stack infos variances a + | ZcaseT (ci,p,br,e) -> + let variances = infer_fterm CONV infos variances (mk_clos e p) [] in + infer_vect infos variances (Array.map (mk_clos e) br) + | Zshift _ -> variances + | Zupdate _ -> variances + | Zprimitive (_,_,rargs,kargs) -> + let variances = List.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances rargs in + let variances = List.fold_left (fun variances (_,c) -> infer_fterm CONV infos variances c []) variances kargs in + variances + in + infer_stack infos variances stk + +and infer_vect infos variances v = + Array.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v + +let infer_term cv_pb env variances c = + let open CClosure in + let infos = (create_clos_infos all env, create_tab ()) in + infer_fterm cv_pb infos variances (CClosure.inject c) [] + +let infer_arity_constructor is_arity env variances arcn = + let infer_typ typ (env,variances) = + match typ with + | Context.Rel.Declaration.LocalAssum (_, typ') -> + (Environ.push_rel typ env, infer_term CUMUL env variances typ') + | Context.Rel.Declaration.LocalDef _ -> assert false + in + let typs, codom = Reduction.dest_prod env arcn in + let env, variances = Context.Rel.fold_outside infer_typ typs ~init:(env, variances) in + (* If we have Inductive foo@{i j} : ... -> Type@{i} := C : ... -> foo Type@{j} + i is irrelevant, j is invariant. *) + if not is_arity then infer_term CUMUL env variances codom else variances + +let infer_inductive env mie = + let open Entries in + let { mind_entry_params = params; + mind_entry_inds = entries; } = mie + in + let variances = + match mie.mind_entry_variance with + | None -> None + | Some _ -> + let uctx = match mie.mind_entry_universes with + | Monomorphic_entry _ -> assert false + | Polymorphic_entry (_,uctx) -> uctx + in + let uarray = Instance.to_array @@ UContext.instance uctx in + let env = Environ.push_context uctx env in + let variances = + Array.fold_left (fun variances u -> LMap.add u Variance.Irrelevant variances) + LMap.empty uarray + in + let env, params = Typeops.check_context env params in + let variances = List.fold_left (fun variances entry -> + let variances = infer_arity_constructor true + env variances entry.mind_entry_arity + in + List.fold_left (infer_arity_constructor false env) + variances entry.mind_entry_lc) + variances + entries + in + let variances = Array.map (fun u -> LMap.find u variances) uarray in + Some variances + in + { mie with mind_entry_variance = variances } + +let dummy_variance = let open Entries in function + | Monomorphic_entry _ -> assert false + | Polymorphic_entry (_,uctx) -> Array.make (UContext.size uctx) Variance.Irrelevant diff --git a/pretyping/inferCumulativity.mli b/pretyping/inferCumulativity.mli new file mode 100644 index 0000000000..6e5bf30f6b --- /dev/null +++ b/pretyping/inferCumulativity.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val infer_inductive : Environ.env -> Entries.mutual_inductive_entry -> + Entries.mutual_inductive_entry + +val dummy_variance : Entries.universes_entry -> Univ.Variance.t array diff --git a/pretyping/locus.ml b/pretyping/locus.ml new file mode 100644 index 0000000000..087a6b9174 --- /dev/null +++ b/pretyping/locus.ml @@ -0,0 +1,100 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** Locus : positions in hypotheses and goals *) + +type 'a or_var = + | ArgArg of 'a + | ArgVar of lident + +(** {6 Occurrences} *) + +type 'a occurrences_gen = + | AllOccurrences + | AtLeastOneOccurrence + | AllOccurrencesBut of 'a list (** non-empty *) + | NoOccurrences + | OnlyOccurrences of 'a list (** non-empty *) + +type occurrences_expr = (int or_var) occurrences_gen +type 'a with_occurrences = occurrences_expr * 'a + +type occurrences = int occurrences_gen + + +(** {6 Locations} + + Selecting the occurrences in body (if any), in type, or in both *) + +type hyp_location_flag = InHyp | InHypTypeOnly | InHypValueOnly + + +(** {6 Abstract clauses expressions} + + A [clause_expr] (and its instance [clause]) denotes occurrences and + hypotheses in a goal in an abstract way; in particular, it can refer + to the set of all hypotheses independently of the effective contents + of the current goal + + Concerning the field [onhyps]: + - [None] means *on every hypothesis* + - [Some l] means on hypothesis belonging to l *) + +type 'a hyp_location_expr = 'a with_occurrences * hyp_location_flag + +type 'id clause_expr = + { onhyps : 'id hyp_location_expr list option; + concl_occs : occurrences_expr } + +type clause = Id.t clause_expr + + +(** {6 Concrete view of occurrence clauses} *) + +(** [clause_atom] refers either to an hypothesis location (i.e. an + hypothesis with occurrences and a position, in body if any, in type + or in both) or to some occurrences of the conclusion *) + +type clause_atom = + | OnHyp of Id.t * occurrences_expr * hyp_location_flag + | OnConcl of occurrences_expr + +(** A [concrete_clause] is an effective collection of occurrences + in the hypotheses and the conclusion *) + +type concrete_clause = clause_atom list + + +(** {6 A weaker form of clause with no mention of occurrences} *) + +(** A [hyp_location] is an hypothesis together with a location *) + +type hyp_location = Id.t * hyp_location_flag + +(** A [goal_location] is either an hypothesis (together with a location) + or the conclusion (represented by None) *) + +type goal_location = hyp_location option + + +(** {6 Simple clauses, without occurrences nor location} *) + +(** A [simple_clause] is a set of hypotheses, possibly extended with + the conclusion (conclusion is represented by None) *) + +type simple_clause = Id.t option list + +(** {6 A notion of occurrences allowing to express "all occurrences + convertible to the first which matches"} *) + +type 'a or_like_first = AtOccs of 'a | LikeFirst + diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml new file mode 100644 index 0000000000..aaa4ce684d --- /dev/null +++ b/pretyping/locusops.ml @@ -0,0 +1,134 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Locus + +(** Utilities on occurrences *) + +let occurrences_map f = function + | OnlyOccurrences l -> + let l' = f l in + if l' = [] then NoOccurrences else OnlyOccurrences l' + | AllOccurrencesBut l -> + let l' = f l in + if l' = [] then AllOccurrences else AllOccurrencesBut l' + | (NoOccurrences|AllOccurrences|AtLeastOneOccurrence) as o -> o + +let convert_occs = function + | AtLeastOneOccurrence -> (false,[]) + | AllOccurrences -> (false,[]) + | AllOccurrencesBut l -> (false,l) + | NoOccurrences -> (true,[]) + | OnlyOccurrences l -> (true,l) + +let is_selected occ = function + | AtLeastOneOccurrence -> true + | AllOccurrences -> true + | AllOccurrencesBut l -> not (Int.List.mem occ l) + | OnlyOccurrences l -> Int.List.mem occ l + | NoOccurrences -> false + +(** Usual clauses *) + +let allHypsAndConcl = { onhyps=None; concl_occs=AllOccurrences } +let allHyps = { onhyps=None; concl_occs=NoOccurrences } +let onConcl = { onhyps=Some[]; concl_occs=AllOccurrences } +let nowhere = { onhyps=Some[]; concl_occs=NoOccurrences } +let onHyp h = + { onhyps=Some[(AllOccurrences,h),InHyp]; concl_occs=NoOccurrences } + +let is_nowhere = function +| { onhyps=Some[]; concl_occs=NoOccurrences } -> true +| _ -> false + +let is_all_occurrences = function + | AtLeastOneOccurrence + | AllOccurrences -> true + | _ -> false + +(** Clause conversion functions, parametrized by a hyp enumeration function *) + +(** From [clause] to [simple_clause] *) + +let simple_clause_of enum_hyps cl = + let error_occurrences () = + CErrors.user_err Pp.(str "This tactic does not support occurrences selection") in + let error_body_selection () = + CErrors.user_err Pp.(str "This tactic does not support body selection") in + let hyps = + match cl.onhyps with + | None -> + List.map Option.make (enum_hyps ()) + | Some l -> + List.map (fun ((occs,id),w) -> + if not (is_all_occurrences occs) then error_occurrences (); + if w = InHypValueOnly then error_body_selection (); + Some id) l in + if cl.concl_occs = NoOccurrences then hyps + else + if not (is_all_occurrences cl.concl_occs) then error_occurrences () + else None :: hyps + +(** From [clause] to [concrete_clause] *) + +let concrete_clause_of enum_hyps cl = + let hyps = + match cl.onhyps with + | None -> + let f id = OnHyp (id,AllOccurrences,InHyp) in + List.map f (enum_hyps ()) + | Some l -> + List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in + if cl.concl_occs = NoOccurrences then hyps + else + OnConcl cl.concl_occs :: hyps + +(** Miscellaneous functions *) + +let out_arg = function + | ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable.") + | ArgArg x -> x + +let occurrences_of_hyp id cls = + let rec hyp_occ = function + [] -> NoOccurrences, InHyp + | ((occs,id'),hl)::_ when Names.Id.equal id id' -> + occurrences_map (List.map out_arg) occs, hl + | _::l -> hyp_occ l in + match cls.onhyps with + None -> AllOccurrences,InHyp + | Some l -> hyp_occ l + +let occurrences_of_goal cls = + occurrences_map (List.map out_arg) cls.concl_occs + +let in_every_hyp cls = Option.is_empty cls.onhyps + +let clause_with_generic_occurrences cls = + let hyps = match cls.onhyps with + | None -> true + | Some hyps -> + List.for_all + (function ((AllOccurrences,_),_) -> true | _ -> false) hyps in + let concl = match cls.concl_occs with + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true + | _ -> false in + hyps && concl + +let clause_with_generic_context_selection cls = + let hyps = match cls.onhyps with + | None -> true + | Some hyps -> + List.for_all + (function ((AllOccurrences,_),InHyp) -> true | _ -> false) hyps in + let concl = match cls.concl_occs with + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true + | _ -> false in + hyps && concl diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli new file mode 100644 index 0000000000..ac15fe1018 --- /dev/null +++ b/pretyping/locusops.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Locus + +(** Utilities on occurrences *) + +val occurrences_map : + ('a list -> 'b list) -> 'a occurrences_gen -> 'b occurrences_gen + +(** From occurrences to a list of positions (or complement of positions) *) +val convert_occs : occurrences -> bool * int list + +val is_selected : int -> occurrences -> bool + +val is_all_occurrences : 'a occurrences_gen -> bool + +(** Usual clauses *) + +val allHypsAndConcl : 'a clause_expr +val allHyps : 'a clause_expr +val onConcl : 'a clause_expr +val nowhere : 'a clause_expr +val onHyp : 'a -> 'a clause_expr + +(** Tests *) + +val is_nowhere : 'a clause_expr -> bool + +(** Clause conversion functions, parametrized by a hyp enumeration function *) + +val simple_clause_of : (unit -> Id.t list) -> clause -> simple_clause +val concrete_clause_of : (unit -> Id.t list) -> clause -> concrete_clause + +(** Miscellaneous functions *) + +val occurrences_of_hyp : Id.t -> clause -> (occurrences * hyp_location_flag) +val occurrences_of_goal : clause -> occurrences +val in_every_hyp : clause -> bool + +val clause_with_generic_occurrences : 'a clause_expr -> bool +val clause_with_generic_context_selection : 'a clause_expr -> bool diff --git a/pretyping/ltac_pretype.ml b/pretyping/ltac_pretype.ml new file mode 100644 index 0000000000..ac59b96eef --- /dev/null +++ b/pretyping/ltac_pretype.ml @@ -0,0 +1,68 @@ +open Names +open Glob_term + +(** {5 Maps of pattern variables} *) + +(** Type [constr_under_binders] is for representing the term resulting + of a matching. Matching can return terms defined in a some context + of named binders; in the context, variable names are ordered by + (<) and referred to by index in the term Thanks to the canonical + ordering, a matching problem like + + [match ... with [(fun x y => ?p,fun y x => ?p)] => [forall x y => p]] + + will be accepted. Thanks to the reference by index, a matching + problem like + + [match ... with [(fun x => ?p)] => [forall x => p]] + + will work even if [x] is also the name of an existing goal + variable. + + Note: we do not keep types in the signature. Besides simplicity, + the main reason is that it would force to close the signature over + binders that occur only in the types of effective binders but not + in the term itself (e.g. for a term [f x] with [f:A -> True] and + [x:A]). + + On the opposite side, by not keeping the types, we loose + opportunity to propagate type informations which otherwise would + not be inferable, as e.g. when matching [forall x, x = 0] with + pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in + expression [forall x, h = x] where nothing tells how the type of x + could be inferred. We also loose the ability of typing ltac + variables before calling the right-hand-side of ltac matching clauses. *) + +type constr_under_binders = Id.t list * EConstr.constr + +(** Types of substitutions with or w/o bound variables *) + +type patvar_map = EConstr.constr Id.Map.t +type extended_patvar_map = constr_under_binders Id.Map.t + +(** A globalised term together with a closure representing the value + of its free variables. Intended for use when these variables are taken + from the Ltac environment. *) +type closure = { + idents:Id.t Id.Map.t; + typed: constr_under_binders Id.Map.t ; + untyped:closed_glob_constr Id.Map.t } +and closed_glob_constr = { + closure: closure; + term: glob_constr } + +(** Ltac variable maps *) +type var_map = constr_under_binders Id.Map.t +type uconstr_var_map = closed_glob_constr Id.Map.t +type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t + +type ltac_var_map = { + ltac_constrs : var_map; + (** Ltac variables bound to constrs *) + ltac_uconstrs : uconstr_var_map; + (** Ltac variables bound to untyped constrs *) + ltac_idents: Id.t Id.Map.t; + (** Ltac variables bound to identifiers *) + ltac_genargs : unbound_ltac_var_map; + (** All Ltac variables (to pass on ltac subterms, and for error reporting) *) +} diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml new file mode 100644 index 0000000000..e694502231 --- /dev/null +++ b/pretyping/nativenorm.ml @@ -0,0 +1,518 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open CErrors +open Term +open Constr +open Context +open Vars +open Environ +open Reduction +open Declarations +open Names +open Inductive +open Util +open Nativecode +open Nativevalues +open Context.Rel.Declaration + +(** This module implements normalization by evaluation to OCaml code *) + +exception Find_at of int + +(* profiling *) + +let profiling_enabled = ref false + +(* for supported platforms, filename for profiler results *) + +let profile_filename = ref "native_compute_profile.data" + +let profiler_platform () = + match [@warning "-8"] Sys.os_type with + | "Unix" -> + let in_ch = Unix.open_process_in "uname" in + let uname = input_line in_ch in + let _ = close_in in_ch in + Format.sprintf "Unix (%s)" uname + | "Win32" -> "Windows (Win32)" + | "Cygwin" -> "Windows (Cygwin)" + +let get_profile_filename () = !profile_filename + +let set_profile_filename fn = + profile_filename := fn + +(* find unused profile filename *) +let get_available_profile_filename () = + let profile_filename = get_profile_filename () in + let dir = Filename.dirname profile_filename in + let base = Filename.basename profile_filename in + (* starting with OCaml 4.04, could use Filename.remove_extension and Filename.extension, which + gets rid of need for exception-handling here + *) + let (name,ext) = + try + let nm = Filename.chop_extension base in + let nm_len = String.length nm in + let ex = String.sub base nm_len (String.length base - nm_len) in + (nm,ex) + with Invalid_argument _ -> (base,"") + in + try + (* unlikely race: fn deleted, another process uses fn *) + Filename.temp_file ~temp_dir:dir (name ^ "_") ext + with Sys_error s -> + let msg = "When trying to find native_compute profile output file: " ^ s in + let _ = Feedback.msg_info (Pp.str msg) in + assert false + +let get_profiling_enabled () = + !profiling_enabled + +let set_profiling_enabled b = + profiling_enabled := b + +let invert_tag cst tag reloc_tbl = + try + for j = 0 to Array.length reloc_tbl - 1 do + let tagj,arity = reloc_tbl.(j) in + if Int.equal tag tagj && (cst && Int.equal arity 0 || not(cst || Int.equal arity 0)) then + raise (Find_at j) + else () + done;raise Not_found + with Find_at j -> (j+1) + +let decompose_prod env t = + let (name,dom,codom) = destProd (whd_all env t) in + let name = map_annot (function + | Anonymous -> Name (Id.of_string "x") + | na -> na) name + in + (name,dom,codom) + +let app_type env c = + let t = whd_all env c in + try destApp t with DestKO -> (t,[||]) + + +let find_rectype_a env c = + let (t, l) = app_type env c in + match kind t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +(* Instantiate inductives and parameters in constructor type *) + +let type_constructor mind mib u (ctx, typ) params = + let typ = it_mkProd_or_LetIn typ ctx in + let s = ind_subst mind mib u in + let ctyp = substl s typ in + let nparams = Array.length params in + if Int.equal nparams 0 then ctyp + else + let _,ctyp = decompose_prod_n nparams ctyp in + substl (List.rev (Array.to_list params)) ctyp + +let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = + let mib,mip = lookup_mind_specif env ind in + let nparams = mib.mind_nparams in + let params = Array.sub allargs 0 nparams in + let i = invert_tag const tag mip.mind_reloc_tbl in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstructU((ind,i),u), params), ctyp) + + +let construct_of_constr const env sigma tag typ = + let t, l = app_type env typ in + match EConstr.kind_upto sigma t with + | Ind (ind,u) -> + construct_of_constr_notnative const env tag ind u l + | _ -> + assert (Constr.equal t (Typeops.type_of_int env)); + (mkInt (Uint63.of_int tag), t) + +let construct_of_constr_const env sigma tag typ = + fst (construct_of_constr true env sigma tag typ) + +let construct_of_constr_block = construct_of_constr false + +let build_branches_type env sigma (mind,_ as _ind) mib mip u params p = + let rtbl = mip.mind_reloc_tbl in + (* [build_one_branch i cty] construit le type de la ieme branche (commence + a 0) et les lambda correspondant aux realargs *) + let build_one_branch i cty = + let typi = type_constructor mind mib u cty params in + let decl,indapp = Reductionops.splay_prod env sigma (EConstr.of_constr typi) in + let decl = List.map (on_snd EConstr.Unsafe.to_constr) decl in + let indapp = EConstr.Unsafe.to_constr indapp in + let decl_with_letin,_ = decompose_prod_assum typi in + let ind,cargs = find_rectype_a env indapp in + let nparams = Array.length params in + let carity = snd (rtbl.(i)) in + let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in + let codom = + let ndecl = List.length decl in + let papp = mkApp(lift ndecl p,crealargs) in + let cstr = ith_constructor_of_inductive (fst ind) (i+1) in + let relargs = Array.init carity (fun i -> mkRel (carity-i)) in + let params = Array.map (lift ndecl) params in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in + mkApp(papp,[|dep_cstr|]) + in + decl, decl_with_letin, codom + in Array.mapi build_one_branch mip.mind_nf_lc + +let build_case_type p realargs c = + mkApp(mkApp(p, realargs), [|c|]) + +(* normalisation of values *) + +let branch_of_switch lvl ans bs = + let tbl = ans.asw_reloc in + let branch i = + let tag,arity = tbl.(i) in + let ci = + if Int.equal arity 0 then mk_const tag + else mk_block tag (mk_rels_accu lvl arity) in + bs ci in + Array.init (Array.length tbl) branch + +let get_proj env (ind, proj_arg) = + let mib = Environ.lookup_mind (fst ind) env in + match Declareops.inductive_make_projection ind mib ~proj_arg with + | None -> + CErrors.anomaly (Pp.strbrk "Return type is not a primitive record") + | Some p -> + Projection.make p true + +let rec nf_val env sigma v typ = + match kind_of_value v with + | Vaccu accu -> nf_accu env sigma accu + | Vfun f -> + let lvl = nb_rel env in + let name,dom,codom = + try decompose_prod env typ + with DestKO -> + CErrors.anomaly + (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") + in + let env = push_rel (LocalAssum (name,dom)) env in + let body = nf_val env sigma (f (mk_rel_accu lvl)) codom in + mkLambda(name,dom,body) + | Vconst n -> construct_of_constr_const env sigma n typ + | Vint64 i -> i |> Uint63.of_int64 |> mkInt + | Vblock b -> + let capp,ctyp = construct_of_constr_block env sigma (block_tag b) typ in + let args = nf_bargs env sigma b ctyp in + mkApp(capp,args) + +and nf_type env sigma v = + match kind_of_value v with + | Vaccu accu -> nf_accu env sigma accu + | _ -> assert false + +and nf_type_sort env sigma v = + match kind_of_value v with + | Vaccu accu -> + let t,s = nf_accu_type env sigma accu in + let s = + try + destSort (whd_all env s) + with DestKO -> + CErrors.anomaly (Pp.str "Value should be a sort") + in + t, s + | _ -> assert false + +and nf_accu env sigma accu = + let atom = atom_of_accu accu in + if Int.equal (accu_nargs accu) 0 then nf_atom env sigma atom + else + let a,typ = nf_atom_type env sigma atom in + let _, args = nf_args env sigma (args_of_accu accu) typ in + mkApp(a,Array.of_list args) + +and nf_accu_type env sigma accu = + let atom = atom_of_accu accu in + if Int.equal (accu_nargs accu) 0 then nf_atom_type env sigma atom + else + let a,typ = nf_atom_type env sigma atom in + let t, args = nf_args env sigma (args_of_accu accu) typ in + mkApp(a,Array.of_list args), t + +and nf_args env sigma args t = + let aux arg (t,l) = + let _,dom,codom = + try decompose_prod env t with + DestKO -> + CErrors.anomaly + (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") + in + let c = nf_val env sigma arg dom in + (subst1 c codom, c::l) + in + let t,l = Array.fold_right aux args (t,[]) in + t, List.rev l + +and nf_bargs env sigma b t = + let t = ref t in + let len = block_size b in + Array.init len + (fun i -> + let _,dom,codom = + try decompose_prod env !t with + DestKO -> + CErrors.anomaly + (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") + in + let c = nf_val env sigma (block_field b i) dom in + t := subst1 c codom; c) + +and nf_atom env sigma atom = + match atom with + | Arel i -> mkRel (nb_rel env - i) + | Aconstant cst -> mkConstU cst + | Aind ind -> mkIndU ind + | Asort s -> mkSort s + | Avar id -> mkVar id + | Aprod(n,dom,codom) -> + let dom, sdom = nf_type_sort env sigma dom in + let rdom = Sorts.relevance_of_sort sdom in + let n = make_annot n rdom in + let vn = mk_rel_accu (nb_rel env) in + let env = push_rel (LocalAssum (n,dom)) env in + let codom = nf_type env sigma (codom vn) in + mkProd(n,dom,codom) + | Ameta (mv,_) -> mkMeta mv + | Aproj (p, c) -> + let c = nf_accu env sigma c in + let p = get_proj env p in + mkProj(p, c) + | _ -> fst (nf_atom_type env sigma atom) + +and nf_atom_type env sigma atom = + match atom with + | Arel i -> + let n = (nb_rel env - i) in + mkRel n, Typeops.type_of_relative env n + | Aconstant cst -> + mkConstU cst, Typeops.type_of_constant_in env cst + | Aind ind -> + mkIndU ind, Inductiveops.type_of_inductive env ind + | Asort s -> + mkSort s, Typeops.type_of_sort s + | Avar id -> + mkVar id, Typeops.type_of_variable env id + | Acase(ans,accu,p,bs) -> + let a,ta = nf_accu_type env sigma accu in + let ((mind,_),u as ind),allargs = find_rectype_a env ta in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in + let nparams = mib.mind_nparams in + let params,realargs = Array.chop nparams allargs in + let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in + let pT = + hnf_prod_applist_assum env nparamdecls + (Inductiveops.type_of_inductive env ind) (Array.to_list params) in + let p = nf_predicate env sigma ind mip params p pT in + (* Calcul du type des branches *) + let btypes = build_branches_type env sigma (fst ind) mib mip u params p in + (* calcul des branches *) + let bsw = branch_of_switch (nb_rel env) ans bs in + let mkbranch i v = + let decl,decl_with_letin,codom = btypes.(i) in + let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in + Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin + in + let branchs = Array.mapi mkbranch bsw in + let tcase = build_case_type p realargs a in + let ci = ans.asw_ci in + mkCase(ci, p, a, branchs), tcase + | Afix(tt,ft,rp,s) -> + let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in + let tt = Array.map fst tt and rt = Array.map snd tt in + let name = Name (Id.of_string "Ffix") in + let names = Array.map (fun s -> make_annot name (Sorts.relevance_of_sort s)) rt in + let lvl = nb_rel env in + let nbfix = Array.length ft in + let fargs = mk_rels_accu lvl (Array.length ft) in + (* Body argument of the tuple is ignored by push_rec_types *) + let env = push_rec_types (names,tt,[||]) env in + (* We lift here because the types of arguments (in tt) will be evaluated + in an environment where the fixpoints have been pushed *) + let norm_body i v = nf_val env sigma (napply v fargs) (lift nbfix tt.(i)) in + let ft = Array.mapi norm_body ft in + mkFix((rp,s),(names,tt,ft)), tt.(s) + | Acofix(tt,ft,s,_) | Acofixe(tt,ft,s,_) -> + let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in + let tt = Array.map fst tt and rt = Array.map snd tt in + let name = Name (Id.of_string "Fcofix") in + let lvl = nb_rel env in + let names = Array.map (fun s -> make_annot name (Sorts.relevance_of_sort s)) rt in + let fargs = mk_rels_accu lvl (Array.length ft) in + let env = push_rec_types (names,tt,[||]) env in + let ft = Array.mapi (fun i v -> nf_val env sigma (napply v fargs) tt.(i)) ft in + mkCoFix(s,(names,tt,ft)), tt.(s) + | Aprod(n,dom,codom) -> + let dom,s1 = nf_type_sort env sigma dom in + let r1 = Sorts.relevance_of_sort s1 in + let n = make_annot n r1 in + let vn = mk_rel_accu (nb_rel env) in + let env = push_rel (LocalAssum (n,dom)) env in + let codom,s2 = nf_type_sort env sigma (codom vn) in + mkProd(n,dom,codom), Typeops.type_of_product env n s1 s2 + | Aevar(evk,args) -> + nf_evar env sigma evk args + | Ameta(mv,ty) -> + let ty = nf_type env sigma ty in + mkMeta mv, ty + | Aproj(p,c) -> + let c,tc = nf_accu_type env sigma c in + let cj = make_judge c tc in + let p = get_proj env p in + let uj = Typeops.judge_of_projection env p cj in + uj.uj_val, uj.uj_type + + +and nf_predicate env sigma ind mip params v pT = + match kind (whd_allnolet env pT) with + | LetIn (name,b,t,pT) -> + let body = + nf_predicate (push_rel (LocalDef (name,b,t)) env) sigma ind mip params v pT in + mkLetIn (name,b,t,body) + | Prod (name,dom,codom) -> begin + match kind_of_value v with + | Vfun f -> + let k = nb_rel env in + let vb = f (mk_rel_accu k) in + let body = + nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in + mkLambda(name,dom,body) + | _ -> nf_type env sigma v + end + | _ -> + match kind_of_value v with + | Vfun f -> + let k = nb_rel env in + let vb = f (mk_rel_accu k) in + let name = Name (Id.of_string "c") in + let n = mip.mind_nrealargs in + let rargs = Array.init n (fun i -> mkRel (n-i)) in + let params = if Int.equal n 0 then params else Array.map (lift n) params in + let dom = mkApp(mkIndU ind,Array.append params rargs) in + let r = Inductive.relevance_of_inductive env (fst ind) in + let name = make_annot name r in + let body = nf_type (push_rel (LocalAssum (name,dom)) env) sigma vb in + mkLambda(name,dom,body) + | _ -> nf_type env sigma v + +and nf_evar env sigma evk args = + let evi = try Evd.find sigma evk with Not_found -> assert false in + let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in + let ty = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in + if List.is_empty hyps then begin + assert (Int.equal (Array.length args) 0); + mkEvar (evk, [||]), ty + end + else + (* Let-bound arguments are present in the evar arguments but not + in the type, so we turn the let into a product. *) + let hyps = Context.Named.drop_bodies hyps in + let fold accu d = Term.mkNamedProd_or_LetIn d accu in + let t = List.fold_left fold ty hyps in + let ty, args = nf_args env sigma args t in + (* nf_args takes arguments in the reverse order but produces them + in the correct one, so we have to reverse them again for the + evar node *) + mkEvar (evk, Array.rev_of_list args), ty + +let evars_of_evar_map sigma = + { Nativelambda.evars_val = Evd.existential_opt_value0 sigma; + Nativelambda.evars_metas = Evd.meta_type0 sigma } + +(* fork perf process, return profiler's process id *) +let start_profiler_linux profile_fn = + let coq_pid = Unix.getpid () in (* pass pid of running coqtop *) + (* we don't want to see perf's console output *) + let dev_null = Unix.descr_of_out_channel (open_out_bin "/dev/null") in + let _ = Feedback.msg_info (Pp.str ("Profiling to file " ^ profile_fn)) in + let perf = "perf" in + let profiler_pid = + Unix.create_process + perf + [|perf; "record"; "-g"; "-o"; profile_fn; "-p"; string_of_int coq_pid |] + Unix.stdin dev_null dev_null + in + (* doesn't seem to be a way to test whether process creation succeeded *) + if !Flags.debug then + Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); + Some profiler_pid + +(* kill profiler via SIGINT *) +let stop_profiler_linux m_pid = + match m_pid with + | Some pid -> ( + let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in + try + Unix.kill pid Sys.sigint; + let _ = Unix.waitpid [] pid in () + with Unix.Unix_error (Unix.ESRCH,"kill","") -> + Feedback.msg_info (Pp.str "Could not stop native code profiler, no such process") + ) + | None -> () + +let start_profiler () = + let profile_fn = get_available_profile_filename () in + match profiler_platform () with + "Unix (Linux)" -> start_profiler_linux profile_fn + | _ -> + let _ = Feedback.msg_info + (Pp.str (Format.sprintf "Native_compute profiling not supported on the platform: %s" + (profiler_platform ()))) in + None + +let stop_profiler m_pid = + match profiler_platform() with + "Unix (Linux)" -> stop_profiler_linux m_pid + | _ -> () + +let native_norm env sigma c ty = + let c = EConstr.Unsafe.to_constr c in + let ty = EConstr.Unsafe.to_constr ty in + if not Coq_config.native_compiler then + user_err Pp.(str "Native_compute reduction has been disabled at configure time.") + else + (* + Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); + Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); + *) + let ml_filename, prefix = Nativelib.get_ml_filename () in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in + let profile = get_profiling_enabled () in + let fn = Nativelib.compile ml_filename code ~profile:profile in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let profiler_pid = if profile then start_profiler () else None in + let t0 = Sys.time () in + Nativelib.call_linker ~fatal:true prefix fn (Some upd); + let t1 = Sys.time () in + if profile then stop_profiler profiler_pid; + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + let res = nf_val env sigma !Nativelib.rt1 ty in + let t2 = Sys.time () in + let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + EConstr.of_constr res + +let native_conv_generic pb sigma t = + Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t + +let native_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = + Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma) + ~catch_incon:true ~pb env sigma t1 t2 diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli new file mode 100644 index 0000000000..4997d0bf0d --- /dev/null +++ b/pretyping/nativenorm.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open EConstr +open Environ +open Evd + +(** This module implements normalization by evaluation to OCaml code *) + +val get_profile_filename : unit -> string +val set_profile_filename : string -> unit + +val get_profiling_enabled : unit -> bool +val set_profiling_enabled : bool -> unit + + +val native_norm : env -> evar_map -> constr -> types -> constr + +(** Conversion with inference of universe constraints *) +val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map option diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml new file mode 100644 index 0000000000..d1c0a4ea2a --- /dev/null +++ b/pretyping/pattern.ml @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** {5 Patterns} *) + +(** Cases pattern variables *) +type patvar = Id.t + +type case_info_pattern = + { cip_style : Constr.case_style; + cip_ind : inductive option; + cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) + cip_extensible : bool (** does this match end with _ => _ ? *) } + +type constr_pattern = + | PRef of GlobRef.t + | PVar of Id.t + | PEvar of Evar.t * constr_pattern array + | PRel of int + | PApp of constr_pattern * constr_pattern array + | PSoApp of patvar * constr_pattern list + | PProj of Projection.t * constr_pattern + | PLambda of Name.t * constr_pattern * constr_pattern + | PProd of Name.t * constr_pattern * constr_pattern + | PLetIn of Name.t * constr_pattern * constr_pattern option * constr_pattern + | PSort of Sorts.family + | PMeta of patvar option + | PIf of constr_pattern * constr_pattern * constr_pattern + | PCase of case_info_pattern * constr_pattern * constr_pattern * + (int * bool list * constr_pattern) list (** index of constructor, nb of args *) + | PFix of (int array * int) * (Name.t array * constr_pattern array * constr_pattern array) + | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) + | PInt of Uint63.t + +(** Nota : in a [PCase], the array of branches might be shorter than + expected, denoting the use of a final "_ => _" branch *) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml new file mode 100644 index 0000000000..c788efda48 --- /dev/null +++ b/pretyping/patternops.ml @@ -0,0 +1,547 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Util +open Names +open Globnames +open Nameops +open Constr +open Context +open Glob_term +open Pp +open Mod_subst +open Decl_kinds +open Pattern +open Environ + +let case_info_pattern_eq i1 i2 = + i1.cip_style == i2.cip_style && + Option.equal eq_ind i1.cip_ind i2.cip_ind && + Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags && + i1.cip_extensible == i2.cip_extensible + +let rec constr_pattern_eq p1 p2 = match p1, p2 with +| PRef r1, PRef r2 -> GlobRef.equal r1 r2 +| PVar v1, PVar v2 -> Id.equal v1 v2 +| PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> + Evar.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2 +| PRel i1, PRel i2 -> + Int.equal i1 i2 +| PApp (t1, arg1), PApp (t2, arg2) -> + constr_pattern_eq t1 t2 && Array.equal constr_pattern_eq arg1 arg2 +| PSoApp (id1, arg1), PSoApp (id2, arg2) -> + Id.equal id1 id2 && List.equal constr_pattern_eq arg1 arg2 +| PLambda (v1, t1, b1), PLambda (v2, t2, b2) -> + Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2 +| PProd (v1, t1, b1), PProd (v2, t2, b2) -> + Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2 +| PLetIn (v1, b1, t1, c1), PLetIn (v2, b2, t2, c2) -> + Name.equal v1 v2 && constr_pattern_eq b1 b2 && + Option.equal constr_pattern_eq t1 t2 && constr_pattern_eq c1 c2 +| PSort s1, PSort s2 -> Sorts.family_equal s1 s2 +| PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2 +| PIf (t1, l1, r1), PIf (t2, l2, r2) -> + constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 +| PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) -> + case_info_pattern_eq info1 info2 && + constr_pattern_eq p1 p2 && + constr_pattern_eq r1 r2 && + List.equal pattern_eq l1 l2 +| PFix ((ln1,i1),f1), PFix ((ln2,i2),f2) -> + Array.equal Int.equal ln1 ln2 && Int.equal i1 i2 && rec_declaration_eq f1 f2 +| PCoFix (i1,f1), PCoFix (i2,f2) -> + Int.equal i1 i2 && rec_declaration_eq f1 f2 +| PProj (p1, t1), PProj (p2, t2) -> + Projection.equal p1 p2 && constr_pattern_eq t1 t2 +| PInt i1, PInt i2 -> + Uint63.equal i1 i2 +| (PRef _ | PVar _ | PEvar _ | PRel _ | PApp _ | PSoApp _ + | PLambda _ | PProd _ | PLetIn _ | PSort _ | PMeta _ + | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _ | PInt _), _ -> false +(** FIXME: fixpoint and cofixpoint should be relativized to pattern *) + +and pattern_eq (i1, j1, p1) (i2, j2, p2) = + Int.equal i1 i2 && List.equal (==) j1 j2 && constr_pattern_eq p1 p2 + +and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = + Array.equal Name.equal n1 n2 && + Array.equal constr_pattern_eq c1 c2 && + Array.equal constr_pattern_eq r1 r2 + +let rec occur_meta_pattern = function + | PApp (f,args) -> + (occur_meta_pattern f) || (Array.exists occur_meta_pattern args) + | PProj (_,arg) -> occur_meta_pattern arg + | PLambda (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) + | PProd (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) + | PLetIn (na,b,t,c) -> + Option.fold_left (fun b t -> b || occur_meta_pattern t) (occur_meta_pattern b) t || (occur_meta_pattern c) + | PIf (c,c1,c2) -> + (occur_meta_pattern c) || + (occur_meta_pattern c1) || (occur_meta_pattern c2) + | PCase(_,p,c,br) -> + (occur_meta_pattern p) || + (occur_meta_pattern c) || + (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) + | PMeta _ | PSoApp _ -> true + | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ + | PInt _ -> false + +let rec occurn_pattern n = function + | PRel p -> Int.equal n p + | PApp (f,args) -> + (occurn_pattern n f) || (Array.exists (occurn_pattern n) args) + | PProj (_,arg) -> occurn_pattern n arg + | PLambda (na,t,c) -> (occurn_pattern n t) || (occurn_pattern (n+1) c) + | PProd (na,t,c) -> (occurn_pattern n t) || (occurn_pattern (n+1) c) + | PLetIn (na,b,t,c) -> + Option.fold_left (fun b t -> b || occurn_pattern n t) (occurn_pattern n b) t || + (occurn_pattern (n+1) c) + | PIf (c,c1,c2) -> + (occurn_pattern n c) || + (occurn_pattern n c1) || (occurn_pattern n c2) + | PCase(_,p,c,br) -> + (occurn_pattern n p) || + (occurn_pattern n c) || + (List.exists (fun (_,_,p) -> occurn_pattern n p) br) + | PMeta _ | PSoApp _ -> true + | PEvar (_,args) -> Array.exists (occurn_pattern n) args + | PVar _ | PRef _ | PSort _ | PInt _ -> false + | PFix (_,(_,tl,bl)) -> + Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl + | PCoFix (_,(_,tl,bl)) -> + Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl + +let noccurn_pattern n c = not (occurn_pattern n c) + +exception BoundPattern;; + +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 + | PIf (c,_,_) -> head_pattern_bound c + | PCase (_,p,c,br) -> head_pattern_bound c + | PRef r -> r + | PVar id -> VarRef id + | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ | PProj _ + -> raise BoundPattern + (* Perhaps they were arguments, but we don't beta-reduce *) + | PLambda _ -> raise BoundPattern + | PCoFix _ | PInt _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") + +let head_of_constr_reference sigma c = match EConstr.kind sigma c with + | Const (sp,_) -> ConstRef sp + | Construct (sp,_) -> ConstructRef sp + | Ind (sp,_) -> IndRef sp + | Var id -> VarRef id + | _ -> anomaly (Pp.str "Not a rigid reference.") + +let pattern_of_constr env sigma t = + let rec pattern_of_constr env t = + let open Context.Rel.Declaration in + match kind t with + | Rel n -> PRel n + | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) + | Var id -> PVar id + | Sort s -> PSort (Sorts.family s) + | Cast (c,_,_) -> pattern_of_constr env c + | LetIn (na,c,t,b) -> PLetIn (na.binder_name, + pattern_of_constr env c,Some (pattern_of_constr env t), + pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) + | Prod (na,c,b) -> PProd (na.binder_name, + pattern_of_constr env c, + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + | Lambda (na,c,b) -> PLambda (na.binder_name, + pattern_of_constr env c, + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + | App (f,a) -> + (match + match kind f with + | Evar (evk,args) -> + (match snd (Evd.evar_source evk sigma) with + Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar id) -> Some id + | _ -> None) + | _ -> None + with + | Some n -> PSoApp (n,Array.to_list (Array.map (pattern_of_constr env) a)) + | None -> PApp (pattern_of_constr env f,Array.map (pattern_of_constr env) a)) + | Const (sp,u) -> PRef (ConstRef (Constant.make1 (Constant.canonical sp))) + | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) + | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) + | Proj (p, c) -> + pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) + | Evar (evk,ctxt as ev) -> + (match snd (Evd.evar_source evk sigma) with + | Evar_kinds.MatchingVar (Evar_kinds.FirstOrderPatVar id) -> + PMeta (Some id) + | Evar_kinds.GoalEvar | Evar_kinds.VarInstance _ -> + (* These are the two evar kinds used for existing goals *) + (* see Proofview.mark_in_evm *) + if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value0 sigma ev) + else PEvar (evk,Array.map (pattern_of_constr env) ctxt) + | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false + | _ -> + PMeta None) + | Case (ci,p,a,br) -> + let cip = + { cip_style = ci.ci_pp_info.style; + cip_ind = Some ci.ci_ind; + cip_ind_tags = Some ci.ci_pp_info.ind_tags; + cip_extensible = false } + in + let branch_of_constr i c = + (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) + in + PCase (cip, pattern_of_constr env p, pattern_of_constr env a, + Array.to_list (Array.mapi branch_of_constr br)) + | Fix (lni,(lna,tl,bl)) -> + let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in + let env' = Array.fold_left2 push env lna tl in + PFix (lni,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, + Array.map (pattern_of_constr env') bl)) + | CoFix (ln,(lna,tl,bl)) -> + let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in + let env' = Array.fold_left2 push env lna tl in + PCoFix (ln,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, + Array.map (pattern_of_constr env') bl)) + | Int i -> PInt i in + pattern_of_constr env t + +(* To process patterns, we need a translation without typing at all. *) + +let map_pattern_with_binders g f l = function + | PApp (p,pl) -> PApp (f l p, Array.map (f l) pl) + | PSoApp (n,pl) -> PSoApp (n, List.map (f l) pl) + | PLambda (n,a,b) -> PLambda (n,f l a,f (g n l) b) + | PProd (n,a,b) -> PProd (n,f l a,f (g n l) b) + | PLetIn (n,a,t,b) -> PLetIn (n,f l a,Option.map (f l) t,f (g n l) b) + | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) + | PCase (ci,po,p,pl) -> + PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + | PProj (p,pc) -> PProj (p, f l pc) + | PFix (lni,(lna,tl,bl)) -> + let l' = Array.fold_left (fun l na -> g na l) l lna in + PFix (lni,(lna,Array.map (f l) tl,Array.map (f l') bl)) + | PCoFix (ln,(lna,tl,bl)) -> + let l' = Array.fold_left (fun l na -> g na l) l lna in + PCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + (* Non recursive *) + | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PInt _ as x) -> x + +let error_instantiate_pattern id l = + let is = match l with + | [_] -> "is" + | _ -> "are" + in + user_err (str "Cannot substitute the term bound to " ++ Id.print id + ++ strbrk " in pattern because the term refers to " ++ pr_enum Id.print l + ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.") + +let instantiate_pattern env sigma lvar c = + let open EConstr in + let open Vars in + let rec aux vars = function + | PVar id as x -> + (try + let ctx,c = Id.Map.find id lvar in + try + let inst = + List.map + (fun id -> mkRel (List.index Name.equal (Name id) vars)) + ctx + in + let c = substl inst c in + (* FIXME: Stupid workaround to pattern_of_constr being evar sensitive *) + let c = Evarutil.nf_evar sigma c in + pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) + with Not_found (* List.index failed *) -> + let vars = + List.map_filter (function Name id -> Some id | _ -> None) vars in + error_instantiate_pattern id (List.subtract Id.equal ctx vars) + with Not_found (* Map.find failed *) -> + x) + | c -> + map_pattern_with_binders (fun id vars -> id::vars) aux vars c in + aux [] c + +let rec liftn_pattern k n = function + | PRel i as x -> if i >= n then PRel (i+k) else x + | c -> map_pattern_with_binders (fun _ -> succ) (liftn_pattern k) n c + +let lift_pattern k = liftn_pattern k 1 + +let rec subst_pattern env sigma subst pat = + match pat with + | PRef ref -> + let ref',t = subst_global subst ref in + if ref' == ref then pat else (match t with + | None -> PRef ref' + | Some t -> + pattern_of_constr env sigma t.Univ.univ_abstracted_value) + | PVar _ + | PEvar _ + | PRel _ + | PInt _ -> pat + | PProj (p,c) -> + let p' = Projection.map (subst_mind subst) p in + let c' = subst_pattern env sigma subst c in + if p' == p && c' == c then pat else + PProj(p',c') + | PApp (f,args) -> + let f' = subst_pattern env sigma subst f in + let args' = Array.Smart.map (subst_pattern env sigma subst) args in + if f' == f && args' == args then pat else + PApp (f',args') + | PSoApp (i,args) -> + let args' = List.Smart.map (subst_pattern env sigma subst) args in + if args' == args then pat else + PSoApp (i,args') + | PLambda (name,c1,c2) -> + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in + if c1' == c1 && c2' == c2 then pat else + PLambda (name,c1',c2') + | PProd (name,c1,c2) -> + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in + if c1' == c1 && c2' == c2 then pat else + PProd (name,c1',c2') + | PLetIn (name,c1,t,c2) -> + let c1' = subst_pattern env sigma subst c1 in + let t' = Option.Smart.map (subst_pattern env sigma subst) t in + let c2' = subst_pattern env sigma subst c2 in + if c1' == c1 && t' == t && c2' == c2 then pat else + PLetIn (name,c1',t',c2') + | PSort _ + | PMeta _ -> pat + | PIf (c,c1,c2) -> + let c' = subst_pattern env sigma subst c in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in + if c' == c && c1' == c1 && c2' == c2 then pat else + PIf (c',c1',c2') + | PCase (cip,typ,c,branches) -> + let ind = cip.cip_ind in + let ind' = Option.Smart.map (subst_ind subst) ind in + let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in + let typ' = subst_pattern env sigma subst typ in + let c' = subst_pattern env sigma subst c in + let subst_branch ((i,n,c) as br) = + let c' = subst_pattern env sigma subst c in + if c' == c then br else (i,n,c') + in + let branches' = List.Smart.map subst_branch branches in + if cip' == cip && typ' == typ && c' == c && branches' == branches + then pat + else PCase(cip', typ', c', branches') + | PFix (lni,(lna,tl,bl)) -> + let tl' = Array.Smart.map (subst_pattern env sigma subst) tl in + let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in + if bl' == bl && tl' == tl then pat + else PFix (lni,(lna,tl',bl')) + | PCoFix (ln,(lna,tl,bl)) -> + let tl' = Array.Smart.map (subst_pattern env sigma subst) tl in + let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in + if bl' == bl && tl' == tl then pat + else PCoFix (ln,(lna,tl',bl')) + +let mkPLetIn na b t c = PLetIn(na,b,t,c) +let mkPProd na t u = PProd(na,t,u) +let mkPLambda na t b = PLambda(na,t,b) +let mkPLambdaUntyped na b = PLambda(na,PMeta None,b) +let rev_it_mkPLambdaUntyped = List.fold_right mkPLambdaUntyped + +let mkPProd_or_LetIn (na,_,bo,t) c = + match bo with + | None -> mkPProd na t c + | Some b -> mkPLetIn na b (Some t) c + +let mkPLambda_or_LetIn (na,_,bo,t) c = + match bo with + | None -> mkPLambda na t c + | Some b -> mkPLetIn na b (Some t) c + +let it_mkPProd_or_LetIn = List.fold_left (fun c d -> mkPProd_or_LetIn d c) +let it_mkPLambda_or_LetIn = List.fold_left (fun c d -> mkPLambda_or_LetIn d c) + +let err ?loc pp = user_err ?loc ~hdr:"pattern_of_glob_constr" pp + +let warn_cast_in_pattern = + CWarnings.create ~name:"cast-in-pattern" ~category:"automation" + (fun () -> Pp.strbrk "Casts are ignored in patterns") + +let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function + | GVar id -> + (try PRel (List.index Name.equal (Name id) vars) + with Not_found -> PVar id) + | GPatVar (Evar_kinds.FirstOrderPatVar n) -> + metas := n::!metas; PMeta (Some n) + | GRef (gr,_) -> + PRef (canonical_gr gr) + (* Hack to avoid rewriting a complete interpretation of patterns *) + | GApp (c, cl) -> + begin match DAst.get c with + | GPatVar (Evar_kinds.SecondOrderPatVar n) -> + metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) + | _ -> + PApp (pat_of_raw metas vars c, + Array.of_list (List.map (pat_of_raw metas vars) cl)) + end + | GLambda (na,bk,c1,c2) -> + Name.iter (fun n -> metas := n::!metas) na; + PLambda (na, pat_of_raw metas vars c1, + pat_of_raw metas (na::vars) c2) + | GProd (na,bk,c1,c2) -> + Name.iter (fun n -> metas := n::!metas) na; + PProd (na, pat_of_raw metas vars c1, + pat_of_raw metas (na::vars) c2) + | GLetIn (na,c1,t,c2) -> + Name.iter (fun n -> metas := n::!metas) na; + PLetIn (na, pat_of_raw metas vars c1, + Option.map (pat_of_raw metas vars) t, + pat_of_raw metas (na::vars) c2) + | GSort gs -> PSort (Glob_ops.glob_sort_family gs) + | GHole _ -> + PMeta None + | GCast (c,_) -> + warn_cast_in_pattern (); + pat_of_raw metas vars c + | GIf (c,(_,None),b1,b2) -> + PIf (pat_of_raw metas vars c, + pat_of_raw metas vars b1,pat_of_raw metas vars b2) + | GLetTuple (nal,(_,None),b,c) -> + let mkGLambda na c = DAst.make ?loc @@ + GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None),c) in + let c = List.fold_right mkGLambda nal c in + let cip = + { cip_style = LetStyle; + cip_ind = None; + cip_ind_tags = None; + cip_extensible = false } + in + let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in + PCase (cip, PMeta None, pat_of_raw metas vars b, + [0,tags,pat_of_raw metas vars c]) + | GCases (sty,p,[c,(na,indnames)],brs) -> + let get_ind p = match DAst.get p with + | PatCstr((ind,_),_,_) -> Some ind + | _ -> None + in + let get_ind = function + | {CAst.v=(_,[p],_)}::_ -> get_ind p + | _ -> None + in + let ind_tags,ind = match indnames with + | Some {CAst.v=(ind,nal)} -> Some (List.length nal), Some ind + | None -> None, get_ind brs + in + let ext,brs = pats_of_glob_branches loc metas vars ind brs + in + let pred = match p,indnames with + | Some p, Some {CAst.v=(_,nal)} -> + let nvars = na :: List.rev nal @ vars in + rev_it_mkPLambdaUntyped nal (mkPLambdaUntyped na (pat_of_raw metas nvars p)) + | None, _ -> PMeta None + | Some p, None -> + match DAst.get p with + | GHole _ -> PMeta None + | _ -> + user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") + in + let info = + { cip_style = sty; + cip_ind = ind; + cip_ind_tags = None; + cip_extensible = ext } + in + (* Nota : when we have a non-trivial predicate, + the inductive type is known. Same when we have at least + one non-trivial branch. These facts are used in [Constrextern]. *) + PCase (info, pred, pat_of_raw metas vars c, brs) + + | GRec (GFix (ln,n), ids, decls, tl, cl) -> + let get_struct_arg = function + | Some n -> n + | None -> err ?loc (Pp.str "\"struct\" annotation is expected.") + (* TODO why can't the annotation be omitted? *) + in + let ln = Array.map get_struct_arg ln in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in + let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in + let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in + let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in + let names = Array.map (fun id -> Name id) ids in + PFix ((ln,n), (names, tl, cl)) + + | GRec (GCoFix n, ids, decls, tl, cl) -> + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in + let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in + let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in + let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in + let names = Array.map (fun id -> Name id) ids in + PCoFix (n, (names, tl, cl)) + + | GInt i -> PInt i + | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ -> + err ?loc (Pp.str "Non supported pattern.")) + +and pat_of_glob_in_context metas vars decls c = + let rec aux acc vars = function + | (na,bk,b,t) :: decls -> + let decl = (na,bk,Option.map (pat_of_raw metas vars) b,pat_of_raw metas vars t) in + aux (decl::acc) (na::vars) decls + | [] -> + acc, pat_of_raw metas vars c + in aux [] vars decls + +and pats_of_glob_branches loc metas vars ind brs = + let get_arg p = match DAst.get p with + | PatVar na -> + Name.iter (fun n -> metas := n::!metas) na; + na + | PatCstr(_,_,_) -> err ?loc:p.CAst.loc (Pp.str "Non supported pattern.") + in + let rec get_pat indexes = function + | [] -> false, [] + | {CAst.loc=loc';v=(_,[p], br)} :: brs -> + begin match DAst.get p, DAst.get br, brs with + | PatVar Anonymous, GHole _, [] -> + true, [] (* ends with _ => _ *) + | PatCstr((indsp,j),lv,_), _, _ -> + let () = match ind with + | Some sp when eq_ind sp indsp -> () + | _ -> + err ?loc (Pp.str "All constructors must be in the same inductive type.") + in + if Int.Set.mem (j-1) indexes then + err ?loc + (str "No unique branch for " ++ int j ++ str"-th constructor."); + let lna = List.map get_arg lv in + let vars' = List.rev lna @ vars in + let pat = rev_it_mkPLambdaUntyped lna (pat_of_raw metas vars' br) in + let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in + let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in + ext, ((j-1, tags, pat) :: pats) + | _ -> + err ?loc:loc' (Pp.str "Non supported pattern.") + end + | {CAst.loc;v=(_,_,_)} :: _ -> err ?loc (Pp.str "Non supported pattern.") + in + get_pat Int.Set.empty brs + +let pattern_of_glob_constr c = + let metas = ref [] in + let p = pat_of_raw metas [] c in + (!metas,p) diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli new file mode 100644 index 0000000000..3821fbf1a0 --- /dev/null +++ b/pretyping/patternops.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Mod_subst +open Glob_term +open Pattern +open EConstr +open Ltac_pretype + +(** {5 Functions on patterns} *) + +val constr_pattern_eq : constr_pattern -> constr_pattern -> bool + +val occur_meta_pattern : constr_pattern -> bool + +val subst_pattern : Environ.env -> Evd.evar_map -> substitution -> constr_pattern -> constr_pattern + +val noccurn_pattern : int -> constr_pattern -> bool + +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 -> GlobRef.t + +(** [head_of_constr_reference c] assumes [r] denotes a reference and + returns its label; raises an anomaly otherwise *) + +val head_of_constr_reference : Evd.evar_map -> constr -> GlobRef.t + +(** [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 : Environ.env -> Evd.evar_map -> Constr.constr -> constr_pattern + +(** [pattern_of_glob_constr 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_glob_constr : glob_constr -> + patvar list * constr_pattern + +val instantiate_pattern : Environ.env -> + Evd.evar_map -> extended_patvar_map -> + constr_pattern -> constr_pattern + +val lift_pattern : int -> constr_pattern -> constr_pattern diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml new file mode 100644 index 0000000000..35a7036af4 --- /dev/null +++ b/pretyping/pretype_errors.ml @@ -0,0 +1,193 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open EConstr +open Type_errors + +type unification_error = + | OccurCheck of Evar.t * constr + | NotClean of existential * env * constr (* Constr is a variable not in scope *) + | NotSameArgSize + | NotSameHead + | NoCanonicalStructure + | ConversionFailed of env * constr * constr (* Non convertible closed terms *) + | MetaOccurInBody of Evar.t + | InstanceNotSameType of Evar.t * env * types * types + | UnifUnivInconsistency of Univ.univ_inconsistency + | CannotSolveConstraint of Evd.evar_constraint * unification_error + | ProblemBeyondCapabilities + +type position = (Id.t * Locus.hyp_location_flag) option + +type position_reporting = (position * int) * constr + +type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option + +type type_error = (constr, types) ptype_error + +type pretype_error = + (* Old Case *) + | CantFindCaseType of constr + (* Type inference unification *) + | ActualTypeNotCoercible of unsafe_judgment * types * unification_error + (* Tactic unification *) + | UnifOccurCheck of Evar.t * constr + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option + | CannotUnify of constr * constr * unification_error option + | CannotUnifyLocal of constr * constr * constr + | CannotUnifyBindingType of constr * constr + | CannotGeneralize of constr + | NoOccurrenceFound of constr * Id.t option + | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option + | WrongAbstractionType of Name.t * constr * types * types + | AbstractionOverMeta of Name.t * Name.t + | NonLinearUnification of Name.t * constr + (* Pretyping *) + | VarNotFound of Id.t + | EvarNotFound of Id.t + | UnexpectedType of constr * constr + | NotProduct of constr + | TypingError of type_error + | CannotUnifyOccurrences of subterm_unification_error + | UnsatisfiableConstraints of + (Evar.t * Evar_kinds.t) option * Evar.Set.t option + | DisallowedSProp + +exception PretypeError of env * Evd.evar_map * pretype_error + +let precatchable_exception = function + | CErrors.UserError _ | TypeError _ | PretypeError _ + | Nametab.GlobalizationError _ -> true + | _ -> false + +let raise_pretype_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,te)) + +let raise_type_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,TypingError te)) + +let error_actual_type ?loc env sigma {uj_val=c;uj_type=actty} expty reason = + let j = {uj_val=c;uj_type=actty} in + raise_pretype_error ?loc + (env, sigma, ActualTypeNotCoercible (j, expty, reason)) + +let error_actual_type_core ?loc env sigma {uj_val=c;uj_type=actty} expty = + let j = {uj_val=c;uj_type=actty} in + raise_type_error ?loc + (env, sigma, ActualType (j, expty)) + +let error_cant_apply_not_functional ?loc env sigma rator randl = + raise_type_error ?loc + (env, sigma, CantApplyNonFunctional (rator, randl)) + +let error_cant_apply_bad_type ?loc env sigma (n,c,t) rator randl = + raise_type_error ?loc + (env, sigma, + CantApplyBadType ((n,c,t), rator, randl)) + +let error_ill_formed_branch ?loc env sigma c i actty expty = + raise_type_error + ?loc (env, sigma, IllFormedBranch (c, i, actty, expty)) + +let error_number_branches ?loc env sigma cj expn = + raise_type_error ?loc (env, sigma, NumberBranches (cj, expn)) + +let error_case_not_inductive ?loc env sigma cj = + raise_type_error ?loc (env, sigma, CaseNotInductive cj) + +let error_ill_typed_rec_body ?loc env sigma i na jl tys = + raise_type_error ?loc + (env, sigma, IllTypedRecBody (i, na, jl, tys)) + +let error_elim_arity ?loc env sigma pi c j a = + raise_type_error ?loc + (env, sigma, ElimArity (pi, c, j, a)) + +let error_not_a_type ?loc env sigma j = + raise_type_error ?loc (env, sigma, NotAType j) + +let error_assumption ?loc env sigma j = + raise_type_error ?loc (env, sigma, BadAssumption j) + +(*s Implicit arguments synthesis errors. It is hard to find + a precise location. *) + +let error_occur_check env sigma ev c = + raise (PretypeError (env, sigma, UnifOccurCheck (ev,c))) + +let error_unsolvable_implicit ?loc env sigma evk explain = + Loc.raise ?loc + (PretypeError (env, sigma, UnsolvableImplicit (evk, explain))) + +let error_cannot_unify ?loc env sigma ?reason (m,n) = + Loc.raise ?loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) + +let error_cannot_unify_local env sigma (m,n,sn) = + raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn))) + +let error_cannot_coerce env sigma (m,n) = + raise (PretypeError (env, sigma,CannotUnify (m,n,None))) + +let error_cannot_find_well_typed_abstraction env sigma p l e = + raise (PretypeError (env, sigma,CannotFindWellTypedAbstraction (p,l,e))) + +let error_wrong_abstraction_type env sigma na a p l = + raise (PretypeError (env, sigma,WrongAbstractionType (na,a,p,l))) + +let error_abstraction_over_meta env sigma hdmeta metaarg = + let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in + raise (PretypeError (env, sigma,AbstractionOverMeta (m,n))) + +let error_non_linear_unification env sigma hdmeta t = + let m = Evd.meta_name sigma hdmeta in + raise (PretypeError (env, sigma,NonLinearUnification (m,t))) + +(*s Ml Case errors *) + +let error_cant_find_case_type ?loc env sigma expr = + raise_pretype_error ?loc (env, sigma, CantFindCaseType expr) + +(*s Pretyping errors *) + +let error_unexpected_type ?loc env sigma actty expty = + raise_pretype_error ?loc (env, sigma, UnexpectedType (actty, expty)) + +let error_not_product ?loc env sigma c = + raise_pretype_error ?loc (env, sigma, NotProduct c) + +(*s Error in conversion from AST to glob_constr *) + +let error_var_not_found ?loc env sigma s = + raise_pretype_error ?loc (env, sigma, VarNotFound s) + +let error_evar_not_found ?loc env sigma id = + raise_pretype_error ?loc (env, sigma, EvarNotFound id) + +let error_disallowed_sprop env sigma = + raise (PretypeError (env, sigma, DisallowedSProp)) + +(*s Typeclass errors *) + +let unsatisfiable_constraints env evd ev comp = + match ev with + | None -> + let err = UnsatisfiableConstraints (None, comp) in + raise (PretypeError (env,evd,err)) + | Some ev -> + let loc, kind = Evd.evar_source ev evd in + let err = UnsatisfiableConstraints (Some (ev, kind), comp) in + Loc.raise ?loc (PretypeError (env,evd,err)) + +let unsatisfiable_exception exn = + match exn with + | PretypeError (_, _, UnsatisfiableConstraints _) -> true + | _ -> false diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli new file mode 100644 index 0000000000..a9e2b0ea8f --- /dev/null +++ b/pretyping/pretype_errors.mli @@ -0,0 +1,170 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Environ +open EConstr +open Type_errors + +(** {6 The type of errors raised by the pretyper } *) + +type unification_error = + | OccurCheck of Evar.t * constr + | NotClean of existential * env * constr + | NotSameArgSize + | NotSameHead + | NoCanonicalStructure + | ConversionFailed of env * constr * constr + | MetaOccurInBody of Evar.t + | InstanceNotSameType of Evar.t * env * types * types + | UnifUnivInconsistency of Univ.univ_inconsistency + | CannotSolveConstraint of Evd.evar_constraint * unification_error + | ProblemBeyondCapabilities + +type position = (Id.t * Locus.hyp_location_flag) option + +type position_reporting = (position * int) * constr + +type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option + +type type_error = (constr, types) ptype_error + +type pretype_error = + | CantFindCaseType of constr + (** Old Case *) + + | ActualTypeNotCoercible of unsafe_judgment * types * unification_error + (** Type inference unification *) + + | UnifOccurCheck of Evar.t * constr + (** Tactic Unification *) + + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option + | CannotUnify of constr * constr * unification_error option + | CannotUnifyLocal of constr * constr * constr + | CannotUnifyBindingType of constr * constr + | CannotGeneralize of constr + | NoOccurrenceFound of constr * Id.t option + | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option + | WrongAbstractionType of Name.t * constr * types * types + | AbstractionOverMeta of Name.t * Name.t + | NonLinearUnification of Name.t * constr + (** Pretyping *) + | VarNotFound of Id.t + | EvarNotFound of Id.t + | UnexpectedType of constr * constr + | NotProduct of constr + | TypingError of type_error + | CannotUnifyOccurrences of subterm_unification_error + | UnsatisfiableConstraints of + (Evar.t * Evar_kinds.t) option * Evar.Set.t option + (** unresolvable evar, connex component *) + | DisallowedSProp + +exception PretypeError of env * Evd.evar_map * pretype_error + +val precatchable_exception : exn -> bool + +(** Raising errors *) +val error_actual_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> + unification_error -> 'b + +val error_actual_type_core : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b + +val error_cant_apply_not_functional : + ?loc:Loc.t -> env -> Evd.evar_map -> + unsafe_judgment -> unsafe_judgment array -> 'b + +val error_cant_apply_bad_type : + ?loc:Loc.t -> env -> Evd.evar_map -> int * constr * constr -> + unsafe_judgment -> unsafe_judgment array -> 'b + +val error_case_not_inductive : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b + +val error_ill_formed_branch : + ?loc:Loc.t -> env -> Evd.evar_map -> + constr -> pconstructor -> constr -> constr -> 'b + +val error_number_branches : + ?loc:Loc.t -> env -> Evd.evar_map -> + unsafe_judgment -> int -> 'b + +val error_ill_typed_rec_body : + ?loc:Loc.t -> env -> Evd.evar_map -> + int -> Name.t Context.binder_annot array -> unsafe_judgment array -> types array -> 'b + +val error_elim_arity : + ?loc:Loc.t -> env -> Evd.evar_map -> + pinductive -> constr -> + unsafe_judgment -> (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'b + +val error_not_a_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b + +val error_assumption : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b + +val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b + +(** {6 Implicit arguments synthesis errors } *) + +val error_occur_check : env -> Evd.evar_map -> Evar.t -> constr -> 'b + +val error_unsolvable_implicit : + ?loc:Loc.t -> env -> Evd.evar_map -> Evar.t -> + Evd.unsolvability_explanation option -> 'b + +val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> + ?reason:unification_error -> constr * constr -> 'b + +val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b + +val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> + constr -> constr list -> (env * type_error) option -> 'b + +val error_wrong_abstraction_type : env -> Evd.evar_map -> + Name.t -> constr -> types -> types -> 'b + +val error_abstraction_over_meta : env -> Evd.evar_map -> + metavariable -> metavariable -> 'b + +val error_non_linear_unification : env -> Evd.evar_map -> + metavariable -> constr -> 'b + +(** {6 Ml Case errors } *) + +val error_cant_find_case_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b + +(** {6 Pretyping errors } *) + +val error_unexpected_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b + +val error_not_product : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b + +val error_var_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b + +val error_evar_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b + +val error_disallowed_sprop : env -> Evd.evar_map -> 'a + +(** {6 Typeclass errors } *) + +val unsatisfiable_constraints : env -> Evd.evar_map -> Evar.t option -> + Evar.Set.t option -> 'a + +val unsatisfiable_exception : exn -> bool + diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml new file mode 100644 index 0000000000..48d981082c --- /dev/null +++ b/pretyping/pretyping.ml @@ -0,0 +1,1182 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file contains the syntax-directed part of the type inference + algorithm introduced by Murthy in Coq V5.10, 1995; the type + inference algorithm was initially developed in a file named trad.ml + which formerly contained a simple concrete-to-abstract syntax + translation function introduced in CoC V4.10 for implementing the + "exact" tactic, 1989 *) +(* Support for typing term in Ltac environment by David Delahaye, 2000 *) +(* Type inference algorithm made a functor of the coercion and + pattern-matching compilation by Matthieu Sozeau, March 2006 *) +(* Fixpoint guard index computation by Pierre Letouzey, July 2007 *) + +(* Structural maintainer: Hugo Herbelin *) +(* Secondary maintenance: collective *) + + +open Pp +open CErrors +open Util +open Names +open Evd +open Constr +open Context +open Termops +open Environ +open EConstr +open Vars +open Reductionops +open Type_errors +open Typing +open Globnames +open Evarutil +open Evardefine +open Pretype_errors +open Glob_term +open Glob_ops +open GlobEnv +open Evarconv + +module NamedDecl = Context.Named.Declaration + +type typing_constraint = OfType of types | IsType | WithoutTypeConstraint + +let (!!) env = GlobEnv.env env + +(************************************************************************) +(* This concerns Cases *) +open Inductive +open Inductiveops + +(************************************************************************) + +(* An auxiliary function for searching for fixpoint guard indexes *) + +exception Found of int array + +let nf_fix sigma (nas, cs, ts) = + let inj c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in + (nas, Array.map inj cs, Array.map inj ts) + +let search_guard ?loc env possible_indexes fixdefs = + (* Standard situation with only one possibility for each fix. *) + (* We treat it separately in order to get proper error msg. *) + let is_singleton = function [_] -> true | _ -> false in + if List.for_all is_singleton possible_indexes then + let indexes = Array.of_list (List.map List.hd possible_indexes) in + let fix = ((indexes, 0),fixdefs) in + (try check_fix env fix + with reraise -> + let (e, info) = CErrors.push reraise in + let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in + iraise (e, info)); + indexes + else + (* we now search recursively among all combinations *) + (try + List.iter + (fun l -> + let indexes = Array.of_list l in + let fix = ((indexes, 0),fixdefs) in + (* spiwack: We search for a unspecified structural + argument under the assumption that we need to check the + guardedness condition (otherwise the first inductive argument + will be chosen). A more robust solution may be to raise an + error when totality is assumed but the strutural argument is + not specified. *) + try + let flags = { (typing_flags env) with Declarations.check_guarded = true } in + let env = Environ.set_typing_flags flags env in + check_fix env fix; raise (Found indexes) + with TypeError _ -> ()) + (List.combinations possible_indexes); + let errmsg = "Cannot guess decreasing argument of fix." in + user_err ?loc ~hdr:"search_guard" (Pp.str errmsg) + with Found indexes -> indexes) + +let esearch_guard ?loc env sigma indexes fix = + let fix = nf_fix sigma fix in + try search_guard ?loc env indexes fix + with TypeError (env,err) -> + raise (PretypeError (env,sigma,TypingError (map_ptype_error of_constr err))) + +(* To force universe name declaration before use *) + +let is_strict_universe_declarations = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"strict universe declaration" + ~key:["Strict";"Universe";"Declaration"] + ~value:true + +(** Miscellaneous interpretation functions *) + +let interp_known_universe_level evd qid = + try + let open Libnames in + if qualid_is_ident qid then Evd.universe_of_name evd @@ qualid_basename qid + else raise Not_found + with Not_found -> + let qid = Nametab.locate_universe qid in + Univ.Level.make qid + +let interp_universe_level_name ~anon_rigidity evd qid = + try evd, interp_known_universe_level evd qid + with Not_found -> + if Libnames.qualid_is_ident qid then (* Undeclared *) + let id = Libnames.qualid_basename qid in + if not (is_strict_universe_declarations ()) then + new_univ_level_variable ?loc:qid.CAst.loc ~name:id univ_rigid evd + else user_err ?loc:qid.CAst.loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared universe: " ++ Id.print id)) + else + let dp, i = Libnames.repr_qualid qid in + let num = + try int_of_string (Id.to_string i) + with Failure _ -> + user_err ?loc:qid.CAst.loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared global universe: " ++ Libnames.pr_qualid qid)) + in + let level = Univ.Level.(make (UGlobal.make dp num)) in + let evd = + try Evd.add_global_univ evd level + with UGraph.AlreadyDeclared -> evd + in evd, level + +let interp_universe ?loc evd = function + | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in + evd, Univ.Universe.make l + | l -> + List.fold_left (fun (evd, u) l -> + let evd', u' = + match l with + | Some (l,n) -> + (* [univ_flexible_alg] can produce algebraic universes in terms *) + let anon_rigidity = univ_flexible in + let evd', l = interp_universe_level_name ~anon_rigidity evd l in + let u' = Univ.Universe.make l in + (match n with + | 0 -> evd', u' + | 1 -> evd', Univ.Universe.super u' + | _ -> + user_err ?loc ~hdr:"interp_universe" + (Pp.(str "Cannot interpret universe increment +" ++ int n))) + | None -> + let evd, l = new_univ_level_variable ?loc univ_flexible evd in + evd, Univ.Universe.make l + in (evd', Univ.sup u u')) + (evd, Univ.Universe.type0m) l + +let interp_known_level_info ?loc evd = function + | UUnknown | UAnonymous -> + user_err ?loc ~hdr:"interp_known_level_info" + (str "Anonymous universes not allowed here.") + | UNamed qid -> + try interp_known_universe_level evd qid + with Not_found -> + user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_qualid qid) + +let interp_level_info ?loc evd : level_info -> _ = function + | UUnknown -> new_univ_level_variable ?loc univ_rigid evd + | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd + | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s + +type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr + +type inference_flags = { + use_typeclasses : bool; + solve_unification_constraints : bool; + fail_evar : bool; + expand_evars : bool; + program_mode : bool; + polymorphic : bool; +} + +(* Compute the set of still-undefined initial evars up to restriction + (e.g. clearing) and the set of yet-unsolved evars freshly created + in the extension [sigma'] of [sigma] (excluding the restrictions of + the undefined evars of [sigma] to be freshly created evars of + [sigma']). Otherwise said, we partition the undefined evars of + [sigma'] into those already in [sigma] or deriving from an evar in + [sigma] by restriction, and the evars properly created in [sigma'] *) + +type frozen = +| FrozenId of evar_info Evar.Map.t + (** No pending evars. We do not put a set here not to reallocate like crazy, + but the actual data of the map is not used, only keys matter. All + functions operating on this type must have the same behaviour on + [FrozenId map] and [FrozenProgress (Evar.Map.domain map, Evar.Set.empty)] *) +| FrozenProgress of (Evar.Set.t * Evar.Set.t) Lazy.t + (** Proper partition of the evar map as described above. *) + +let frozen_and_pending_holes (sigma, sigma') = + let undefined0 = Option.cata Evd.undefined_map Evar.Map.empty sigma in + (* Fast path when the undefined evars where not modified *) + if undefined0 == Evd.undefined_map sigma' then + FrozenId undefined0 + else + let data = lazy begin + let add_derivative_of evk evi acc = + match advance sigma' evk with None -> acc | Some evk' -> Evar.Set.add evk' acc in + let frozen = Evar.Map.fold add_derivative_of undefined0 Evar.Set.empty in + let fold evk _ accu = if not (Evar.Set.mem evk frozen) then Evar.Set.add evk accu else accu in + let pending = Evd.fold_undefined fold sigma' Evar.Set.empty in + (frozen, pending) + end in + FrozenProgress data + +let apply_typeclasses ~program_mode env sigma frozen fail_evar = + let filter_frozen = match frozen with + | FrozenId map -> fun evk -> Evar.Map.mem evk map + | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen + in + let sigma = Typeclasses.resolve_typeclasses + ~filter:(if program_mode + then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) + else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) + ~split:true ~fail:fail_evar env sigma in + let sigma = if program_mode then (* Try optionally solving the obligations *) + Typeclasses.resolve_typeclasses + ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env sigma + else sigma in + sigma + +let apply_inference_hook hook env sigma frozen = match frozen with +| FrozenId _ -> sigma +| FrozenProgress (lazy (_, pending)) -> + Evar.Set.fold (fun evk sigma -> + if Evd.is_undefined sigma evk (* in particular not defined by side-effect *) + then + try + let sigma, c = hook env sigma evk in + Evd.define evk c sigma + with Exit -> + sigma + else + sigma) pending sigma + +let apply_heuristics env sigma fail_evar = + (* Resolve eagerly, potentially making wrong choices *) + let flags = default_flags_of (Typeclasses.classes_transparent_state ()) in + try solve_unif_constraints_with_heuristics ~flags env sigma + with e when CErrors.noncritical e -> + let e = CErrors.push e in + if fail_evar then iraise e else sigma + +let check_typeclasses_instances_are_solved ~program_mode env current_sigma frozen = + (* Naive way, call resolution again with failure flag *) + apply_typeclasses ~program_mode env current_sigma frozen true + +let check_extra_evars_are_solved env current_sigma frozen = match frozen with +| FrozenId _ -> () +| FrozenProgress (lazy (_, pending)) -> + Evar.Set.iter + (fun evk -> + if not (Evd.is_defined current_sigma evk) then + let (loc,k) = evar_source evk current_sigma in + match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> + error_unsolvable_implicit ?loc env current_sigma evk None) pending + +(* [check_evars] fails if some unresolved evar remains *) + +let check_evars env initial_sigma sigma c = + let rec proc_rec c = + match EConstr.kind sigma c with + | Evar (evk, _) -> + if not (Evd.mem initial_sigma evk) then + let (loc,k) = evar_source evk sigma in + begin match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None + end + | _ -> EConstr.iter sigma proc_rec c + in proc_rec c + +let check_evars_are_solved ~program_mode env sigma frozen = + let sigma = check_typeclasses_instances_are_solved ~program_mode env sigma frozen in + check_problems_are_solved env sigma; + check_extra_evars_are_solved env sigma frozen + +(* Try typeclasses, hooks, unification heuristics ... *) + +let solve_remaining_evars ?hook flags env ?initial sigma = + let program_mode = flags.program_mode in + let frozen = frozen_and_pending_holes (initial, sigma) in + let sigma = + if flags.use_typeclasses + then apply_typeclasses ~program_mode env sigma frozen false + else sigma + in + let sigma = match hook with + | None -> sigma + | Some hook -> apply_inference_hook hook env sigma frozen + in + let sigma = if flags.solve_unification_constraints + then apply_heuristics env sigma false + else sigma + in + if flags.fail_evar then check_evars_are_solved ~program_mode env sigma frozen; + sigma + +let check_evars_are_solved ~program_mode env ?initial current_sigma = + let frozen = frozen_and_pending_holes (initial, current_sigma) in + check_evars_are_solved ~program_mode env current_sigma frozen + +let process_inference_flags flags env initial (sigma,c,cty) = + let sigma = solve_remaining_evars flags env ~initial sigma in + let c = if flags.expand_evars then nf_evar sigma c else c in + sigma,c,cty + +let adjust_evar_source sigma na c = + match na, kind sigma c with + | Name id, Evar (evk,args) -> + let evi = Evd.find sigma evk in + begin match evi.evar_source with + | loc, Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=b; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=recfieldname; + } -> + let src = (loc,Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=b; + Evar_kinds.qm_name=na; + Evar_kinds.qm_record_field=recfieldname; + }) in + let (sigma, evk') = restrict_evar sigma evk (evar_filter evi) ~src None in + sigma, mkEvar (evk',args) + | _ -> sigma, c + end + | _, _ -> sigma, c + +(* coerce to tycon if any *) +let inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j = function + | None -> sigma, j + | Some t -> + Coercion.inh_conv_coerce_to ?loc ~program_mode resolve_tc !!env sigma j t + +let check_instance loc subst = function + | [] -> () + | (id,_) :: _ -> + if List.mem_assoc id subst then + user_err ?loc (Id.print id ++ str "appears more than once.") + else + user_err ?loc (str "No such variable in the signature of the existential variable: " ++ Id.print id ++ str ".") + +(* used to enforce a name in Lambda when the type constraints itself + is named, hence possibly dependent *) + +let orelse_name name name' = match name with + | Anonymous -> name' + | _ -> name + +let pretype_id pretype k0 loc env sigma id = + (* Look for the binder of [id] *) + try + let (n,_,typ) = lookup_rel_id id (rel_context !!env) in + sigma, { uj_val = mkRel n; uj_type = lift n typ } + with Not_found -> + try + GlobEnv.interp_ltac_variable ?loc (fun env -> pretype env sigma) env sigma id + with Not_found -> + (* Check if [id] is a section or goal variable *) + try + sigma, { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id !!env) } + with Not_found -> + (* [id] not found, standard error message *) + error_var_not_found ?loc !!env sigma id + +(*************************************************************************) +(* Main pretyping function *) + +let interp_known_glob_level ?loc evd = function + | GSProp -> Univ.Level.sprop + | GProp -> Univ.Level.prop + | GSet -> Univ.Level.set + | GType s -> interp_known_level_info ?loc evd s + +let interp_glob_level ?loc evd : glob_level -> _ = function + | GSProp -> evd, Univ.Level.sprop + | GProp -> evd, Univ.Level.prop + | GSet -> evd, Univ.Level.set + | GType s -> interp_level_info ?loc evd s + +let interp_instance ?loc evd l = + let evd, l' = + List.fold_left + (fun (evd, univs) l -> + let evd, l = interp_glob_level ?loc evd l in + (evd, l :: univs)) (evd, []) + l + in + if List.exists (fun l -> Univ.Level.is_prop l) l' then + user_err ?loc ~hdr:"pretype" + (str "Universe instances cannot contain Prop, polymorphic" ++ + str " universe instances must be greater or equal to Set."); + evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) + +let pretype_global ?loc rigid env evd gr us = + let evd, instance = + match us with + | None -> evd, None + | Some l -> interp_instance ?loc evd l + in + Evd.fresh_global ?loc ~rigid ?names:instance !!env evd gr + +let pretype_ref ?loc sigma env ref us = + match ref with + | VarRef id -> + (* Section variable *) + (try sigma, make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) + with Not_found -> + (* This may happen if env is a goal env and section variables have + been cleared - section variables should be different from goal + variables *) + Pretype_errors.error_var_not_found ?loc !!env sigma id) + | ref -> + let sigma, c = pretype_global ?loc univ_flexible env sigma ref us in + let ty = unsafe_type_of !!env sigma c in + sigma, make_judge c ty + +let judge_of_Type ?loc evd s = + let evd, s = interp_universe ?loc evd s in + let judge = + { uj_val = mkType s; uj_type = mkType (Univ.super s) } + in + evd, judge + +let pretype_sort ?loc sigma = function + | GSProp -> sigma, judge_of_sprop + | GProp -> sigma, judge_of_prop + | GSet -> sigma, judge_of_set + | GType s -> judge_of_Type ?loc sigma s + +let new_type_evar env sigma loc = + new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) + +let mark_obligation_evar sigma k evc = + match k with + | Evar_kinds.QuestionMark _ + | Evar_kinds.ImplicitArg (_, _, false) -> + Evd.set_obligation_evar sigma (fst (destEvar sigma evc)) + | _ -> sigma + +(* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) +(* in environment [env], with existential variables [sigma] and *) +(* the type constraint tycon *) + +let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = + let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in + let pretype = pretype ~program_mode ~poly k0 resolve_tc in + let open Context.Rel.Declaration in + let loc = t.CAst.loc in + match DAst.get t with + | GRef (ref,u) -> + let sigma, t_ref = pretype_ref ?loc sigma env ref u in + inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon + + | GVar id -> + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in + inh_conv_coerce_to_tycon ?loc env sigma t_id tycon + + | GEvar (id, inst) -> + (* 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 id = interp_ltac_id env id in + let evk = + try Evd.evar_key id sigma + with Not_found -> error_evar_not_found ?loc !!env sigma id in + let hyps = evar_filtered_context (Evd.find sigma evk) in + let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in + let c = mkEvar (evk, args) in + let j = Retyping.get_judgment_of !!env sigma c in + inh_conv_coerce_to_tycon ?loc env sigma j tycon + + | GPatVar kind -> + let sigma, ty = + match tycon with + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in + let k = Evar_kinds.MatchingVar kind in + let sigma, uj_val = new_evar env sigma ~src:(loc,k) ty in + sigma, { uj_val; uj_type = ty } + + | GHole (k, naming, None) -> + let open Namegen in + let naming = match naming with + | IntroIdentifier id -> IntroIdentifier (interp_ltac_id env id) + | IntroAnonymous -> IntroAnonymous + | IntroFresh id -> IntroFresh (interp_ltac_id env id) in + let sigma, ty = + match tycon with + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in + let sigma, uj_val = new_evar env sigma ~src:(loc,k) ~naming ty in + let sigma = if program_mode then mark_obligation_evar sigma k uj_val else sigma in + sigma, { uj_val; uj_type = ty } + + | GHole (k, _naming, Some arg) -> + let sigma, ty = + match tycon with + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in + let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in + sigma, { uj_val = c; uj_type = ty } + + | GRec (fixkind,names,bl,lar,vdef) -> + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let rec type_bl env sigma ctxt = function + | [] -> sigma, ctxt + | (na,bk,None,ty)::bl -> + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let rty' = Sorts.relevance_of_sort ty'.utj_type in + let dcl = LocalAssum (make_annot na rty', ty'.utj_val) in + let dcl', env = push_rel ~hypnaming sigma dcl env in + type_bl env sigma (Context.Rel.add dcl' ctxt) bl + | (na,bk,Some bd,ty)::bl -> + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let rty' = Sorts.relevance_of_sort ty'.utj_type in + let sigma, bd' = pretype (mk_tycon ty'.utj_val) env sigma bd in + let dcl = LocalDef (make_annot na rty', bd'.uj_val, ty'.utj_val) in + let dcl', env = push_rel ~hypnaming sigma dcl env in + type_bl env sigma (Context.Rel.add dcl' ctxt) bl in + let sigma, ctxtv = Array.fold_left_map (fun sigma -> type_bl env sigma Context.Rel.empty) sigma bl in + let sigma, larj = + Array.fold_left2_map + (fun sigma e ar -> + pretype_type empty_valcon (snd (push_rel_context ~hypnaming sigma e env)) sigma ar) + sigma 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 + let sigma = + match tycon with + | Some t -> + let fixi = match fixkind with + | GFix (vn,i) -> i + | GCoFix i -> i + in + begin match Evarconv.unify_delay !!env sigma ftys.(fixi) t with + | exception Evarconv.UnableToUnify _ -> sigma + | sigma -> sigma + end + | None -> sigma + in + let names = Array.map2 (fun na t -> + make_annot na (Retyping.relevance_of_type !!(env) sigma t)) + names ftys + in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let names,newenv = push_rec_types ~hypnaming sigma (names,ftys) env in + let sigma, vdefj = + Array.fold_left2_map_i + (fun i sigma 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 sigma (Context.Rel.length ctxt) + (lift nbfix ftys.(i)) in + let ctxt,nenv = push_rel_context ~hypnaming sigma ctxt newenv in + let sigma, j = pretype (mk_tycon ty) nenv sigma def in + sigma, { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + sigma ctxtv vdef in + let sigma = Typing.check_type_fixpoint ?loc !!env sigma names ftys vdefj in + let nf c = nf_evar sigma c in + let ftys = Array.map nf ftys in (* FIXME *) + let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in + let fixj = match fixkind with + | GFix (vn,i) -> + (* First, let's find the guard indexes. *) + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem worth the effort (except for huge mutual + fixpoints ?) *) + let possible_indexes = + Array.to_list (Array.mapi + (fun i annot -> match annot with + | Some n -> [n] + | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,fdefs) in + let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + | GCoFix i -> + let fixdecls = (names,ftys,fdefs) in + let cofix = (i, fixdecls) in + (try check_cofix !!env (i, nf_fix sigma fixdecls) + with reraise -> + let (e, info) = CErrors.push reraise in + let info = Option.cata (Loc.add_loc info) info loc in + iraise (e, info)); + make_judge (mkCoFix cofix) ftys.(i) + in + inh_conv_coerce_to_tycon ?loc env sigma fixj tycon + + | GSort s -> + let sigma, j = pretype_sort ?loc sigma s in + inh_conv_coerce_to_tycon ?loc env sigma j tycon + + | GApp (f,args) -> + let sigma, fj = pretype empty_tycon env sigma f in + let floc = loc_of_glob_constr f in + let length = List.length args in + let candargs = + (* Bidirectional typechecking hint: + parameters of a constructor are completely determined + by a typing constraint *) + if program_mode && length > 0 && isConstruct sigma fj.uj_val then + match tycon with + | None -> [] + | Some ty -> + let ((ind, i), u) = destConstruct sigma fj.uj_val in + let npars = inductive_nparams !!env ind in + if Int.equal npars 0 then [] + else + try + let IndType (indf, args) = find_rectype !!env sigma ty in + let ((ind',u'),pars) = dest_ind_family indf in + if eq_ind ind ind' then List.map EConstr.of_constr pars + else (* Let the usual code throw an error *) [] + with Not_found -> [] + else [] + in + let app_f = + match EConstr.kind sigma fj.uj_val with + | Const (p, u) when Recordops.is_primitive_projection p -> + let p = Option.get @@ Recordops.find_primitive_projection p in + let p = Projection.make p false in + let npars = Projection.npars p in + fun n -> + if n == npars + 1 then fun _ v -> mkProj (p, v) + else fun f v -> applist (f, [v]) + | _ -> fun _ f v -> applist (f, [v]) + in + let rec apply_rec env sigma n resj candargs = function + | [] -> sigma, resj + | c::rest -> + let argloc = loc_of_glob_constr c in + let sigma, resj = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in + let resty = whd_all !!env sigma resj.uj_type in + match EConstr.kind sigma resty with + | Prod (na,c1,c2) -> + let tycon = Some c1 in + let sigma, hj = pretype tycon env sigma c in + let sigma, candargs, ujval = + match candargs with + | [] -> sigma, [], j_val hj + | arg :: args -> + begin match Evarconv.unify_delay !!env sigma (j_val hj) arg with + | exception Evarconv.UnableToUnify _ -> + sigma, [], j_val hj + | sigma -> + sigma, args, nf_evar sigma (j_val hj) + end + in + let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in + let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in + let j = { uj_val = value; uj_type = typ } in + apply_rec env sigma (n+1) j candargs rest + | _ -> + let sigma, hj = pretype empty_tycon env sigma c in + error_cant_apply_not_functional + ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] + in + let sigma, resj = apply_rec env sigma 1 fj candargs args in + let sigma, resj = + match EConstr.kind sigma resj.uj_val with + | App (f,args) -> + if Termops.is_template_polymorphic_ind !!env sigma f then + (* Special case for inductive type applications that must be + refreshed right away. *) + let c = mkApp (f, args) in + let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in + let t = Retyping.get_type_of !!env sigma c in + sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t + else sigma, resj + | _ -> sigma, resj + in + inh_conv_coerce_to_tycon ?loc env sigma resj tycon + + | GLambda(name,bk,c1,c2) -> + let sigma, tycon' = + match tycon with + | None -> sigma, tycon + | Some ty -> + let sigma, ty' = Coercion.inh_coerce_to_prod ?loc ~program_mode !!env sigma ty in + sigma, Some ty' + in + let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in + let dom_valcon = valcon_of_tycon dom in + let sigma, j = pretype_type dom_valcon env sigma c1 in + let name = {binder_name=name; binder_relevance=Sorts.relevance_of_sort j.utj_type} in + let var = LocalAssum (name, j.utj_val) in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let var',env' = push_rel ~hypnaming sigma var env in + let sigma, j' = pretype rng env' sigma c2 in + let name = get_name var' in + let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in + inh_conv_coerce_to_tycon ?loc env sigma resj tycon + + | GProd(name,bk,c1,c2) -> + let sigma, j = pretype_type empty_valcon env sigma c1 in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let sigma, name, j' = match name with + | Anonymous -> + let sigma, j = pretype_type empty_valcon env sigma c2 in + sigma, name, { j with utj_val = lift 1 j.utj_val } + | Name _ -> + let r = Sorts.relevance_of_sort j.utj_type in + let var = LocalAssum (make_annot name r, j.utj_val) in + let var, env' = push_rel ~hypnaming sigma var env in + let sigma, c2_j = pretype_type empty_valcon env' sigma c2 in + sigma, get_name var, c2_j + in + let resj = + try + judge_of_product !!env name j j' + with TypeError _ as e -> + let (e, info) = CErrors.push e in + let info = Option.cata (Loc.add_loc info) info loc in + iraise (e, info) in + inh_conv_coerce_to_tycon ?loc env sigma resj tycon + + | GLetIn(name,c1,t,c2) -> + let sigma, tycon1 = + match t with + | Some t -> + let sigma, t_j = pretype_type empty_valcon env sigma t in + sigma, mk_tycon t_j.utj_val + | None -> + sigma, empty_tycon in + let sigma, j = pretype tycon1 env sigma c1 in + let sigma, t = Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma j.uj_type in + let r = Retyping.relevance_of_term !!env sigma j.uj_val in + let var = LocalDef (make_annot name r, j.uj_val, t) in + let tycon = lift_tycon 1 tycon in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let var, env = push_rel ~hypnaming sigma var env in + let sigma, j' = pretype tycon env sigma c2 in + let name = get_name var in + sigma, { uj_val = mkLetIn (make_annot name r, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } + + | GLetTuple (nal,(na,po),c,d) -> + let sigma, cj = pretype empty_tycon env sigma c in + let (IndType (indf,realargs)) = + try find_rectype !!env sigma cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive ?loc:cloc !!env sigma cj + in + let ind = fst (fst (dest_ind_family indf)) in + let cstrs = get_constructors !!env indf in + if not (Int.equal (Array.length cstrs) 1) then + user_err ?loc (str "Destructing let is only for inductive types" ++ + str " with one constructor."); + let cs = cstrs.(0) in + if not (Int.equal (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, record = + let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in + match Environ.get_projections !!env ind with + | None -> + List.map2 set_name (List.rev nal) cs.cs_args, false + | Some ps -> + let rec aux n k names l = + match names, l with + | na :: names, (LocalAssum (na', t) :: l) -> + let t = EConstr.of_constr t in + let proj = Projection.make ps.(cs.cs_nargs - k) true in + LocalDef ({na' with binder_name = na}, + lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) + :: aux (n+1) (k + 1) names l + | na :: names, (decl :: l) -> + set_name na decl :: aux (n+1) k names l + | [], [] -> [] + | _ -> assert false + in aux 1 1 (List.rev nal) cs.cs_args, true in + let fsign = Context.Rel.map (whd_betaiota sigma) fsign in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in + let obj ind rci p v f = + if not record then + let f = it_mkLambda_or_LetIn f fsign in + let ci = make_case_info !!env (fst ind) rci LetStyle in + mkCase (ci, p, cj.uj_val,[|f|]) + else it_mkLambda_or_LetIn f fsign + in + (* Make dependencies from arity signature impossible *) + let arsgn, indr = + let arsgn,s = get_arity !!env indf in + List.map (set_name Anonymous) arsgn, Sorts.relevance_of_sort_family s + in + let indt = build_dependent_inductive !!env indf in + let psign = LocalAssum (make_annot na indr, indt) :: arsgn in (* For locating names in [po] *) + let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in + let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in + let nar = List.length arsgn in + let psign',env_p = push_rel_context ~hypnaming ~force_names:true sigma psign predenv in + (match po with + | Some p -> + let sigma, pj = pretype_type empty_valcon env_p sigma p in + let ccl = nf_evar sigma pj.utj_val in + let p = it_mkLambda_or_LetIn ccl psign' in + let inst = + (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) + @[EConstr.of_constr (build_dependent_constructor cs)] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist !!env sigma lp inst in + let sigma, fj = pretype (mk_tycon fty) env_f sigma d in + let v = + let ind,_ = dest_ind_family indf in + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in + obj ind rci p cj.uj_val fj.uj_val + in + sigma, { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } + + | None -> + let tycon = lift_tycon cs.cs_nargs tycon in + let sigma, fj = pretype tycon env_f sigma d in + let ccl = nf_evar sigma fj.uj_type in + let ccl = + if noccur_between sigma 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type ?loc !!env sigma + cj.uj_val in + (* let ccl = refresh_universes ccl in *) + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in + let v = + let ind,_ = dest_ind_family indf in + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in + obj ind rci p cj.uj_val fj.uj_val + in sigma, { uj_val = v; uj_type = ccl }) + + | GIf (c,(na,po),b1,b2) -> + let sigma, cj = pretype empty_tycon env sigma c in + let (IndType (indf,realargs)) = + try find_rectype !!env sigma cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive ?loc:cloc !!env sigma cj in + let cstrs = get_constructors !!env indf in + if not (Int.equal (Array.length cstrs) 2) then + user_err ?loc + (str "If is only for inductive types with two constructors."); + + let arsgn, indr = + let arsgn,s = get_arity !!env indf in + (* Make dependencies from arity signature impossible *) + List.map (set_name Anonymous) arsgn, Sorts.relevance_of_sort_family s + in + let nar = List.length arsgn in + let indt = build_dependent_inductive !!env indf in + let psign = LocalAssum (make_annot na indr, indt) :: arsgn in (* For locating names in [po] *) + let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in + let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let psign,env_p = push_rel_context ~hypnaming sigma psign predenv in + let sigma, pred, p = match po with + | Some p -> + let sigma, pj = pretype_type empty_valcon env_p sigma p in + let ccl = nf_evar sigma pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in + sigma, pred, typ + | None -> + let sigma, p = match tycon with + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc + in + sigma, it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar sigma pred in + let p = nf_evar sigma p in + let f sigma cs b = + let n = Context.Rel.length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist sigma (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in + let cs_args = Context.Rel.map (whd_betaiota sigma) cs_args in + let csgn = + List.map (set_name Anonymous) cs_args + in + let _,env_c = push_rel_context ~hypnaming sigma csgn env in + let sigma, bj = pretype (mk_tycon pi) env_c sigma b in + sigma, it_mkLambda_or_LetIn bj.uj_val cs_args in + let sigma, b1 = f sigma cstrs.(0) b1 in + let sigma, b2 = f sigma cstrs.(1) b2 in + let v = + let ind,_ = dest_ind_family indf in + let pred = nf_evar sigma pred in + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in + let ci = make_case_info !!env (fst ind) rci IfStyle in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + let cj = { uj_val = v; uj_type = p } in + inh_conv_coerce_to_tycon ?loc env sigma cj tycon + + | GCases (sty,po,tml,eqns) -> + Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns) + + | GCast (c,k) -> + let sigma, cj = + match k with + | CastCoerce -> + let sigma, cj = pretype empty_tycon env sigma c in + Coercion.inh_coerce_to_base ?loc ~program_mode !!env sigma cj + | CastConv t | CastVM t | CastNative t -> + let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in + let sigma, tj = pretype_type empty_valcon env sigma t in + let sigma, tval = Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in + let tval = nf_evar sigma tval in + let (sigma, cj), tval = match k with + | VMcast -> + let sigma, cj = pretype empty_tycon env sigma c in + let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in + if not (occur_existential sigma cty || occur_existential sigma tval) then + match Reductionops.vm_infer_conv !!env sigma cty tval with + | Some sigma -> (sigma, cj), tval + | None -> + error_actual_type ?loc !!env sigma cj tval + (ConversionFailed (!!env,cty,tval)) + else user_err ?loc (str "Cannot check cast with vm: " ++ + str "unresolved arguments remain.") + | NATIVEcast -> + let sigma, cj = pretype empty_tycon env sigma c in + let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in + begin + match Nativenorm.native_infer_conv !!env sigma cty tval with + | Some sigma -> (sigma, cj), tval + | None -> + error_actual_type ?loc !!env sigma cj tval + (ConversionFailed (!!env,cty,tval)) + end + | _ -> + pretype (mk_tycon tval) env sigma c, tval + in + let v = mkCast (cj.uj_val, k, tval) in + sigma, { uj_val = v; uj_type = tval } + in inh_conv_coerce_to_tycon ?loc env sigma cj tycon + + | GInt i -> + let resj = + try Typing.judge_of_int !!env i + with Invalid_argument _ -> + user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") + in + inh_conv_coerce_to_tycon ?loc env sigma resj tycon + +and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = + let f decl (subst,update,sigma) = + let id = NamedDecl.get_id decl in + let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in + let t = replace_vars subst (NamedDecl.get_type decl) in + let check_body sigma id c = + match b, c with + | Some b, Some c -> + if not (is_conv !!env sigma b c) then + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + strbrk " in current context: binding for " ++ Id.print id ++ + strbrk " is not convertible to its expected definition (cannot unify " ++ + quote (Termops.Internal.print_constr_env !!env sigma b) ++ + strbrk " and " ++ + quote (Termops.Internal.print_constr_env !!env sigma c) ++ + str ").") + | Some b, None -> + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + strbrk " in current context: " ++ Id.print id ++ + strbrk " should be bound to a local definition.") + | None, _ -> () in + let check_type sigma id t' = + if not (is_conv !!env sigma t t') then + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + strbrk " in current context: binding for " ++ Id.print id ++ + strbrk " is not well-typed.") in + let sigma, c, update = + try + let c = List.assoc id update in + let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in + check_body sigma id (Some c.uj_val); + sigma, c.uj_val, List.remove_assoc id update + with Not_found -> + try + let (n,b',t') = lookup_rel_id id (rel_context !!env) in + check_type sigma id (lift n t'); + check_body sigma id (Option.map (lift n) b'); + sigma, mkRel n, update + with Not_found -> + try + let decl = lookup_named id !!env in + check_type sigma id (NamedDecl.get_type decl); + check_body sigma id (NamedDecl.get_value decl); + sigma, mkVar id, update + with Not_found -> + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + str " in current context: no binding for " ++ Id.print id ++ str ".") in + ((id,c)::subst, update, sigma) in + let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in + check_instance loc subst inst; + sigma, Array.map_of_list snd subst + +(* [pretype_type valcon env sigma c] coerces [c] into a type *) +and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with + | GHole (knd, naming, None) -> + let loc = loc_of_glob_constr c in + (match valcon with + | Some v -> + let sigma, s = + let t = Retyping.get_type_of !!env sigma v in + match EConstr.kind sigma (whd_all !!env sigma t) with + | Sort s -> + sigma, ESorts.kind sigma s + | Evar ev when is_Type sigma (existential_type sigma ev) -> + define_evar_as_sort !!env sigma ev + | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") + in + (* Correction of bug #5315 : we need to define an evar for *all* holes *) + let sigma, evkt = new_evar env sigma ~src:(loc, knd) ~naming (mkSort s) in + let ev,_ = destEvar sigma evkt in + let sigma = Evd.define ev (nf_evar sigma v) sigma in + (* End of correction of bug #5315 *) + sigma, { utj_val = v; + utj_type = s } + | None -> + let sigma, s = new_sort_variable univ_flexible_alg sigma in + let sigma, utj_val = new_evar env sigma ~src:(loc, knd) ~naming (mkSort s) in + let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in + sigma, { utj_val; utj_type = s}) + | _ -> + let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in + let loc = loc_of_glob_constr c in + let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in + match valcon with + | None -> sigma, tj + | Some v -> + begin match Evarconv.unify_leq_delay !!env sigma v tj.utj_val with + | sigma -> sigma, tj + | exception Evarconv.UnableToUnify _ -> + error_unexpected_type + ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v + end + +let ise_pretype_gen flags env sigma lvar kind c = + let program_mode = flags.program_mode in + let poly = flags.polymorphic in + let hypnaming = + if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames + in + let env = GlobEnv.make ~hypnaming env sigma lvar in + let k0 = Context.Rel.length (rel_context !!env) in + let sigma', c', c'_ty = match kind with + | WithoutTypeConstraint -> + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in + sigma, j.uj_val, j.uj_type + | OfType exptyp -> + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + sigma, j.uj_val, j.uj_type + | IsType -> + let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in + sigma, tj.utj_val, mkSort tj.utj_type + in + process_inference_flags flags !!env sigma (sigma',c',c'_ty) + +let default_inference_flags fail = { + use_typeclasses = true; + solve_unification_constraints = true; + fail_evar = fail; + expand_evars = true; + program_mode = false; + polymorphic = false; +} + +let no_classes_no_fail_inference_flags = { + use_typeclasses = false; + solve_unification_constraints = true; + fail_evar = false; + expand_evars = true; + program_mode = false; + polymorphic = false; +} + +let all_and_fail_flags = default_inference_flags true +let all_no_fail_flags = default_inference_flags false + +let ise_pretype_gen_ctx flags env sigma lvar kind c = + let sigma, c, _ = ise_pretype_gen flags env sigma lvar kind c in + c, Evd.evar_universe_context sigma + +(** Entry points of the high-level type synthesis algorithm *) + +let understand + ?(flags=all_and_fail_flags) + ?(expected_type=WithoutTypeConstraint) + env sigma c = + ise_pretype_gen_ctx flags env sigma empty_lvar expected_type c + +let understand_tcc_ty ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutTypeConstraint) c = + ise_pretype_gen flags env sigma empty_lvar expected_type c + +let understand_tcc ?flags env sigma ?expected_type c = + let sigma, c, _ = understand_tcc_ty ?flags env sigma ?expected_type c in + sigma, c + +let understand_ltac flags env sigma lvar kind c = + let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in + (sigma, c) + +let path_convertible env sigma p q = + let open Classops in + let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in + let mkGVar id = DAst.make @@ Glob_term.GVar(id) in + let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in + let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Decl_kinds.Explicit,t,b) in + let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in + let path_to_gterm p = + match p with + | ic :: p' -> + let names = + List.map (fun n -> Id.of_string ("x" ^ string_of_int n)) + (List.interval 0 ic.coe_param) + in + List.fold_right + (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ + List.fold_left + (fun t ic -> + mkGApp (mkGRef ic.coe_value, + List.make ic.coe_param (mkGHole ()) @ [t])) + (mkGApp (mkGRef ic.coe_value, List.map (fun i -> mkGVar i) names)) + p' + | [] -> anomaly (str "A coercion path shouldn't be empty.") + in + try + let sigma,tp = understand_tcc env sigma (path_to_gterm p) in + let sigma,tq = understand_tcc env sigma (path_to_gterm q) in + if Evd.has_undefined sigma then + false + else + let _ = Evarconv.unify_delay env sigma tp tq in true + with Evarconv.UnableToUnify _ | PretypeError _ -> false + +let _ = Classops.install_path_comparator path_convertible diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli new file mode 100644 index 0000000000..1037cf6cc5 --- /dev/null +++ b/pretyping/pretyping.mli @@ -0,0 +1,116 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This file implements type inference. It maps [glob_constr] + (i.e. untyped terms whose names are located) to [constr]. In + particular, it drives complex pattern-matching problems ("match") + into elementary ones, insertion of coercions and resolution of + implicit arguments. *) + +open Environ +open Evd +open EConstr +open Glob_term +open Ltac_pretype + +val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> + glob_level -> Univ.Level.t + +(** An auxiliary function for searching for fixpoint guard indexes *) + +val search_guard : + ?loc:Loc.t -> env -> int list list -> Constr.rec_declaration -> int array + +type typing_constraint = OfType of types | IsType | WithoutTypeConstraint + +type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr + +type inference_flags = { + use_typeclasses : bool; + solve_unification_constraints : bool; + fail_evar : bool; + expand_evars : bool; + program_mode : bool; + polymorphic : bool; +} + +val default_inference_flags : bool -> inference_flags + +val no_classes_no_fail_inference_flags : inference_flags + +val all_no_fail_flags : inference_flags + +val all_and_fail_flags : inference_flags + +(** Generic calls to the interpreter from glob_constr to open_constr; + by default, inference_flags tell to use type classes and + heuristics (but no external tactic solver hooks), as well as to + ensure that conversion problems are all solved and expand evars, + but unresolved evars can remain. The difference is in whether the + evar_map is modified explicitly or by side-effect. *) + +val understand_tcc : ?flags:inference_flags -> env -> evar_map -> + ?expected_type:typing_constraint -> glob_constr -> evar_map * constr + +(** As [understand_tcc] but also returns the type of the elaborated term. + The [expand_evars] flag is not applied to the type (only to the term). *) +val understand_tcc_ty : ?flags:inference_flags -> env -> evar_map -> + ?expected_type:typing_constraint -> glob_constr -> evar_map * constr * types + +(** More general entry point with evars from ltac *) + +(** Generic call to the interpreter from glob_constr to constr + + In [understand_ltac flags sigma env ltac_env constraint c], + + flags: tell how to manage evars + sigma: initial set of existential variables (typically current goals) + ltac_env: partial substitution of variables (used for the tactic language) + constraint: tell if interpreted as a possibly constrained term or a type +*) + +val understand_ltac : inference_flags -> + env -> evar_map -> ltac_var_map -> + typing_constraint -> glob_constr -> evar_map * EConstr.t + +(** Standard call to get a constr from a glob_constr, resolving + implicit arguments and coercions, and compiling pattern-matching; + the default inference_flags tells to use type classes and + heuristics (but no external tactic solver hook), as well as to + ensure that conversion problems are all solved and that no + unresolved evar remains, expanding evars. *) +val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> + env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context + +(** Trying to solve remaining evars and remaining conversion problems + possibly using type classes, heuristics, external tactic solver + hook depending on given flags. *) +(* For simplicity, it is assumed that current map has no other evars + with candidate and no other conversion problems that the one in + [pending], however, it can contain more evars than the pending ones. *) + +val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> + env -> ?initial:evar_map -> (* current map *) evar_map -> evar_map + +(** Checking evars and pending conversion problems are all solved, + reporting an appropriate error message *) + +val check_evars_are_solved : + program_mode:bool -> env -> ?initial:evar_map -> (* current map: *) evar_map -> unit + +(** [check_evars env initial_sigma extended_sigma c] fails if some + new unresolved evar remains in [c] *) +val check_evars : env -> evar_map -> evar_map -> constr -> unit + +(**/**) +(** Internal of Pretyping... *) +val ise_pretype_gen : + inference_flags -> env -> evar_map -> + ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr * types diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib new file mode 100644 index 0000000000..34a6cecc95 --- /dev/null +++ b/pretyping/pretyping.mllib @@ -0,0 +1,38 @@ +Geninterp +Locus +Locusops +Pretype_errors +Reductionops +Inductiveops +InferCumulativity +Arguments_renaming +Retyping +Vnorm +Nativenorm +Cbv +Find_subterm +Evardefine +Evarsolve +Recordops +Heads +Evarconv +Typing +Miscops +Glob_term +Ltac_pretype +Glob_ops +Pattern +Patternops +Constr_matching +Tacred +Typeclasses_errors +Typeclasses +Classops +Program +Coercion +Detyping +Indrec +GlobEnv +Cases +Pretyping +Unification diff --git a/pretyping/program.ml b/pretyping/program.ml new file mode 100644 index 0000000000..7e38c09189 --- /dev/null +++ b/pretyping/program.ml @@ -0,0 +1,100 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Util + +let papp evdref r args = + let open EConstr in + let gr = delayed_force r in + let evd, hd = Evarutil.new_global !evdref gr in + evdref := evd; + mkApp (hd, args) + +let sig_typ () = Coqlib.lib_ref "core.sig.type" +let sig_intro () = Coqlib.lib_ref "core.sig.intro" +let sig_proj1 () = Coqlib.lib_ref "core.sig.proj1" +(* let sig_proj2 () = Coqlib.lib_ref "core.sig.proj2" *) + +let sigT_typ () = Coqlib.lib_ref "core.sigT.type" +let sigT_intro () = Coqlib.lib_ref "core.sigT.intro" +let sigT_proj1 () = Coqlib.lib_ref "core.sigT.proj1" +let sigT_proj2 () = Coqlib.lib_ref "core.sigT.proj2" + +let prod_typ () = Coqlib.lib_ref "core.prod.type" +let prod_intro () = Coqlib.lib_ref "core.prod.intro" +let prod_proj1 () = Coqlib.lib_ref "core.prod.proj1" +let prod_proj2 () = Coqlib.lib_ref "core.prod.proj2" + +let coq_eq_ind () = Coqlib.lib_ref "core.eq.type" +let coq_eq_refl () = Coqlib.lib_ref "core.eq.refl" +let coq_eq_refl_ref () = Coqlib.lib_ref "core.eq.refl" +let coq_eq_rect () = Coqlib.lib_ref "core.eq.rect" + +let mk_coq_not sigma x = + let sigma, notc = Evarutil.new_global sigma Coqlib.(lib_ref "core.not.type") in + sigma, EConstr.mkApp (notc, [| x |]) + +let coq_JMeq_ind () = + try Coqlib.lib_ref "core.JMeq.type" + with Not_found -> + user_err (Pp.str "cannot find Coq.Logic.JMeq.JMeq; maybe library Coq.Logic.JMeq has to be required first.") +let coq_JMeq_refl () = Coqlib.lib_ref "core.JMeq.refl" + +(* let coq_not () = Universes.constr_of_global @@ Coqlib.lib_ref "core.not.type" *) +(* let coq_and () = Universes.constr_of_global @@ Coqlib.lib_ref "core.and.type" *) + +let unsafe_fold_right f = function + hd :: tl -> List.fold_right f tl hd + | [] -> invalid_arg "unsafe_fold_right" + +let mk_coq_and sigma l = + let sigma, and_typ = Evarutil.new_global sigma Coqlib.(lib_ref "core.and.type") in + sigma, unsafe_fold_right + (fun c conj -> + EConstr.(mkApp (and_typ, [| c ; conj |]))) + l + +(* true = transparent by default, false = opaque if possible *) +let proofs_transparency = ref true +let program_cases = ref true +let program_generalized_coercion = ref true + +let set_proofs_transparency = (:=) proofs_transparency +let get_proofs_transparency () = !proofs_transparency + +let is_program_generalized_coercion () = !program_generalized_coercion +let is_program_cases () = !program_cases + +open Goptions + +let () = + declare_bool_option + { optdepr = false; + optname = "preferred transparency of Program obligations"; + optkey = ["Transparent";"Obligations"]; + optread = get_proofs_transparency; + optwrite = set_proofs_transparency; } + +let () = + declare_bool_option + { optdepr = false; + optname = "program cases"; + optkey = ["Program";"Cases"]; + optread = (fun () -> !program_cases); + optwrite = (:=) program_cases } + +let () = + declare_bool_option + { optdepr = false; + optname = "program generalized coercion"; + optkey = ["Program";"Generalized";"Coercion"]; + optread = (fun () -> !program_generalized_coercion); + optwrite = (:=) program_generalized_coercion } diff --git a/pretyping/program.mli b/pretyping/program.mli new file mode 100644 index 0000000000..a8f5115788 --- /dev/null +++ b/pretyping/program.mli @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr + +(** A bunch of Coq constants used by Progam *) + +val sig_typ : unit -> GlobRef.t +val sig_intro : unit -> GlobRef.t +val sig_proj1 : unit -> GlobRef.t +val sigT_typ : unit -> GlobRef.t +val sigT_intro : unit -> GlobRef.t +val sigT_proj1 : unit -> GlobRef.t +val sigT_proj2 : unit -> GlobRef.t + +val prod_typ : unit -> GlobRef.t +val prod_intro : unit -> GlobRef.t +val prod_proj1 : unit -> GlobRef.t +val prod_proj2 : unit -> GlobRef.t + +val coq_eq_ind : unit -> GlobRef.t +val coq_eq_refl : unit -> GlobRef.t +val coq_eq_refl_ref : unit -> GlobRef.t +val coq_eq_rect : unit -> GlobRef.t + +val coq_JMeq_ind : unit -> GlobRef.t +val coq_JMeq_refl : unit -> GlobRef.t + +val mk_coq_and : Evd.evar_map -> constr list -> Evd.evar_map * constr +val mk_coq_not : Evd.evar_map -> constr -> Evd.evar_map * constr + +(** Polymorphic application of delayed references *) +val papp : Evd.evar_map ref -> (unit -> GlobRef.t) -> constr array -> constr + +val get_proofs_transparency : unit -> bool +val is_program_cases : unit -> bool +val is_program_generalized_coercion : unit -> bool diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml new file mode 100644 index 0000000000..1feb8acd5f --- /dev/null +++ b/pretyping/recordops.ml @@ -0,0 +1,329 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Created by Amokrane Saïbi, Dec 1998 *) +(* Addition of products and sorts in canonical structures by Pierre + Corbineau, Feb 2008 *) + +(* This file registers properties of records: projections and + canonical structures *) + +open CErrors +open Util +open Pp +open Names +open Globnames +open Constr +open Mod_subst +open Reductionops + +(*s A structure S is a non recursive inductive type with a single + constructor (the name of which defaults to Build_S) *) + +(* Table des structures: le nom de la structure (un [inductive]) donne + le nom du constructeur, le nombre de paramètres et pour chaque + argument réel du constructeur, le nom de la projection + correspondante, si valide, et un booléen disant si c'est une vraie + projection ou bien une fonction constante (associée à un LetIn) *) + +type struc_typ = { + s_CONST : constructor; + s_EXPECTEDPARAM : int; + s_PROJKIND : (Name.t * bool) list; + s_PROJ : Constant.t option list } + +let structure_table = + Summary.ref (Indmap.empty : struc_typ Indmap.t) ~name:"record-structs" +let projection_table = + Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" + +(* TODO: could be unify struc_typ and struc_tuple ? *) + +type struc_tuple = + constructor * (Name.t * bool) list * Constant.t option list + +let register_structure env (id,kl,projs) = + let open Declarations in + let ind = fst id in + let mib, mip = Inductive.lookup_mind_specif env ind in + let n = mib.mind_nparams in + let struc = + { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in + structure_table := Indmap.add ind struc !structure_table; + projection_table := + List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc)) + projs !projection_table + +let subst_structure subst (id, kl, projs as obj) = + let projs' = + (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) + (* the first component of subst_con. *) + List.Smart.map + (Option.Smart.map (subst_constant subst)) + projs + in + let id' = subst_constructor subst id in + if projs' == projs && id' == id then obj else + (id',kl,projs') + +let lookup_structure indsp = Indmap.find indsp !structure_table + +let lookup_projections indsp = (lookup_structure indsp).s_PROJ + +let find_projection_nparams = function + | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM + | _ -> raise Not_found + +let find_projection = function + | ConstRef cst -> Cmap.find cst !projection_table + | _ -> raise Not_found + +let is_projection cst = Cmap.mem cst !projection_table + +let prim_table = + Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" + +let register_primitive_projection p c = + prim_table := Cmap_env.add c p !prim_table + +let is_primitive_projection c = Cmap_env.mem c !prim_table + +let find_primitive_projection c = + try Some (Cmap_env.find c !prim_table) with Not_found -> None + +(************************************************************************) +(*s A canonical structure declares "canonical" conversion hints between *) +(* the effective components of a structure and the projections of the *) +(* structure *) + +(* Table des definitions "object" : pour chaque object c, + + c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n) + + If ti has the form (ci ui1...uir) where ci is a global reference (or + a sort, or a product or a reference to a parameter) and if the + corresponding projection Li of the structure R is defined, one + declares a "conversion" between ci and Li. + + x1:B1..xk:Bk |- (Li a1..am (c x1..xk)) =_conv (ci ui1...uir) + + that maps the pair (Li,ci) to the following data + + o_DEF = c + o_TABS = B1...Bk + o_INJ = Some n (when ci is a reference to the parameter xi) + o_PARAMS = a1...am + o_NARAMS = m + o_TCOMP = ui1...uir + +*) + +type obj_typ = { + o_DEF : constr; + o_CTX : Univ.AUContext.t; + o_INJ : int option; (* position of trivial argument if any *) + o_TABS : constr list; (* ordered *) + o_TPARAMS : constr list; (* ordered *) + o_NPARAMS : int; + o_TCOMPS : constr list } (* ordered *) + +type cs_pattern = + Const_cs of GlobRef.t + | Prod_cs + | Sort_cs of Sorts.family + | Default_cs + +let eq_cs_pattern p1 p2 = match p1, p2 with +| Const_cs gr1, Const_cs gr2 -> GlobRef.equal gr1 gr2 +| Prod_cs, Prod_cs -> true +| Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2 +| Default_cs, Default_cs -> true +| _ -> false + +let rec assoc_pat a = function + | ((pat, t), e) :: xs -> if eq_cs_pattern pat a then (t, e) else assoc_pat a xs + | [] -> raise Not_found + + +let object_table = + Summary.ref (GlobRef.Map.empty : ((cs_pattern * constr) * obj_typ) list GlobRef.Map.t) + ~name:"record-canonical-structs" + +let canonical_projections () = + GlobRef.Map.fold (fun x -> List.fold_right (fun ((y,_),c) acc -> ((x,y),c)::acc)) + !object_table [] + +let keep_true_projections projs kinds = + let filter (p, (_, b)) = if b then Some p else None in + List.map_filter filter (List.combine projs kinds) + +let rec cs_pattern_of_constr env t = + match kind t with + | App (f,vargs) -> + let patt, n, args = cs_pattern_of_constr env f in + patt, n, args @ Array.to_list vargs + | Rel n -> Default_cs, Some n, [] + | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] + | Proj (p, c) -> + let { Environ.uj_type = ty } = Typeops.infer env c in + let _, params = Inductive.find_rectype env ty in + Const_cs (ConstRef (Projection.constant p)), None, params @ [c] + | Sort s -> Sort_cs (Sorts.family s), None, [] + | _ -> Const_cs (global_of_constr t) , None, [] + +let warn_projection_no_head_constant = + CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" + (fun (sign,env,t,con,proji_sp) -> + let env = Termops.push_rels_assum sign env in + let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) in + let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in + let term_pp = Termops.Internal.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in + strbrk "Projection value has no head constant: " + ++ term_pp ++ strbrk " in canonical instance " + ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") + +(* Intended to always succeed *) +let compute_canonical_projections env ~warn (con,ind) = + let ctx = Environ.constant_context env con in + let u = Univ.make_abstract_instance ctx in + let v = (mkConstU (con,u)) in + let c = Environ.constant_value_in env (con,u) in + let sign,t = Reductionops.splay_lam env (Evd.from_env env) (EConstr.of_constr c) in + let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in + let t = EConstr.Unsafe.to_constr t in + let lt = List.rev_map snd sign in + let args = snd (decompose_app t) in + let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = + lookup_structure ind in + let params, projs = List.chop p args in + let lpj = keep_true_projections lpj kl in + let lps = List.combine lpj projs in + let nenv = Termops.push_rels_assum sign env in + let comp = + List.fold_left + (fun l (spopt,t) -> (* comp=components *) + match spopt with + | Some proji_sp -> + begin + try + let patt, n , args = cs_pattern_of_constr nenv t in + ((ConstRef proji_sp, patt, t, n, args) :: l) + with Not_found -> + if warn then warn_projection_no_head_constant (sign,env,t,con,proji_sp); + l + end + | _ -> l) + [] lps in + List.map (fun (refi,c,t,inj,argj) -> + (refi,(c,t)), + {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; + o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) + comp + +let pr_cs_pattern = function + Const_cs c -> Nametab.pr_global_env Id.Set.empty c + | Prod_cs -> str "_ -> _" + | Default_cs -> str "_" + | Sort_cs s -> Sorts.pr_sort_family s + +let warn_redundant_canonical_projection = + CWarnings.create ~name:"redundant-canonical-projection" ~category:"typechecker" + (fun (hd_val,prj,new_can_s,old_can_s) -> + strbrk "Ignoring canonical projection to " ++ hd_val + ++ strbrk " by " ++ prj ++ strbrk " in " + ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s) + +let register_canonical_structure ~warn env sigma o = + compute_canonical_projections env ~warn o |> + List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> + let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in + match assoc_pat cs_pat l with + | exception Not_found -> + object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table + | _, cs -> + if warn + then + let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in + let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in + let prj = Nametab.pr_global_env Id.Set.empty proj in + let hd_val = pr_cs_pattern cs_pat in + warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) + ) + +let subst_canonical_structure subst (cst,ind as obj) = + (* invariant: cst is an evaluable reference. Thus we can take *) + (* the first component of subst_con. *) + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in + if cst' == cst && ind' == ind then obj else (cst',ind') + +(*s High-level declaration of a canonical structure *) + +let error_not_structure ref description = + user_err ~hdr:"object_declare" + (str"Could not declare a canonical structure " ++ + (Id.print (Nametab.basename_of_global ref) ++ str"." ++ spc() ++ + description)) + +let check_and_decompose_canonical_structure env sigma ref = + let sp = + match ref with + ConstRef sp -> sp + | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") + in + let u = Univ.make_abstract_instance (Environ.constant_context env sp) in + let vc = match Environ.constant_opt_value_in env (sp, u) with + | Some vc -> vc + | None -> error_not_structure ref (str "Could not find its value in the global environment.") in + let body = snd (splay_lam env sigma (EConstr.of_constr vc)) in + let body = EConstr.Unsafe.to_constr body in + let f,args = match kind body with + | App (f,args) -> f,args + | _ -> + error_not_structure ref (str "Expected a record or structure constructor applied to arguments.") in + let indsp = match kind f with + | Construct ((indsp,1),u) -> indsp + | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in + let s = + try lookup_structure indsp + with Not_found -> + error_not_structure ref + (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in + let ntrue_projs = List.count snd s.s_PROJKIND in + if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then + error_not_structure ref (str "Got too few arguments to the record or structure constructor."); + (sp,indsp) + +let lookup_canonical_conversion (proj,pat) = + assoc_pat pat (GlobRef.Map.find proj !object_table) + +let decompose_projection sigma c args = + match EConstr.kind sigma c with + | Const (c, u) -> + let n = find_projection_nparams (ConstRef c) in + (* Check if there is some canonical projection attached to this structure *) + let _ = GlobRef.Map.find (ConstRef c) !object_table in + let arg = Stack.nth args n in + arg + | Proj (p, c) -> + let _ = GlobRef.Map.find (ConstRef (Projection.constant p)) !object_table in + c + | _ -> raise Not_found + +let is_open_canonical_projection env sigma (c,args) = + let open EConstr in + try + let arg = decompose_projection sigma c args in + try + let arg = whd_all env sigma arg in + let hd = match EConstr.kind sigma arg with App (hd, _) -> hd | _ -> arg in + not (isConstruct sigma hd) + with Failure _ -> false + with Not_found -> false diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli new file mode 100644 index 0000000000..f0594d513a --- /dev/null +++ b/pretyping/recordops.mli @@ -0,0 +1,92 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr + +(** Operations concerning records and canonical structures *) + +(** {6 Records } *) +(** A structure S is a non recursive inductive type with a single + constructor (the name of which defaults to Build_S) *) + +type struc_typ = { + s_CONST : constructor; + s_EXPECTEDPARAM : int; + s_PROJKIND : (Name.t * bool) list; + s_PROJ : Constant.t option list } + +type struc_tuple = + constructor * (Name.t * bool) list * Constant.t option list + +val register_structure : Environ.env -> struc_tuple -> unit +val subst_structure : Mod_subst.substitution -> struc_tuple -> struc_tuple + +(** [lookup_structure isp] returns the struc_typ associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val lookup_structure : inductive -> struc_typ + +(** [lookup_projections isp] returns the projections associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val lookup_projections : inductive -> Constant.t option list + +(** raise [Not_found] if not a projection *) +val find_projection_nparams : GlobRef.t -> int + +(** raise [Not_found] if not a projection *) +val find_projection : GlobRef.t -> struc_typ + +val is_projection : Constant.t -> bool + +(** Sets up the mapping from constants to primitive projections *) +val register_primitive_projection : Projection.Repr.t -> Constant.t -> unit + +val is_primitive_projection : Constant.t -> bool + +val find_primitive_projection : Constant.t -> Projection.Repr.t option + +(** {6 Canonical structures } *) +(** A canonical structure declares "canonical" conversion hints between + the effective components of a structure and the projections of the + structure *) + +(** A cs_pattern characterizes the form of a component of canonical structure *) +type cs_pattern = + Const_cs of GlobRef.t + | Prod_cs + | Sort_cs of Sorts.family + | Default_cs + +type obj_typ = { + o_DEF : constr; + o_CTX : Univ.AUContext.t; + o_INJ : int option; (** position of trivial argument *) + o_TABS : constr list; (** ordered *) + o_TPARAMS : constr list; (** ordered *) + o_NPARAMS : int; + o_TCOMPS : constr list } (** ordered *) + +(** Return the form of the component of a canonical structure *) +val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * constr list + +val pr_cs_pattern : cs_pattern -> Pp.t + +val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ +val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> + Constant.t * inductive -> unit +val subst_canonical_structure : Mod_subst.substitution -> Constant.t * inductive -> Constant.t * inductive +val is_open_canonical_projection : + Environ.env -> Evd.evar_map -> Reductionops.state -> bool +val canonical_projections : unit -> + ((GlobRef.t * cs_pattern) * obj_typ) list + +val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> Constant.t * inductive diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml new file mode 100644 index 0000000000..1871609e18 --- /dev/null +++ b/pretyping/reductionops.ml @@ -0,0 +1,1805 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Util +open Names +open Constr +open Context +open Termops +open Univ +open Evd +open Environ +open EConstr +open Vars +open Context.Rel.Declaration + +exception Elimconst + +(** This module implements a call by name reduction used by (at + least) evarconv unification and cbn tactic. + + It has an ability to "refold" constants by storing constants and + their parameters in its stack. +*) + +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Generate weak constraints between Irrelevant universes"; + optkey = ["Cumulativity";"Weak";"Constraints"]; + optread = (fun () -> not !UState.drop_weak_constraints); + optwrite = (fun a -> UState.drop_weak_constraints:=not a); +}) + + +(** Support for reduction effects *) + +open Mod_subst +open Libobject + +type effect_name = string + +(** create a persistent set to store effect functions *) + +(* Table bindings a constant to an effect *) +let constant_effect_table = Summary.ref ~name:"reduction-side-effect" Cmap.empty + +(* Table bindings function key to effective functions *) +let effect_table = ref String.Map.empty + +(** a test to know whether a constant is actually the effect function *) +let reduction_effect_hook env sigma con c = + try + let funkey = Cmap.find con !constant_effect_table in + let effect = String.Map.find funkey !effect_table in + effect env sigma (Lazy.force c) + with Not_found -> () + +let cache_reduction_effect (_,(con,funkey)) = + constant_effect_table := Cmap.add con funkey !constant_effect_table + +let subst_reduction_effect (subst,(con,funkey)) = + (subst_constant subst con,funkey) + +let inReductionEffect : Constant.t * string -> obj = + declare_object @@ global_object_nodischarge "REDUCTION-EFFECT" + ~cache:cache_reduction_effect + ~subst:(Some subst_reduction_effect) + +let declare_reduction_effect funkey f = + if String.Map.mem funkey !effect_table then + CErrors.anomaly Pp.(str "Cannot redeclare effect function " ++ qstring funkey ++ str "."); + effect_table := String.Map.add funkey f !effect_table + +(** A function to set the value of the print function *) +let set_reduction_effect x funkey = + Lib.add_anonymous_leaf (inReductionEffect (x,funkey)) + + +(** Machinery to custom the behavior of the reduction *) +module ReductionBehaviour = struct + open Globnames + open Names + open Libobject + + type t = { + b_nargs: int; + b_recargs: int list; + b_dont_expose_case: bool; + } + + let table = + Summary.ref (GlobRef.Map.empty : t GlobRef.Map.t) ~name:"reductionbehaviour" + + type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] + type req = + | ReqLocal + | ReqGlobal of GlobRef.t * (int list * int * flag list) + + let load _ (_,(_,(r, b))) = + table := GlobRef.Map.add r b !table + + let cache o = load 1 o + + let classify = function + | ReqLocal, _ -> Dispose + | ReqGlobal _, _ as o -> Substitute o + + let subst (subst, (_, (r,o as orig))) = + ReqLocal, + let r' = fst (subst_global subst r) in if r==r' then orig else (r',o) + + let discharge = function + | _,(ReqGlobal (ConstRef c as gr, req), (_, b)) -> + let b = + if Lib.is_in_section gr then + let vars = Lib.variable_section_segment_of_reference gr in + let extra = List.length vars in + let nargs' = + if b.b_nargs = max_int then max_int + else if b.b_nargs < 0 then b.b_nargs + else b.b_nargs + extra in + let recargs' = List.map ((+) extra) b.b_recargs in + { b with b_nargs = nargs'; b_recargs = recargs' } + else b + in + Some (ReqGlobal (gr, req), (ConstRef c, b)) + | _ -> None + + let rebuild = function + | req, (ConstRef c, _ as x) -> req, x + | _ -> assert false + + let inRedBehaviour = declare_object { + (default_object "REDUCTIONBEHAVIOUR") with + load_function = load; + cache_function = cache; + classify_function = classify; + subst_function = subst; + discharge_function = discharge; + rebuild_function = rebuild; + } + + let set local r (recargs, nargs, flags as req) = + let nargs = if List.mem `ReductionNeverUnfold flags then max_int else nargs in + let behaviour = { + b_nargs = nargs; b_recargs = recargs; + b_dont_expose_case = List.mem `ReductionDontExposeCase flags } in + let req = if local then ReqLocal else ReqGlobal (r, req) in + Lib.add_anonymous_leaf (inRedBehaviour (req, (r, behaviour))) + ;; + + let get r = + try + let b = GlobRef.Map.find r !table in + let flags = + if Int.equal b.b_nargs max_int then [`ReductionNeverUnfold] + else if b.b_dont_expose_case then [`ReductionDontExposeCase] else [] in + Some (b.b_recargs, (if Int.equal b.b_nargs max_int then -1 else b.b_nargs), flags) + with Not_found -> None + + let print ref = + let open Pp in + let pr_global = Nametab.pr_global_env Id.Set.empty in + match get ref with + | None -> mt () + | Some (recargs, nargs, flags) -> + let never = List.mem `ReductionNeverUnfold flags in + let nomatch = List.mem `ReductionDontExposeCase flags in + let pp_nomatch = spc() ++ if nomatch then + str "but avoid exposing match constructs" else str"" in + let pp_recargs = spc() ++ str "when the " ++ + pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++ + str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ + str " to a constructor" in + let pp_nargs = + spc() ++ str "when applied to " ++ int nargs ++ + str (String.plural nargs " argument") in + hov 2 (str "The reduction tactics " ++ + match recargs, nargs, never with + | _,_, true -> str "never unfold " ++ pr_global ref + | [], 0, _ -> str "always unfold " ++ pr_global ref + | _::_, n, _ when n < 0 -> + str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch + | _::_, n, _ when n > List.fold_left max 0 recargs -> + str "unfold " ++ pr_global ref ++ pp_recargs ++ + str " and" ++ pp_nargs ++ pp_nomatch + | _::_, _, _ -> + str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch + | [], n, _ when n > 0 -> + str "unfold " ++ pr_global ref ++ pp_nargs ++ pp_nomatch + | _ -> str "unfold " ++ pr_global ref ++ pp_nomatch ) +end + +(** Machinery about stack of unfolded constants *) +module Cst_stack = struct + open EConstr + +(** constant * params * args + +- constant applied to params = term in head applied to args +- there is at most one arguments with an empty list of args, it must be the first. +- in args, the int represents the indice of the first arg to consider *) + type t = (constr * constr list * (int * constr array) list) list + + let empty = [] + let is_empty = CList.is_empty + + let drop_useless = function + | _ :: ((_,_,[])::_ as q) -> q + | l -> l + + let add_param h cst_l = + let append2cst = function + | (c,params,[]) -> (c, h::params, []) + | (c,params,((i,t)::q)) when i = pred (Array.length t) -> + (c, params, q) + | (c,params,(i,t)::q) -> + (c, params, (succ i,t)::q) + in + drop_useless (List.map append2cst cst_l) + + let add_args cl = + List.map (fun (a,b,args) -> (a,b,(0,cl)::args)) + + let add_cst cst = function + | (_,_,[]) :: q as l -> l + | l -> (cst,[],[])::l + + let best_cst = function + | (cst,params,[])::_ -> Some(cst,params) + | _ -> None + + let reference sigma t = match best_cst t with + | Some (c, _) when isConst sigma c -> Some (fst (destConst sigma c)) + | _ -> None + + (** [best_replace d cst_l c] makes the best replacement for [d] + by [cst_l] in [c] *) + let best_replace sigma d cst_l c = + let reconstruct_head = List.fold_left + (fun t (i,args) -> mkApp (t,Array.sub args i (Array.length args - i))) in + List.fold_right + (fun (cst,params,args) t -> Termops.replace_term sigma + (reconstruct_head d args) + (applist (cst, List.rev params)) + t) cst_l c + + let pr env sigma l = + let open Pp in + let p_c c = Termops.Internal.print_constr_env env sigma c in + prlist_with_sep pr_semicolon + (fun (c,params,args) -> + hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++ + pr_sequence (fun (i,el) -> prvect_with_sep spc p_c (Array.sub el i (Array.length el - i))) args ++ + str ")")) l +end + + +(** The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +module Stack : +sig + open EConstr + type 'a app_node + val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + + type cst_member = + | Cst_const of pconstant + | Cst_proj of Projection.t + + type 'a member = + | App of 'a app_node + | Case of case_info * 'a * 'a array * Cst_stack.t + | Proj of Projection.t * Cst_stack.t + | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t + | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t + | Cst of cst_member * int * int list * 'a t * Cst_stack.t + + and 'a t = 'a member list + + exception IncompatibleFold2 + + val pr : ('a -> Pp.t) -> 'a t -> Pp.t + val empty : 'a t + val is_empty : 'a t -> bool + val append_app : 'a array -> 'a t -> 'a t + val decomp : 'a t -> ('a * 'a t) option + val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t) + val equal : ('a -> 'a -> bool) -> (('a, 'a) pfixpoint -> ('a, 'a) pfixpoint -> bool) + -> 'a t -> 'a t -> bool + val compare_shape : 'a t -> 'a t -> bool + val map : ('a -> 'a) -> 'a t -> 'a t + val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> + constr t -> constr t -> 'a + val append_app_list : 'a list -> 'a t -> 'a t + val strip_app : 'a t -> 'a t * 'a t + val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option + val not_purely_applicative : 'a t -> bool + val will_expose_iota : 'a t -> bool + val list_of_app_stack : constr t -> constr list option + val assign : 'a t -> int -> 'a -> 'a t + val args_size : 'a t -> int + val tail : int -> 'a t -> 'a t + val nth : 'a t -> int -> 'a + val best_state : evar_map -> constr * constr t -> Cst_stack.t -> constr * constr t + val zip : ?refold:bool -> evar_map -> constr * constr t -> constr + val check_native_args : CPrimitives.t -> 'a t -> bool + val get_next_primitive_args : CPrimitives.args_red -> 'a t -> CPrimitives.args_red * ('a t * 'a * 'a t) option +end = +struct + open EConstr + type 'a app_node = int * 'a array * int + (* first releavnt position, arguments, last relevant position *) + + (* + Invariant that this module must ensure : + (behare of direct access to app_node by the rest of Reductionops) + - in app_node (i,_,j) i <= j + - There is no array realocation (outside of debug printing) + *) + + let pr_app_node pr (i,a,j) = + let open Pp in surround ( + prvect_with_sep pr_comma pr (Array.sub a i (j - i + 1)) + ) + + + type cst_member = + | Cst_const of pconstant + | Cst_proj of Projection.t + + type 'a member = + | App of 'a app_node + | Case of case_info * 'a * 'a array * Cst_stack.t + | Proj of Projection.t * Cst_stack.t + | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t + | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t + | Cst of cst_member * int * int list * 'a t * Cst_stack.t + + and 'a t = 'a member list + + (* Debugging printer *) + let rec pr_member pr_c member = + let open Pp in + let pr_c x = hov 1 (pr_c x) in + match member with + | App app -> str "ZApp" ++ pr_app_node pr_c app + | Case (_,_,br,cst) -> + str "ZCase(" ++ + prvect_with_sep (pr_bar) pr_c br + ++ str ")" + | Proj (p,cst) -> + str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" + | Fix (f,args,cst) -> + str "ZFix(" ++ Constr.debug_print_fix pr_c f + ++ pr_comma () ++ pr pr_c args ++ str ")" + | Primitive (p,c,args,kargs,cst_l) -> + str "ZPrimitive(" ++ str (CPrimitives.to_string p) + ++ pr_comma () ++ pr pr_c args ++ str ")" + | Cst (mem,curr,remains,params,cst_l) -> + str "ZCst(" ++ pr_cst_member pr_c mem ++ pr_comma () ++ int curr + ++ pr_comma () ++ + prlist_with_sep pr_semicolon int remains ++ + pr_comma () ++ pr pr_c params ++ str ")" + and pr pr_c l = + let open Pp in + prlist_with_sep pr_semicolon (fun x -> hov 1 (pr_member pr_c x)) l + + and pr_cst_member pr_c c = + let open Pp in + match c with + | Cst_const (c, u) -> + if Univ.Instance.is_empty u then Constant.debug_print c + else str"(" ++ Constant.debug_print c ++ str ", " ++ + Univ.Instance.pr Univ.Level.pr u ++ str")" + | Cst_proj p -> + str".(" ++ Constant.debug_print (Projection.constant p) ++ str")" + + let empty = [] + let is_empty = CList.is_empty + + let append_app v s = + let le = Array.length v in + if Int.equal le 0 then s else App (0,v,pred le) :: s + + let decomp_node (i,l,j) sk = + if i < j then (l.(i), App (succ i,l,j) :: sk) + else (l.(i), sk) + + let decomp = function + | App node::s -> Some (decomp_node node s) + | _ -> None + + let decomp_node_last (i,l,j) sk = + if i < j then (l.(j), App (i,l,pred j) :: sk) + else (l.(j), sk) + + let equal f f_fix sk1 sk2 = + let equal_cst_member x y = + match x, y with + | Cst_const (c1,u1), Cst_const (c2, u2) -> + Constant.equal c1 c2 && Univ.Instance.equal u1 u2 + | Cst_proj p1, Cst_proj p2 -> Projection.repr_equal p1 p2 + | _, _ -> false + in + let rec equal_rec sk1 sk2 = + match sk1,sk2 with + | [],[] -> true + | App a1 :: s1, App a2 :: s2 -> + let t1,s1' = decomp_node_last a1 s1 in + let t2,s2' = decomp_node_last a2 s2 in + (f t1 t2) && (equal_rec s1' s2') + | Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 -> + f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 + | (Proj (p,_)::s1, Proj(p2,_)::s2) -> + Projection.Repr.equal (Projection.repr p) (Projection.repr p2) + && equal_rec s1 s2 + | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' -> + f_fix f1 f2 + && equal_rec (List.rev s1) (List.rev s2) + && equal_rec s1' s2' + | Cst (c1,curr1,remains1,params1,_)::s1', Cst (c2,curr2,remains2,params2,_)::s2' -> + equal_cst_member c1 c2 + && equal_rec (List.rev params1) (List.rev params2) + && equal_rec s1' s2' + | ((App _|Case _|Proj _|Fix _|Cst _|Primitive _)::_|[]), _ -> false + in equal_rec (List.rev sk1) (List.rev sk2) + + let compare_shape stk1 stk2 = + let rec compare_rec bal stk1 stk2 = + match (stk1,stk2) with + ([],[]) -> Int.equal bal 0 + | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 + | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 + | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> + Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 + | (Proj (p,_)::s1, Proj(p2,_)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 + | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> + Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 + | (Primitive(_,_,a1,_,_)::s1, Primitive(_,_,a2,_,_)::s2) -> + Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 + | (Cst (_,_,_,p1,_)::s1, Cst (_,_,_,p2,_)::s2) -> + Int.equal bal 0 && compare_rec 0 p1 p2 && compare_rec 0 s1 s2 + | ((Case _|Proj _|Fix _|Cst _|Primitive _) :: _ | []) ,_ -> false in + compare_rec 0 stk1 stk2 + + exception IncompatibleFold2 + let fold2 f o sk1 sk2 = + let rec aux o sk1 sk2 = + match sk1,sk2 with + | [], [] -> o + | App n1 :: q1, App n2 :: q2 -> + let t1,l1 = decomp_node_last n1 q1 in + let t2,l2 = decomp_node_last n2 q2 in + aux (f o t1 t2) l1 l2 + | Case (_,t1,a1,_) :: q1, Case (_,t2,a2,_) :: q2 -> + aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 + | Proj (p1,_) :: q1, Proj (p2,_) :: q2 -> + aux o q1 q2 + | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> + let o' = aux (Array.fold_left2 f (Array.fold_left2 f o b1 b2) a1 a2) (List.rev s1) (List.rev s2) in + aux o' q1 q2 + | Cst (cst1,_,_,params1,_) :: q1, Cst (cst2,_,_,params2,_) :: q2 -> + let o' = aux o (List.rev params1) (List.rev params2) in + aux o' q1 q2 + | (((App _|Case _|Proj _|Fix _|Cst _|Primitive _) :: _|[]), _) -> + raise IncompatibleFold2 + in aux o (List.rev sk1) (List.rev sk2) + + let rec map f x = List.map (function + | (Proj (_,_)) as e -> e + | App (i,a,j) -> + let le = j - i + 1 in + App (0,Array.map f (Array.sub a i le), le-1) + | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt) + | Fix ((r,(na,ty,bo)),arg,alt) -> + Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) + | Cst (cst,curr,remains,params,alt) -> + Cst (cst,curr,remains,map f params,alt) + | Primitive (p,c,args,kargs,cst_l) -> + Primitive(p,c, map f args, kargs, cst_l) + ) x + + let append_app_list l s = + let a = Array.of_list l in + append_app a s + + let rec args_size = function + | App (i,_,j)::s -> j + 1 - i + args_size s + | (Case _|Fix _|Proj _|Cst _|Primitive _)::_ | [] -> 0 + + let strip_app s = + let rec aux out = function + | ( App _ as e) :: s -> aux (e :: out) s + | s -> List.rev out,s + in aux [] s + let strip_n_app n s = + let rec aux n out = function + | App (i,a,j) as e :: s -> + let nb = j - i + 1 in + if n >= nb then + aux (n - nb) (e::out) s + else + let p = i+n in + Some (CList.rev + (if Int.equal n 0 then out else App (i,a,p-1) :: out), + a.(p), + if j > p then App(succ p,a,j)::s else s) + | s -> None + in aux n [] s + + let not_purely_applicative args = + List.exists (function (Fix _ | Case _ | Proj _ | Cst _) -> true + | App _ | Primitive _ -> false) args + let will_expose_iota args = + List.exists + (function (Fix (_,_,l) | Case (_,_,_,l) | + Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) + args + + let list_of_app_stack s = + let rec aux = function + | App (i,a,j) :: s -> + let (args',s') = aux s in + let a' = Array.sub a i (j - i + 1) in + (Array.fold_right (fun x y -> x::y) a' args', s') + | s -> ([],s) in + let (out,s') = aux s in + let init = match s' with [] -> true | _ -> false in + Option.init init out + + let assign s p c = + match strip_n_app p s with + | Some (pre,_,sk) -> pre @ (App (0,[|c|],0)::sk) + | None -> assert false + + let tail n0 s0 = + let rec aux n s = + if Int.equal n 0 then s else + match s with + | App (i,a,j) :: s -> + let nb = j - i + 1 in + if n >= nb then + aux (n - nb) s + else + let p = i+n in + if j >= p then App(p,a,j)::s else s + | _ -> raise (Invalid_argument "Reductionops.Stack.tail") + in aux n0 s0 + + let nth s p = + match strip_n_app p s with + | Some (_,el,_) -> el + | None -> raise Not_found + + (** This function breaks the abstraction of Cst_stack ! *) + let best_state sigma (_,sk as s) l = + let rec aux sk def = function + |(cst, params, []) -> (cst, append_app_list (List.rev params) sk) + |(cst, params, (i,t)::q) -> match decomp sk with + | Some (el,sk') when EConstr.eq_constr sigma el t.(i) -> + if i = pred (Array.length t) + then aux sk' def (cst, params, q) + else aux sk' def (cst, params, (succ i,t)::q) + | _ -> def + in List.fold_left (aux sk) s l + + let constr_of_cst_member f sk = + match f with + | Cst_const (c, u) -> mkConstU (c, EInstance.make u), sk + | Cst_proj p -> + match decomp sk with + | Some (hd, sk) -> mkProj (p, hd), sk + | None -> assert false + + let zip ?(refold=false) sigma s = + let rec zip = function + | f, [] -> f + | f, (App (i,a,j) :: s) -> + let a' = if Int.equal i 0 && Int.equal j (Array.length a - 1) + then a + else Array.sub a i (j - i + 1) in + zip (mkApp (f, a'), s) + | f, (Case (ci,rt,br,cst_l)::s) when refold -> + zip (best_state sigma (mkCase (ci,rt,f,br), s) cst_l) + | f, (Case (ci,rt,br,_)::s) -> zip (mkCase (ci,rt,f,br), s) + | f, (Fix (fix,st,cst_l)::s) when refold -> + zip (best_state sigma (mkFix fix, st @ (append_app [|f|] s)) cst_l) + | f, (Fix (fix,st,_)::s) -> zip + (mkFix fix, st @ (append_app [|f|] s)) + | f, (Cst (cst,_,_,params,cst_l)::s) when refold -> + zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) + | f, (Cst (cst,_,_,params,_)::s) -> + zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) + | f, (Proj (p,cst_l)::s) when refold -> + zip (best_state sigma (mkProj (p,f),s) cst_l) + | f, (Proj (p,_)::s) -> zip (mkProj (p,f),s) + | f, (Primitive (p,c,args,kargs,cst_l)::s) -> + zip (mkConstU c, args @ append_app [|f|] s) + in + zip s + + (* Check if there is enough arguments on [stk] w.r.t. arity of [op] *) + let check_native_args op stk = + let nargs = CPrimitives.arity op in + let rargs = args_size stk in + nargs <= rargs + + let get_next_primitive_args kargs stk = + let rec nargs = function + | [] -> 0 + | CPrimitives.Kwhnf :: _ -> 0 + | _ :: s -> 1 + nargs s + in + let n = nargs kargs in + (List.skipn (n+1) kargs, strip_n_app n stk) + +end + +(** The type of (machine) states (= lambda-bar-calculus' cuts) *) +type state = constr * constr Stack.t + +type contextual_reduction_function = env -> evar_map -> constr -> constr +type reduction_function = contextual_reduction_function +type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * 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 = + evar_map -> 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 = evar_map -> state -> state + +let pr_state env sigma (tm,sk) = + let open Pp in + let pr c = Termops.Internal.print_constr_env env sigma c in + h 0 (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) + +(*************************************) +(*** Reduction Functions Operators ***) +(*************************************) + +let safe_evar_value = Evarutil.safe_evar_value + +let safe_meta_value sigma ev = + try Some (Evd.meta_value sigma ev) + with Not_found -> None + +let strong_with_flags whdfun flags env sigma t = + let push_rel_check_zeta d env = + let open CClosure.RedFlags in + let d = match d with + | LocalDef (na,c,t) when not (red_set flags fZETA) -> LocalAssum (na,t) + | d -> d in + push_rel d env in + let rec strongrec env t = + map_constr_with_full_binders sigma + push_rel_check_zeta strongrec env (whdfun flags env sigma t) in + strongrec env t + +let strong whdfun env sigma t = + let rec strongrec env t = + map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in + strongrec env t + +let local_strong whdfun sigma = + let rec strongrec t = EConstr.map sigma strongrec (whdfun sigma t) in + strongrec + +let rec strong_prodspine redfun sigma c = + let x = redfun sigma c in + match EConstr.kind sigma x with + | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b) + | _ -> x + +(*************************************) +(*** Reduction using bindingss ***) +(*************************************) + +let eta = CClosure.RedFlags.mkflags [CClosure.RedFlags.fETA] + +(* Beta Reduction tools *) + +let apply_subst recfun env sigma refold cst_l t stack = + let rec aux env cst_l t stack = + match (Stack.decomp stack, EConstr.kind sigma t) with + | Some (h,stacktl), Lambda (_,_,c) -> + let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in + aux (h::env) cst_l' c stacktl + | _ -> recfun sigma cst_l (substl env t, stack) + in aux env cst_l t stack + +let stacklam recfun env sigma t stack = + apply_subst (fun _ _ s -> recfun s) env sigma false Cst_stack.empty t stack + +let beta_applist sigma (c,l) = + let zip s = Stack.zip sigma s in + stacklam zip [] sigma c (Stack.append_app_list l Stack.empty) + +(* 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 sigma c = match EConstr.kind sigma c with + | Construct _ | CoFix _ -> true + | _ -> false + +(** @return c if there is a constant c whose body is bd + @return bd else. + + It has only a meaning because internal representation of "Fixpoint f x + := t" is Definition f := fix f x => t + + Even more fragile that we could hope because do Module M. Fixpoint + f x := t. End M. Definition f := u. and say goodbye to any hope + of refolding M.f this way ... +*) +let magicaly_constant_of_fixbody env sigma reference bd = function + | Name.Anonymous -> bd + | Name.Name id -> + let open UnivProblem in + try + let (cst_mod,_) = Constant.repr2 reference in + let cst = Constant.make2 cst_mod (Label.of_id id) in + let (cst, u), ctx = UnivGen.fresh_constant_instance env cst in + match constant_opt_value_in env (cst,u) with + | None -> bd + | Some t -> + let csts = EConstr.eq_constr_universes env sigma (EConstr.of_constr t) bd in + begin match csts with + | Some csts -> + let subst = Set.fold (fun cst acc -> + let l, r = match cst with + | ULub (u, v) | UWeak (u, v) -> u, v + | UEq (u, v) | ULe (u, v) -> + let get u = Option.get (Universe.level u) in + get u, get v + in + Univ.LMap.add l r acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + mkConstU (cst, EInstance.make inst) + | None -> bd + end + with + | Not_found -> bd + +let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = + let nbodies = Array.length bodies in + let make_Fi j = + let ind = nbodies-j-1 in + if Int.equal bodynum ind then mkCoFix (ind,typedbodies) + else + let bd = mkCoFix (ind,typedbodies) in + match env with + | None -> bd + | Some e -> + match reference with + | None -> bd + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in + let closure = List.init nbodies make_Fi in + substl closure bodies.(bodynum) + +(** Similar to the "fix" case below *) +let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = + let raw_answer = + let env = if refold then Some env else None in + contract_cofix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in + apply_subst + (fun sigma x (t,sk') -> + let t' = + if refold then Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t else t in + recfun x (t',sk')) + [] sigma refold Cst_stack.empty raw_answer sk + +let reduce_mind_case sigma mia = + match EConstr.kind sigma mia.mconstr with + | Construct ((ind_sp,i),u) -> +(* 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 sigma 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 ?env sigma ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = + let nbodies = Array.length recindices in + let make_Fi j = + let ind = nbodies-j-1 in + if Int.equal bodynum ind then mkFix ((recindices,ind),typedbodies) + else + let bd = mkFix ((recindices,ind),typedbodies) in + match env with + | None -> bd + | Some e -> + match reference with + | None -> bd + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in + let closure = List.init nbodies make_Fi in + substl closure bodies.(bodynum) + +(** First we substitute the Rel bodynum by the fixpoint and then we try to + replace the fixpoint by the best constant from [cst_l] + Other rels are directly substituted by constants "magically found from the + context" in contract_fix *) +let reduce_and_refold_fix recfun env sigma refold cst_l fix sk = + let raw_answer = + let env = if refold then Some env else None in + contract_fix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in + apply_subst + (fun sigma x (t,sk') -> + let t' = + if refold then + Cst_stack.best_replace sigma (mkFix fix) cst_l t + else t + in recfun x (t',sk')) + [] sigma refold Cst_stack.empty raw_answer sk + +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 + +open Primred + +module CNativeEntries = +struct + + type elem = EConstr.t + type args = EConstr.t array + type evd = evar_map + + let get = Array.get + + let get_int evd e = + match EConstr.kind evd e with + | Int i -> i + | _ -> raise Primred.NativeDestKO + + let mkInt env i = + mkInt i + + let mkBool env b = + let (ct,cf) = get_bool_constructors env in + mkConstruct (if b then ct else cf) + + let mkCarry env b e = + let int_ty = mkConst @@ get_int_type env in + let (c0,c1) = get_carry_constructors env in + mkApp (mkConstruct (if b then c1 else c0),[|int_ty;e|]) + + let mkIntPair env e1 e2 = + let int_ty = mkConst @@ get_int_type env in + let c = get_pair_constructor env in + mkApp(mkConstruct c, [|int_ty;int_ty;e1;e2|]) + + let mkLt env = + let (_eq, lt, _gt) = get_cmp_constructors env in + mkConstruct lt + + let mkEq env = + let (eq, _lt, _gt) = get_cmp_constructors env in + mkConstruct eq + + let mkGt env = + let (_eq, _lt, gt) = get_cmp_constructors env in + mkConstruct gt + +end + +module CredNative = RedNative(CNativeEntries) + + + +(** Generic reduction function with environment + + Here is where unfolded constant are stored in order to be + eventualy refolded. + + If tactic_mode is true, it uses ReductionBehaviour, prefers + refold constant instead of value and tries to infer constants + fix and cofix came from. + + It substitutes fix and cofix by the constant they come from in + contract_* in any case . +*) + +let debug_RAKAM = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Print states of the Reductionops abstract machine"; + optkey = ["Debug";"RAKAM"]; + optread = (fun () -> !debug_RAKAM); + optwrite = (fun a -> debug_RAKAM:=a); +}) + +let equal_stacks sigma (x, l) (y, l') = + let f_equal x y = eq_constr sigma x y in + let eq_fix a b = f_equal (mkFix a) (mkFix b) in + Stack.equal f_equal eq_fix l l' && f_equal x y + +let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = + let open Context.Named.Declaration in + let rec whrec cst_l (x, stack) = + let () = if !debug_RAKAM then + let open Pp in + let pr c = Termops.Internal.print_constr_env env sigma c in + Feedback.msg_notice + (h 0 (str "<<" ++ pr x ++ + str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ + str "|" ++ cut () ++ Stack.pr pr stack ++ + str ">>")) + in + let c0 = EConstr.kind sigma x in + let fold () = + let () = if !debug_RAKAM then + let open Pp in Feedback.msg_notice (str "<><><><><>") in + ((EConstr.of_kind c0, stack),cst_l) + in + match c0 with + | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA -> + (match lookup_rel n env with + | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack) + | _ -> fold ()) + | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> + (match lookup_named id env with + | LocalDef (_,body,_) -> + whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) + | _ -> fold ()) + | Evar ev -> fold () + | Meta ev -> + (match safe_meta_value sigma ev with + | Some body -> whrec cst_l (body, stack) + | None -> fold ()) + | Const (c,u as const) -> + reduction_effect_hook env sigma c + (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); + if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then + let u' = EInstance.kind sigma u in + match constant_value_in env (c, u') with + | body -> + begin + let body = EConstr.of_constr body in + if not tactic_mode + then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) + (body, stack) + else (* Looks for ReductionBehaviour *) + match ReductionBehaviour.get (Globnames.ConstRef c) with + | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) + | Some (recargs, nargs, flags) -> + if (List.mem `ReductionNeverUnfold flags + || (nargs > 0 && Stack.args_size stack < nargs)) + then fold () + else (* maybe unfolds *) + if List.mem `ReductionDontExposeCase flags then + let app_sk,sk = Stack.strip_app stack in + let (tm',sk'),cst_l' = + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) + in + let rec is_case x = match EConstr.kind sigma x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if equal_stacks sigma (x, app_sk) (tm', sk') + || Stack.will_expose_iota sk' + || is_case tm' + then fold () + else whrec cst_l' (tm', sk' @ sk) + else match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) + whrec cst_l (body, stack) + |curr::remains -> match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') + end + | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> + let kargs = CPrimitives.kind p in + let (kargs,o) = Stack.get_next_primitive_args kargs stack in + (* Should not fail thanks to [check_native_args] *) + let (before,a,after) = Option.get o in + whrec Cst_stack.empty (a,Stack.Primitive(p,const,before,kargs,cst_l)::after) + | exception NotEvaluableConst _ -> fold () + else fold () + | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> + (let npars = Projection.npars p in + if not tactic_mode then + let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in + whrec Cst_stack.empty stack' + else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with + | None -> + let stack' = (c, Stack.Proj (p, cst_l) :: stack) in + let stack'', csts = whrec Cst_stack.empty stack' in + if equal_stacks sigma stack' stack'' then fold () + else stack'', csts + | Some (recargs, nargs, flags) -> + if (List.mem `ReductionNeverUnfold flags + || (nargs > 0 && Stack.args_size stack < (nargs - (npars + 1)))) + then fold () + else + let recargs = List.map_filter (fun x -> + let idx = x - npars in + if idx < 0 then None else Some idx) recargs + in + match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) + let stack' = (c, Stack.Proj (p, cst_l) :: stack) in + whrec Cst_stack.empty(* cst_l *) stack' + | curr::remains -> + if curr == 0 then (* Try to reduce the record argument *) + whrec Cst_stack.empty + (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) + else + match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, + Stack.append_app [|c|] bef,cst_l)::s')) + + | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> + apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack + | Cast (c,_,_) -> whrec cst_l (c, stack) + | App (f,cl) -> + whrec + (if refold then Cst_stack.add_args cl cst_l else cst_l) + (f, Stack.append_app cl stack) + | Lambda (na,t,c) -> + (match Stack.decomp stack with + | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> + apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack + | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> + let env' = push_rel (LocalAssum (na, t)) env in + let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in + (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with + | App (f,cl) -> + let napp = Array.length cl in + if napp > 0 then + let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in + match EConstr.kind sigma x', l' with + | Rel 1, [] -> + let lc = Array.sub cl 0 (napp-1) in + let u = if Int.equal napp 1 then f else mkApp (f,lc) in + if noccurn sigma 1 u then (pop u,Stack.empty),Cst_stack.empty else fold () + | _ -> fold () + else fold () + | _ -> fold ()) + | _ -> fold ()) + + | Case (ci,p,d,lf) -> + whrec Cst_stack.empty (d, Stack.Case (ci,p,lf,cst_l) :: stack) + + | Fix ((ri,n),_ as f) -> + (match Stack.strip_n_app ri.(n) stack with + |None -> fold () + |Some (bef,arg,s') -> + whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s')) + + | Construct ((ind,c),u) -> + let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in + let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in + if use_match || use_fix then + match Stack.strip_app stack with + |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> + whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Proj (p,_)::s') when use_match -> + whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') + |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> + let x' = Stack.zip sigma (x, args) in + let out_sk = s' @ (Stack.append_app [|x'|] s'') in + reduce_and_refold_fix whrec env sigma refold cst_l f out_sk + |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> + let x' = Stack.zip sigma (x, args) in + begin match remains with + | [] -> + (match const with + | Stack.Cst_const const -> + (match constant_opt_value_in env const with + | None -> fold () + | Some body -> + let const = (fst const, EInstance.make (snd const)) in + let body = EConstr.of_constr body in + whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) + (body, s' @ (Stack.append_app [|x'|] s''))) + | Stack.Cst_proj p -> + let stack = s' @ (Stack.append_app [|x'|] s'') in + match Stack.strip_n_app 0 stack with + | None -> assert false + | Some (_,arg,s'') -> + whrec Cst_stack.empty (arg, Stack.Proj (p,cst_l) :: s'')) + | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with + | None -> fold () + | Some (bef,arg,s''') -> + whrec Cst_stack.empty + (arg, + Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''') + end + |_, (Stack.App _)::_ -> assert false + |_, _ -> fold () + else fold () + + | CoFix cofix -> + if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then + match Stack.strip_app stack with + |args, ((Stack.Case _ |Stack.Proj _)::s') -> + reduce_and_refold_cofix whrec env sigma refold cst_l cofix stack + |_ -> fold () + else fold () + + | Int i -> + begin match Stack.strip_app stack with + | (_, Stack.Primitive(p,kn,rargs,kargs,cst_l')::s) -> + let more_to_reduce = List.exists (fun k -> CPrimitives.Kwhnf = k) kargs in + if more_to_reduce then + let (kargs,o) = Stack.get_next_primitive_args kargs s in + (* Should not fail because Primitive is put on the stack only if fully applied *) + let (before,a,after) = Option.get o in + whrec Cst_stack.empty (a,Stack.Primitive(p,kn,rargs @ Stack.append_app [|x|] before,kargs,cst_l')::after) + else + let n = List.length kargs in + let (args,s) = Stack.strip_app s in + let (args,extra_args) = + try List.chop n args + with List.IndexOutOfRange -> (args,[]) (* FIXME probably useless *) + in + let args = Array.of_list (Option.get (Stack.list_of_app_stack (rargs @ Stack.append_app [|x|] args))) in + begin match CredNative.red_prim env sigma p args with + | Some t -> whrec cst_l' (t,s) + | None -> ((mkApp (mkConstU kn, args), s), cst_l) + end + | _ -> fold () + end + + | Rel _ | Var _ | LetIn _ | Proj _ -> fold () + | Sort _ | Ind _ | Prod _ -> fold () + in + fun xs -> + let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in + if tactic_mode then (Stack.best_state sigma s cst_l,Cst_stack.empty) else res + +(** reduction machine without global env and refold machinery *) +let local_whd_state_gen flags sigma = + let rec whrec (x, stack) = + let c0 = EConstr.kind sigma x in + let s = (EConstr.of_kind c0, stack) in + match c0 with + | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> + stacklam whrec [b] sigma c stack + | Cast (c,_,_) -> whrec (c, stack) + | App (f,cl) -> whrec (f, Stack.append_app cl stack) + | Lambda (_,_,c) -> + (match Stack.decomp stack with + | Some (a,m) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> + stacklam whrec [a] sigma c m + | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> + (match EConstr.kind sigma (Stack.zip sigma (whrec (c, Stack.empty))) with + | App (f,cl) -> + let napp = Array.length cl in + if napp > 0 then + let x', l' = whrec (Array.last cl, Stack.empty) in + match EConstr.kind sigma x', l' with + | Rel 1, [] -> + let lc = Array.sub cl 0 (napp-1) in + let u = if Int.equal napp 1 then f else mkApp (f,lc) in + if noccurn sigma 1 u then (pop u,Stack.empty) else s + | _ -> s + else s + | _ -> s) + | _ -> s) + + | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> + (whrec (c, Stack.Proj (p, Cst_stack.empty) :: stack)) + + | Case (ci,p,d,lf) -> + whrec (d, Stack.Case (ci,p,lf,Cst_stack.empty) :: stack) + + | Fix ((ri,n),_ as f) -> + (match Stack.strip_n_app ri.(n) stack with + |None -> s + |Some (bef,arg,s') -> whrec (arg, Stack.Fix(f,bef,Cst_stack.empty)::s')) + + | Evar ev -> s + | Meta ev -> + (match safe_meta_value sigma ev with + Some c -> whrec (c,stack) + | None -> s) + + | Construct ((ind,c),u) -> + let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in + let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in + if use_match || use_fix then + match Stack.strip_app stack with + |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> + whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Proj (p,_) :: s') when use_match -> + whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') + |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> + let x' = Stack.zip sigma (x,args) in + whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) + |_, (Stack.App _|Stack.Cst _)::_ -> assert false + |_, _ -> s + else s + + | CoFix cofix -> + if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then + match Stack.strip_app stack with + |args, ((Stack.Case _ | Stack.Proj _)::s') -> + whrec (contract_cofix sigma cofix, stack) + |_ -> s + else s + + | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ + | Int _ -> s + + in + whrec + +let raw_whd_state_gen flags env = + let f sigma s = fst (whd_state_gen ~refold:false + ~tactic_mode:false + flags env sigma s) in + f + +let stack_red_of_state_red f = + let f sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f sigma (x, Stack.empty))) in + f + +(* Drops the Cst_stack *) +let iterate_whd_gen refold flags env sigma s = + let rec aux t = + let (hd,sk),_ = whd_state_gen ~refold ~tactic_mode:false flags env sigma (t,Stack.empty) in + let whd_sk = Stack.map aux sk in + Stack.zip sigma ~refold (hd,whd_sk) + in aux s + +let red_of_state_red f sigma x = + Stack.zip sigma (f sigma (x,Stack.empty)) + +(* 0. No Reduction Functions *) + +let whd_nored_state = local_whd_state_gen CClosure.nored +let whd_nored_stack = stack_red_of_state_red whd_nored_state +let whd_nored = red_of_state_red whd_nored_state + +(* 1. Beta Reduction Functions *) + +let whd_beta_state = local_whd_state_gen CClosure.beta +let whd_beta_stack = stack_red_of_state_red whd_beta_state +let whd_beta = red_of_state_red whd_beta_state + +let whd_betalet_state = local_whd_state_gen CClosure.betazeta +let whd_betalet_stack = stack_red_of_state_red whd_betalet_state +let whd_betalet = red_of_state_red whd_betalet_state + +(* 2. Delta Reduction Functions *) + +let whd_delta_state e = raw_whd_state_gen CClosure.delta e +let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env) +let whd_delta env = red_of_state_red (whd_delta_state env) + +let whd_betadeltazeta_state e = raw_whd_state_gen CClosure.betadeltazeta e +let whd_betadeltazeta_stack env = + stack_red_of_state_red (whd_betadeltazeta_state env) +let whd_betadeltazeta env = + red_of_state_red (whd_betadeltazeta_state env) + + +(* 3. Iota reduction Functions *) + +let whd_betaiota_state = local_whd_state_gen CClosure.betaiota +let whd_betaiota_stack = stack_red_of_state_red whd_betaiota_state +let whd_betaiota = red_of_state_red whd_betaiota_state + +let whd_betaiotazeta_state = local_whd_state_gen CClosure.betaiotazeta +let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state +let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state + +let whd_all_state env = raw_whd_state_gen CClosure.all env +let whd_all_stack env = + stack_red_of_state_red (whd_all_state env) +let whd_all env = + red_of_state_red (whd_all_state env) + +let whd_allnolet_state env = raw_whd_state_gen CClosure.allnolet env +let whd_allnolet_stack env = + stack_red_of_state_red (whd_allnolet_state env) +let whd_allnolet env = + red_of_state_red (whd_allnolet_state env) + +(* 4. Ad-hoc eta reduction, does not subsitute evars *) + +let shrink_eta c = Stack.zip Evd.empty (local_whd_state_gen eta Evd.empty (c,Stack.empty)) + +(* 5. Zeta Reduction Functions *) + +let whd_zeta_state = local_whd_state_gen CClosure.zeta +let whd_zeta_stack = stack_red_of_state_red whd_zeta_state +let whd_zeta = red_of_state_red whd_zeta_state + +(****************************************************************************) +(* Reduction Functions *) +(****************************************************************************) + +(* Replacing defined evars for error messages *) +let whd_evar = Evarutil.whd_evar +let nf_evar = Evarutil.nf_evar + +(* lazy reduction functions. The infos must be created for each term *) +(* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add + a [nf_evar] here *) +let clos_norm_flags flgs env sigma t = + try + let evars ev = safe_evar_value sigma ev in + EConstr.of_constr (CClosure.norm_val + (CClosure.create_clos_infos ~evars flgs env) + (CClosure.create_tab ()) + (CClosure.inject (EConstr.Unsafe.to_constr t))) + with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") + +let clos_whd_flags flgs env sigma t = + try + let evars ev = safe_evar_value sigma ev in + EConstr.of_constr (CClosure.whd_val + (CClosure.create_clos_infos ~evars flgs env) + (CClosure.create_tab ()) + (CClosure.inject (EConstr.Unsafe.to_constr t))) + with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") + +let nf_beta = clos_norm_flags CClosure.beta +let nf_betaiota = clos_norm_flags CClosure.betaiota +let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta +let nf_zeta = clos_norm_flags CClosure.zeta +let nf_all env sigma = + clos_norm_flags CClosure.all env sigma + + +(********************************************************************) +(* Conversion *) +(********************************************************************) +(* +let fkey = CProfile.declare_profile "fhnf";; +let fhnf info v = CProfile.profile2 fkey fhnf info v;; + +let fakey = CProfile.declare_profile "fhnf_apply";; +let fhnf_apply info k h a = CProfile.profile4 fakey fhnf_apply info k h a;; +*) + +let is_transparent e k = + match Conv_oracle.get_strategy (Environ.oracle e) k with + | Conv_oracle.Opaque -> false + | _ -> true + +(* Conversion utility functions *) + +type conversion_test = Constraint.t -> Constraint.t + +let pb_is_equal pb = pb == Reduction.CONV + +let pb_equal = function + | Reduction.CUMUL -> Reduction.CONV + | Reduction.CONV -> Reduction.CONV + +let report_anomaly e = + let msg = Pp.(str "Conversion test raised an anomaly:" ++ + spc () ++ CErrors.print e) in + let e = UserError (None,msg) in + let e = CErrors.push e in + iraise e + +let f_conv ?l2r ?reds env ?evars x y = + let inj = EConstr.Unsafe.to_constr in + Reduction.conv ?l2r ?reds env ?evars (inj x) (inj y) + +let f_conv_leq ?l2r ?reds env ?evars x y = + let inj = EConstr.Unsafe.to_constr in + Reduction.conv_leq ?l2r ?reds env ?evars (inj x) (inj y) + +let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y = + try + let evars ev = safe_evar_value sigma ev in + let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in + true + with Reduction.NotConvertible -> false + | e when is_anomaly e -> report_anomaly e + +let is_conv ?(reds=TransparentState.full) env sigma = test_trans_conversion f_conv reds env sigma +let is_conv_leq ?(reds=TransparentState.full) env sigma = test_trans_conversion f_conv_leq reds env sigma +let is_fconv ?(reds=TransparentState.full) = function + | Reduction.CONV -> is_conv ~reds + | Reduction.CUMUL -> is_conv_leq ~reds + +let check_conv ?(pb=Reduction.CUMUL) ?(ts=TransparentState.full) env sigma x y = + let f = match pb with + | Reduction.CONV -> f_conv + | Reduction.CUMUL -> f_conv_leq + in + try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true + with Reduction.NotConvertible -> false + | Univ.UniverseInconsistency _ -> false + | e when is_anomaly e -> report_anomaly e + +let sigma_compare_sorts env pb s0 s1 sigma = + match pb with + | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1 + | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1 + +let sigma_compare_instances ~flex i0 i1 sigma = + try Evd.set_eq_instances ~flex sigma i0 i1 + with Evd.UniversesDiffer + | Univ.UniverseInconsistency _ -> + raise Reduction.NotConvertible + +let sigma_check_inductive_instances cv_pb variance u1 u2 sigma = + match Evarutil.compare_cumulative_instances cv_pb variance u1 u2 sigma with + | Inl sigma -> sigma + | Inr _ -> + raise Reduction.NotConvertible + +let sigma_univ_state = + let open Reduction in + { compare_sorts = sigma_compare_sorts; + compare_instances = sigma_compare_instances; + compare_cumul_instances = sigma_check_inductive_instances; } + +let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) + ?(ts=TransparentState.full) env sigma x y = + (* FIXME *) + try + let ans = match pb with + | Reduction.CUMUL -> + EConstr.leq_constr_universes env sigma x y + | Reduction.CONV -> + EConstr.eq_constr_universes env sigma x y + in + let ans = match ans with + | None -> None + | Some cstr -> + try Some (Evd.add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None + in + match ans with + | Some sigma -> ans + | None -> + let x = EConstr.Unsafe.to_constr x in + let y = EConstr.Unsafe.to_constr y in + let sigma' = + conv_fun pb ~l2r:false sigma ts + env (sigma, sigma_univ_state) x y in + Some sigma' + with + | Reduction.NotConvertible -> None + | Univ.UniverseInconsistency _ when catch_incon -> None + | e when is_anomaly e -> report_anomaly e + +let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> + Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) + +(* This reference avoids always having to link C code with the kernel *) +let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:TransparentState.full) +let set_vm_infer_conv f = vm_infer_conv := f +let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = + !vm_infer_conv ~pb env t1 t2 + +(********************************************************************) +(* Special-Purpose Reduction *) +(********************************************************************) + +let whd_meta sigma c = match EConstr.kind sigma c with + | Meta p -> (try meta_value sigma p with Not_found -> c) + | _ -> c + +let default_plain_instance_ident = Id.of_string "H" + +(* Try to replace all metas. Does not replace metas in the metas' values + * Differs from (strong whd_meta). *) +let plain_instance sigma s c = + let rec irec n u = match EConstr.kind sigma u with + | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u) + | App (f,l) when isCast sigma f -> + let (f,_,t) = destCast sigma f in + let l' = Array.Fun1.Smart.map irec n l in + (match EConstr.kind sigma 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 = Metamap.find p s in + match EConstr.kind sigma g with + | App _ -> + let l' = Array.Fun1.Smart.map lift 1 l' in + let r = Sorts.Relevant in (* TODO fix relevance *) + let na = make_annot (Name default_plain_instance_ident) r in + mkLetIn (na,g,t,mkApp(mkRel 1, l')) + | _ -> mkApp (g,l') + with Not_found -> mkApp (f,l')) + | _ -> mkApp (irec n f,l')) + | Cast (m,_,_) when isMeta sigma m -> + (try lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) + | _ -> + map_with_binders sigma succ irec n u + in + if Metamap.is_empty s then c + else irec 0 c + +(* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota] + has (unfortunately) different subtle side effects: + + - ** Order of subgoals ** + If the lemma is a case analysis with parameters, it will move the + parameters as first subgoals (e.g. "case H" applied on + "H:D->A/\B|-C" will present the subgoal |-D first while w/o + betaiota the subgoal |-D would have come last). + + - ** Betaiota-contraction in statement ** + If the lemma has a parameter which is a function and this + function is applied in the lemma, then the _strong_ betaiota will + contract the application of the function to its argument (e.g. + "apply (H (fun x => x))" in "H:forall f, f 0 = 0 |- 0=0" will + result in applying the lemma 0=0 in which "(fun x => x) 0" has + been contracted). A goal to rewrite may then fail or succeed + differently. + + - ** Naming of hypotheses ** + If a lemma is a function of the form "fun H:(forall a:A, P a) + => .. F H .." where the expected type of H is "forall b:A, P b", + then, without reduction, the application of the lemma will + generate a subgoal "forall a:A, P a" (and intro will use name + "a"), while with reduction, it will generate a subgoal "forall + b:A, P b" (and intro will use name "b"). + + - ** First-order pattern-matching ** + If a lemma has the type "(fun x => p) t" then rewriting t may fail + if the type of the lemma is first beta-reduced (this typically happens + when rewriting a single variable and the type of the lemma is obtained + by meta_instance (with empty map) which itself calls instance with this + empty map). + *) + +let instance sigma s c = + (* if s = [] then c else *) + local_strong whd_betaiota sigma (plain_instance sigma 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 EConstr.kind sigma (whd_all env sigma t) with + | Prod (_,_,b) -> subst1 n b + | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product.") + +let hnf_prod_appvect env sigma t nl = + Array.fold_left (fun acc t -> hnf_prod_app env sigma acc t) t nl + +let hnf_prod_applist env sigma t nl = + List.fold_left (fun acc t -> hnf_prod_app env sigma acc t) t nl + +let hnf_lam_app env sigma t n = + match EConstr.kind sigma (whd_all env sigma t) with + | Lambda (_,_,b) -> subst1 n b + | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction.") + +let hnf_lam_appvect env sigma t nl = + Array.fold_left (fun acc t -> hnf_lam_app env sigma acc t) t nl + +let hnf_lam_applist env sigma t nl = + List.fold_left (fun acc t -> hnf_lam_app env sigma acc t) t nl + +let splay_prod env sigma = + let rec decrec env m c = + let t = whd_all env sigma c in + match EConstr.kind sigma t with + | Prod (n,a,c0) -> + decrec (push_rel (LocalAssum (n,a)) env) ((n,a)::m) c0 + | _ -> m,t + in + decrec env [] + +let splay_lam env sigma = + let rec decrec env m c = + let t = whd_all env sigma c in + match EConstr.kind sigma t with + | Lambda (n,a,c0) -> + decrec (push_rel (LocalAssum (n,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_allnolet env sigma c in + match EConstr.kind sigma t with + | Prod (x,t,c) -> + prodec_rec (push_rel (LocalAssum (x,t)) env) + (Context.Rel.add (LocalAssum (x,t)) l) c + | LetIn (x,b,t,c) -> + prodec_rec (push_rel (LocalDef (x,b,t)) env) + (Context.Rel.add (LocalDef (x,b,t)) l) c + | Cast (c,_,_) -> prodec_rec env l c + | _ -> + let t' = whd_all env sigma t in + if EConstr.eq_constr sigma t t' then l,t + else prodec_rec env l t' + in + prodec_rec env Context.Rel.empty + +let splay_arity env sigma c = + let l, c = splay_prod env sigma c in + match EConstr.kind sigma c with + | Sort s -> l,s + | _ -> invalid_arg "splay_arity" + +let sort_of_arity env sigma c = snd (splay_arity env sigma c) + +let splay_prod_n env sigma n = + let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else + match EConstr.kind sigma (whd_all env sigma c) with + | Prod (n,a,c0) -> + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + | _ -> invalid_arg "splay_prod_n" + in + decrec env n Context.Rel.empty + +let splay_lam_n env sigma n = + let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else + match EConstr.kind sigma (whd_all env sigma c) with + | Lambda (n,a,c0) -> + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + | _ -> invalid_arg "splay_lam_n" + in + decrec env n Context.Rel.empty + +let is_sort env sigma t = + match EConstr.kind sigma (whd_all env sigma t) with + | Sort s -> true + | _ -> false + +(* reduction to head-normal-form allowing delta/zeta only in argument + of case/fix (heuristic used by evar_conv) *) + +let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = + let refold = false in + let tactic_mode = false in + let rec whrec csts s = + let (t, stack as s),csts' = whd_state_gen ~csts ~refold ~tactic_mode CClosure.betaiota env sigma s in + match Stack.strip_app stack with + |args, (Stack.Case _ :: _ as stack') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode + (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in + if reducible_mind_case sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + |args, (Stack.Fix _ :: _ as stack') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode + (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in + if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + |args, (Stack.Proj (p,_) :: stack'') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode + (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in + if isConstruct sigma t_o then + whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') + else s,csts' + |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' + in whrec csts s + +let find_conclusion env sigma = + let rec decrec env c = + let t = whd_all env sigma c in + match EConstr.kind sigma t with + | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 + | t -> t + in + decrec env + +let is_arity env sigma c = + match find_conclusion env sigma c with + | Sort _ -> true + | _ -> false + +(*************************************) +(* Metas *) + +let meta_value evd mv = + let rec valrec mv = + match meta_opt_fvalue evd mv with + | Some (b,_) -> + let metas = Metamap.bind valrec b.freemetas in + instance evd metas b.rebus + | None -> mkMeta mv + in + valrec mv + +let meta_instance sigma b = + let fm = b.freemetas in + if Metaset.is_empty fm then b.rebus + else + let c_sigma = Metamap.bind (fun mv -> meta_value sigma mv) fm in + instance sigma c_sigma b.rebus + +let nf_meta sigma c = + let cl = mk_freelisted c in + meta_instance sigma { cl with rebus = cl.rebus } + +(* Instantiate metas that create beta/iota redexes *) + +let meta_reducible_instance evd b = + let fm = b.freemetas in + let fold mv accu = + let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in + match fvalue with + | None -> accu + | Some (g, (_, s)) -> Metamap.add mv (g.rebus, s) accu + in + let metas = Metaset.fold fold fm Metamap.empty in + let rec irec u = + let u = whd_betaiota Evd.empty u (* FIXME *) in + match EConstr.kind evd u with + | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + let m = destMeta evd (strip_outer_cast evd c) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkCase (ci,p,g,bl)) + | None -> mkCase (ci,irec p,c,Array.map irec bl)) + | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> + let m = destMeta evd (strip_outer_cast evd f) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isLambda evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkApp (g,l)) + | None -> mkApp (f,Array.map irec l)) + | Meta m -> + (try let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if not is_coerce then irec g else u + with Not_found -> u) + | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> + let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) + | _ -> EConstr.map evd irec u + in + if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus + else irec b.rebus + +let betazetaevar_applist sigma n c l = + let rec stacklam n env t stack = + if Int.equal n 0 then applist (substl env t, stack) else + match EConstr.kind sigma t, stack with + | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack + | Evar _, _ -> applist (substl env t, stack) + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in + stacklam n [] c l diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli new file mode 100644 index 0000000000..5938d9b367 --- /dev/null +++ b/pretyping/reductionops.mli @@ -0,0 +1,321 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open EConstr +open Univ +open Evd +open Environ + +(** Reduction Functions. *) + +exception Elimconst + +(** Machinery to customize the behavior of the reduction *) +module ReductionBehaviour : sig + type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] + +(** [set is_local ref (recargs, nargs, flags)] *) + val set : + bool -> GlobRef.t -> (int list * int * flag list) -> unit + val get : + GlobRef.t -> (int list * int * flag list) option + val print : GlobRef.t -> Pp.t +end + +(** {6 Support for reduction effects } *) + +type effect_name = string + +(* [declare_reduction_effect name f] declares [f] under key [name]; + [name] must be a unique in "world". *) +val declare_reduction_effect : effect_name -> + (Environ.env -> Evd.evar_map -> Constr.constr -> unit) -> unit + +(* [set_reduction_effect cst name] declares effect [name] to be called when [cst] is found *) +val set_reduction_effect : Constant.t -> effect_name -> unit + +(* [effect_hook env sigma key term] apply effect associated to [key] on [term] *) +val reduction_effect_hook : Environ.env -> Evd.evar_map -> Constant.t -> + Constr.constr Lazy.t -> unit + +(** {6 Machinery about a stack of unfolded constant } + + cst applied to params must convertible to term of the state applied to args +*) +module Cst_stack : sig + type t + val empty : t + val add_param : constr -> t -> t + val add_args : constr array -> t -> t + val add_cst : constr -> t -> t + val best_cst : t -> (constr * constr list) option + val best_replace : Evd.evar_map -> constr -> t -> constr -> constr + val reference : Evd.evar_map -> t -> Constant.t option + val pr : env -> Evd.evar_map -> t -> Pp.t +end + +module Stack : sig + type 'a app_node + + val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + + type cst_member = + | Cst_const of pconstant + | Cst_proj of Projection.t + + type 'a member = + | App of 'a app_node + | Case of case_info * 'a * 'a array * Cst_stack.t + | Proj of Projection.t * Cst_stack.t + | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t + | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t + | Cst of cst_member + * int (* current foccussed arg *) + * int list (* remaining args *) + * 'a t * Cst_stack.t + and 'a t = 'a member list + + val pr : ('a -> Pp.t) -> 'a t -> Pp.t + + val empty : 'a t + val is_empty : 'a t -> bool + val append_app : 'a array -> 'a t -> 'a t + val decomp : 'a t -> ('a * 'a t) option + + val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t) + + val compare_shape : 'a t -> 'a t -> bool + + exception IncompatibleFold2 + + (** [fold2 f x sk1 sk2] folds [f] on any pair of term in [(sk1,sk2)]. + @return the result and the lifts to apply on the terms + @raise IncompatibleFold2 when [sk1] and [sk2] have incompatible shapes *) + val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> + constr t -> constr t -> 'a + val map : ('a -> 'a) -> 'a t -> 'a t + val append_app_list : 'a list -> 'a t -> 'a t + + (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not + start by App *) + val strip_app : 'a t -> 'a t * 'a t + + (** @return (the nth first elements, the (n+1)th element, the remaining stack) *) + val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option + + val not_purely_applicative : 'a t -> bool + val list_of_app_stack : constr t -> constr list option + + val assign : 'a t -> int -> 'a -> 'a t + val args_size : 'a t -> int + val tail : int -> 'a t -> 'a t + val nth : 'a t -> int -> 'a + + val best_state : evar_map -> constr * constr t -> Cst_stack.t -> constr * constr t + val zip : ?refold:bool -> evar_map -> constr * constr t -> constr +end + +(************************************************************************) + +type state = constr * constr Stack.t + +type contextual_reduction_function = env -> evar_map -> constr -> constr +type reduction_function = contextual_reduction_function +type local_reduction_function = evar_map -> constr -> constr + +type e_reduction_function = env -> evar_map -> constr -> evar_map * 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 = + evar_map -> 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 = evar_map -> state -> state + +val pr_state : env -> evar_map -> state -> Pp.t + +(** {6 Reduction Function Operators } *) + +val strong_with_flags : + (CClosure.RedFlags.reds -> reduction_function) -> + (CClosure.RedFlags.reds -> reduction_function) +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 -> evar_map -> constr -> constr Stack.t -> 'a + +val whd_state_gen : ?csts:Cst_stack.t -> refold:bool -> tactic_mode:bool -> + CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t + +val iterate_whd_gen : bool -> CClosure.RedFlags.reds -> + Environ.env -> Evd.evar_map -> constr -> constr + +(** {6 Generic Optimized Reduction Function using Closures } *) + +val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function +val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function + +(** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) +val nf_beta : reduction_function +val nf_betaiota : reduction_function +val nf_betaiotazeta : reduction_function +val nf_zeta : reduction_function +val nf_all : reduction_function +val nf_evar : evar_map -> constr -> constr + +(** Lazy strategy, weak head reduction *) + +val whd_evar : evar_map -> constr -> constr +val whd_nored : local_reduction_function +val whd_beta : local_reduction_function +val whd_betaiota : local_reduction_function +val whd_betaiotazeta : local_reduction_function +val whd_all : contextual_reduction_function +val whd_allnolet : contextual_reduction_function +val whd_betalet : local_reduction_function + +(** Removes cast and put into applicative form *) +val whd_nored_stack : local_stack_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_all_stack : contextual_stack_reduction_function +val whd_allnolet_stack : contextual_stack_reduction_function +val whd_betalet_stack : local_stack_reduction_function + +val whd_nored_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_all_state : contextual_state_reduction_function +val whd_allnolet_state : contextual_state_reduction_function +val whd_betalet_state : local_state_reduction_function + +(** {6 Head normal forms } *) + +val whd_delta_stack : stack_reduction_function +val whd_delta_state : state_reduction_function +val whd_delta : reduction_function +val whd_betadeltazeta_stack : stack_reduction_function +val whd_betadeltazeta_state : state_reduction_function +val whd_betadeltazeta : reduction_function +val whd_zeta_stack : local_stack_reduction_function +val whd_zeta_state : local_state_reduction_function +val whd_zeta : local_reduction_function + +val shrink_eta : constr -> constr + +(** Various reduction functions *) + +val safe_evar_value : evar_map -> Constr.existential -> Constr.constr option + +val beta_applist : evar_map -> 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.t Context.binder_annot * constr) list * constr +val splay_lam : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * constr +val splay_arity : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * ESorts.t +val sort_of_arity : env -> evar_map -> constr -> ESorts.t +val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr +val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr +val splay_prod_assum : + env -> evar_map -> constr -> 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 : evar_map -> constr -> bool +val reduce_mind_case : evar_map -> constr miota_args -> constr + +val find_conclusion : env -> evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) kind_of_term +val is_arity : env -> evar_map -> constr -> bool +val is_sort : env -> evar_map -> types -> bool + +val contract_fix : ?env:Environ.env -> evar_map -> ?reference:Constant.t -> fixpoint -> constr +val fix_recarg : ('a, 'a) pfixpoint -> 'b Stack.t -> (int * 'b) option + +(** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) +val is_transparent : Environ.env -> Constant.t tableKey -> bool + +(** {6 Conversion Functions (uses closures, lazy strategy) } *) + +type conversion_test = Constraint.t -> Constraint.t + +val pb_is_equal : conv_pb -> bool +val pb_equal : conv_pb -> conv_pb + +val is_conv : ?reds:TransparentState.t -> env -> evar_map -> constr -> constr -> bool +val is_conv_leq : ?reds:TransparentState.t -> env -> evar_map -> constr -> constr -> bool +val is_fconv : ?reds:TransparentState.t -> conv_pb -> env -> evar_map -> constr -> constr -> bool + +(** [check_conv] Checks universe constraints only. + pb defaults to CUMUL and ts to a full transparent state. + *) +val check_conv : ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> bool + +(** [infer_conv] Adds necessary universe constraints to the evar map. + pb defaults to CUMUL and ts to a full transparent state. + @raise UniverseInconsistency iff catch_incon is set to false, + otherwise returns false in that case. + *) +val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> + env -> evar_map -> constr -> constr -> evar_map option + +(** Conversion with inference of universe constraints *) +val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map option) -> unit +val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map option + + +(** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a +conversion function. Used to pretype vm and native casts. *) +val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> + (Constr.constr, evar_map) Reduction.generic_conversion_function) -> + ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> + evar_map -> constr -> constr -> evar_map option + +(** {6 Special-Purpose Reduction Functions } *) + +val whd_meta : local_reduction_function +val plain_instance : evar_map -> constr Metamap.t -> constr -> constr +val instance : evar_map -> constr Metamap.t -> constr -> constr +val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr + +(** {6 Heuristic for Conversion with Evar } *) + +val whd_betaiota_deltazeta_for_iota_state : + TransparentState.t -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> + state * Cst_stack.t + +(** {6 Meta-related reduction functions } *) +val meta_instance : evar_map -> constr freelisted -> constr +val nf_meta : evar_map -> constr -> constr +val meta_reducible_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml new file mode 100644 index 0000000000..38e254a5b4 --- /dev/null +++ b/pretyping/retyping.ml @@ -0,0 +1,298 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Term +open Constr +open Context +open Inductive +open Inductiveops +open Names +open Reductionops +open Environ +open Termops +open EConstr +open Vars +open Arguments_renaming +open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +type retype_error = + | NotASort + | NotAnArity + | NotAType + | BadVariable of Id.t + | BadMeta of int + | BadRecursiveType + | NonFunctionalConstruction + +let print_retype_error = function + | NotASort -> str "Not a sort" + | NotAnArity -> str "Not an arity" + | NotAType -> str "Not a type (1)" + | BadVariable id -> str "variable " ++ Id.print id ++ str " unbound" + | BadMeta n -> str "unknown meta " ++ int n + | BadRecursiveType -> str "Bad recursive type" + | NonFunctionalConstruction -> str "Non-functional construction" + +exception RetypeError of retype_error + +let retype_error re = raise (RetypeError re) + +let anomaly_on_error f x = + try f x + with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e ++ str ".") + +let get_type_from_constraints env sigma t = + if isEvar sigma (fst (decompose_app_vect sigma t)) then + match + List.map_filter (fun (pbty,env,t1,t2) -> + if is_fconv Reduction.CONV env sigma t t1 then Some t2 + else if is_fconv Reduction.CONV env sigma t t2 then Some t1 + else None) + (snd (Evd.extract_all_conv_pbs sigma)) + with + | t::l -> t + | _ -> raise Not_found + else raise Not_found + +let rec subst_type env sigma typ = function + | [] -> typ + | h::rest -> + match EConstr.kind sigma (whd_all env sigma typ) with + | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest + | _ -> retype_error NonFunctionalConstruction + +(* If ft is the type of f which itself is applied to args, *) +(* [sort_of_atomic_type] computes ft[args] which has to be a sort *) + +let sort_of_atomic_type env sigma ft args = + let rec concl_of_arity env n ar args = + match EConstr.kind sigma (whd_all env sigma ar), args with + | Prod (na, t, b), h::l -> + concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l + | Sort s, [] -> ESorts.kind sigma s + | _ -> retype_error NotASort + in concl_of_arity env 0 ft (Array.to_list args) + +let type_of_var env id = + try NamedDecl.get_type (lookup_named id env) + with Not_found -> retype_error (BadVariable id) + +let decomp_sort env sigma t = + match EConstr.kind sigma (whd_all env sigma t) with + | Sort s -> ESorts.kind sigma s + | _ -> retype_error NotASort + +let destSort sigma s = ESorts.kind sigma (destSort sigma s) + +let retype ?(polyprop=true) sigma = + let rec type_of env cstr = + match EConstr.kind sigma cstr with + | Meta n -> + (try strip_outer_cast sigma (Evd.meta_ftype sigma n).Evd.rebus + with Not_found -> retype_error (BadMeta n)) + | Rel n -> + let ty = RelDecl.get_type (lookup_rel n env) in + lift n ty + | Var id -> type_of_var env id + | Const (cst, u) -> EConstr.of_constr (rename_type_of_constant env (cst, EInstance.kind sigma u)) + | Evar ev -> existential_type sigma ev + | Ind (ind, u) -> EConstr.of_constr (rename_type_of_inductive env (ind, EInstance.kind sigma u)) + | Construct (cstr, u) -> EConstr.of_constr (rename_type_of_constructor env (cstr, EInstance.kind sigma u)) + | Case (_,p,c,lf) -> + let Inductiveops.IndType(indf,realargs) = + let t = type_of env c in + try Inductiveops.find_rectype env sigma t + with Not_found -> + try + let t = get_type_from_constraints env sigma t in + Inductiveops.find_rectype env sigma t + with Not_found -> retype_error BadRecursiveType + in + let n = inductive_nrealdecls env (fst (fst (dest_ind_family indf))) in + let t = betazetaevar_applist sigma n p realargs in + (match EConstr.kind sigma (whd_all env sigma (type_of env t)) with + | Prod _ -> whd_beta sigma (applist (t, [c])) + | _ -> t) + | Lambda (name,c1,c2) -> + mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) + | LetIn (name,b,c1,c2) -> + subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) + | Fix ((_,i),(_,tys,_)) -> tys.(i) + | CoFix (i,(_,tys,_)) -> tys.(i) + | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> + let t = type_of_global_reference_knowing_parameters env f args in + strip_outer_cast sigma (subst_type env sigma t (Array.to_list args)) + | App(f,args) -> + strip_outer_cast sigma + (subst_type env sigma (type_of env f) (Array.to_list args)) + | Proj (p,c) -> + let ty = type_of env c in + EConstr.of_constr (try + Inductiveops.type_of_projection_knowing_arg env sigma p c ty + with Invalid_argument _ -> retype_error BadRecursiveType) + | Cast (c,_, t) -> t + | Sort _ | Prod _ -> mkSort (sort_of env cstr) + | Int _ -> EConstr.of_constr (Typeops.type_of_int env) + + and sort_of env t = + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> destSort sigma s + | Sort s -> + begin match ESorts.kind sigma s with + | SProp | Prop | Set -> Sorts.type1 + | Type u -> Sorts.sort_of_univ (Univ.super u) + end + | Prod (name,t,c2) -> + let dom = sort_of env t in + let rang = sort_of (push_rel (LocalAssum (name,t)) env) c2 in + Typeops.sort_of_product env dom rang + | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> + let t = type_of_global_reference_knowing_parameters env f args in + sort_of_atomic_type env sigma t args + | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args + | Lambda _ | Fix _ | Construct _ -> retype_error NotAType + | _ -> decomp_sort env sigma (type_of env t) + + and type_of_global_reference_knowing_parameters env c args = + let argtyps = + Array.map (fun c -> lazy (EConstr.to_constr ~abort_on_undefined_evars:false sigma (type_of env c))) args in + match EConstr.kind sigma c with + | Ind (ind, u) -> + let u = EInstance.kind sigma u in + let mip = lookup_mind_specif env ind in + EConstr.of_constr (try Inductive.type_of_inductive_knowing_parameters + ~polyprop env (mip, u) argtyps + with Reduction.NotArity -> retype_error NotAnArity) + | Construct (cstr, u) -> + let u = EInstance.kind sigma u in + EConstr.of_constr (type_of_constructor env (cstr, u)) + | _ -> assert false + + in type_of, sort_of, type_of_global_reference_knowing_parameters + +let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = + let type_of,_,type_of_global_reference_knowing_parameters = retype ~polyprop sigma in + let rec sort_family_of env t = + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) + | Sort _ -> InType + | Prod (name,t,c2) -> + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + if not (is_impredicative_set env) && + s2 == InSet && sort_family_of env t == InType then InType else s2 + | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> + if truncation_style then InType else + let t = type_of_global_reference_knowing_parameters env f args in + Sorts.family (sort_of_atomic_type env sigma t args) + | App(f,args) -> + Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) + | Lambda _ | Fix _ | Construct _ -> retype_error NotAType + | Ind _ when truncation_style && Termops.is_template_polymorphic_ind env sigma t -> InType + | _ -> + Sorts.family (decomp_sort env sigma (type_of env t)) + in sort_family_of env t + +let get_sort_of ?(polyprop=true) env sigma t = + let _,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) t +let type_of_global_reference_knowing_parameters env sigma c args = + let _,_,f = retype sigma in anomaly_on_error (f env c) args + +let type_of_global_reference_knowing_conclusion env sigma c conclty = + match EConstr.kind sigma c with + | Ind (ind,u) -> + let spec = Inductive.lookup_mind_specif env ind in + type_of_inductive_knowing_conclusion env sigma (spec, EInstance.kind sigma u) conclty + | Const (cst, u) -> + let t = constant_type_in env (cst, EInstance.kind sigma u) in + sigma, EConstr.of_constr t + | Var id -> sigma, type_of_var env id + | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) + | _ -> assert false + +(* Profiling *) +(* let get_type_of polyprop lax env sigma c = *) +(* let f,_,_,_ = retype ~polyprop sigma in *) +(* if lax then f env c else anomaly_on_error (f env) c *) + +(* let get_type_of_key = CProfile.declare_profile "get_type_of" *) +(* let get_type_of = CProfile.profile5 get_type_of_key get_type_of *) + +(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) +(* get_type_of polyprop lax env sigma c *) + +let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = + let f,_,_ = retype ~polyprop sigma in + if lax then f env c else anomaly_on_error (f env) 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 } + +(* Returns sorts of a context *) +let sorts_of_context env evc ctxt = + let rec aux = function + | [] -> env,[] + | d :: ctxt -> + let env,sorts = aux ctxt in + let s = get_sort_of env evc (RelDecl.get_type d) in + (push_rel d env,s::sorts) in + snd (aux ctxt) + +let expand_projection env sigma pr c args = + let ty = get_type_of ~lax:true env sigma c in + let (i,u), ind_args = + try Inductiveops.find_mrectype env sigma ty + with Not_found -> retype_error BadRecursiveType + in + mkApp (mkConstU (Projection.constant pr,u), + Array.of_list (ind_args @ (c :: args))) + +let relevance_of_term env sigma c = + if Environ.sprop_allowed env then + let rec aux rels c = + match kind sigma c with + | Rel n -> Retypeops.relevance_of_rel_extra env rels n + | Var x -> Retypeops.relevance_of_var env x + | Sort _ -> Sorts.Relevant + | Cast (c, _, _) -> aux rels c + | Prod ({binder_relevance=r}, _, codom) -> + aux (r::rels) codom + | Lambda ({binder_relevance=r}, _, bdy) -> + aux (r::rels) bdy + | LetIn ({binder_relevance=r}, _, _, bdy) -> + aux (r::rels) bdy + | App (c, _) -> aux rels c + | Const (c,_) -> Retypeops.relevance_of_constant env c + | Ind _ -> Sorts.Relevant + | Construct (c,_) -> Retypeops.relevance_of_constructor env c + | Case (ci, _, _, _) -> ci.ci_relevance + | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance + | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance + | Proj (p, _) -> Retypeops.relevance_of_projection env p + | Int _ -> Sorts.Relevant + + | Meta _ | Evar _ -> Sorts.Relevant + + in + aux [] c + else Sorts.Relevant + +let relevance_of_type env sigma t = + let s = get_sort_family_of env sigma t in + Sorts.relevance_of_sort_family s + +let relevance_of_sort s = Sorts.relevance_of_sort (EConstr.Unsafe.to_sorts s) + +let relevance_of_sort_family f = Sorts.relevance_of_sort_family f diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli new file mode 100644 index 0000000000..252bfb1a84 --- /dev/null +++ b/pretyping/retyping.mli @@ -0,0 +1,60 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Evd +open Environ +open EConstr + +(** This family of functions assumes its constr argument is known to be + well-typable. It does not type-check, just recompute the type + without any costly verifications. On non well-typable terms, it + either produces a wrong result or raise an anomaly. Use with care. + It doesn't handle predicative universes too. *) + +(** The "polyprop" optional argument is used by the extraction to + disable "Prop-polymorphism", cf comment in [inductive.ml] *) + +(** The "lax" optional argument provides a relaxed version of + [get_type_of] that won't raise any anomaly but RetypeError instead *) + +type retype_error +exception RetypeError of retype_error + +val get_type_of : + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types + +val get_sort_of : + ?polyprop:bool -> env -> evar_map -> types -> Sorts.t + +(* When [truncation_style] is [true], tells if the type has been explicitly + truncated to Prop or (impredicative) Set; in particular, singleton type and + small inductive types, which have all eliminations to Type, are in Type *) +val get_sort_family_of : + ?truncation_style:bool -> ?polyprop:bool -> env -> evar_map -> types -> Sorts.family + +(** Makes an unsafe judgment from a constr *) +val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment + +val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> + constr array -> types + +val type_of_global_reference_knowing_conclusion : + env -> evar_map -> constr -> types -> evar_map * types + +val sorts_of_context : env -> evar_map -> rel_context -> Sorts.t list + +val expand_projection : env -> evar_map -> Names.Projection.t -> constr -> constr list -> constr + +val print_retype_error : retype_error -> Pp.t + +val relevance_of_term : env -> evar_map -> constr -> Sorts.relevance +val relevance_of_type : env -> evar_map -> types -> Sorts.relevance +val relevance_of_sort : ESorts.t -> Sorts.relevance +val relevance_of_sort_family : Sorts.family -> Sorts.relevance diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml new file mode 100644 index 0000000000..bcc20a41b4 --- /dev/null +++ b/pretyping/tacred.ml @@ -0,0 +1,1295 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Constr +open Context +open Libnames +open Globnames +open Termops +open Environ +open EConstr +open Vars +open Find_subterm +open Namegen +open CClosure +open Reductionops +open Cbv +open Patternops +open Locus + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* Errors *) + +type reduction_tactic_error = + InvalidAbstraction of env * Evd.evar_map * EConstr.constr * (env * Type_errors.type_error) + +exception ReductionTacticError of reduction_tactic_error + +(* Evaluable reference *) + +exception Elimconst +exception Redelimination + +let error_not_evaluable r = + user_err ~hdr:"error_not_evaluable" + (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ + spc () ++ str "to an evaluable reference.") + +let is_evaluable_const env cst = + is_transparent env (ConstKey cst) && + (evaluable_constant cst env || is_primitive env cst) + +let is_evaluable_var env id = + is_transparent env (VarKey id) && evaluable_named id env + +let is_evaluable env = function + | EvalConstRef cst -> is_evaluable_const env cst + | EvalVarRef id -> is_evaluable_var env id + +let value_of_evaluable_ref env evref u = + match evref with + | EvalConstRef con -> + let u = Unsafe.to_instance u in + EConstr.of_constr (constant_value_in env (con, u)) + | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get + +let evaluable_of_global_reference env = function + | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst + | VarRef id when is_evaluable_var env id -> EvalVarRef id + | r -> error_not_evaluable r + +let global_of_evaluable_reference = function + | EvalConstRef cst -> ConstRef cst + | EvalVarRef id -> VarRef id + +type evaluable_reference = + | EvalConst of Constant.t + | EvalVar of Id.t + | EvalRel of int + | EvalEvar of EConstr.existential + +let evaluable_reference_eq sigma r1 r2 = match r1, r2 with +| EvalConst c1, EvalConst c2 -> Constant.equal c1 c2 +| EvalVar id1, EvalVar id2 -> Id.equal id1 id2 +| EvalRel i1, EvalRel i2 -> Int.equal i1 i2 +| EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> + Evar.equal e1 e2 && Array.equal (EConstr.eq_constr sigma) ctx1 ctx2 +| _ -> false + +let mkEvalRef ref u = + match ref with + | EvalConst cst -> mkConstU (cst,u) + | EvalVar id -> mkVar id + | EvalRel n -> mkRel n + | EvalEvar ev -> EConstr.mkEvar ev + +let isEvalRef env sigma c = match EConstr.kind sigma c with + | Const (sp,_) -> is_evaluable env (EvalConstRef sp) + | Var id -> is_evaluable env (EvalVarRef id) + | Rel _ | Evar _ -> true + | _ -> false + +let destEvalRefU sigma c = match EConstr.kind sigma c with + | Const (cst,u) -> EvalConst cst, u + | Var id -> (EvalVar id, EInstance.empty) + | Rel n -> (EvalRel n, EInstance.empty) + | Evar ev -> (EvalEvar ev, EInstance.empty) + | _ -> anomaly (Pp.str "Not an unfoldable reference.") + +let unsafe_reference_opt_value env sigma eval = + match eval with + | EvalConst cst -> + (match (lookup_constant cst env).Declarations.const_body with + | Declarations.Def c -> Some (EConstr.of_constr (Mod_subst.force_constr c)) + | _ -> None) + | EvalVar id -> + env |> lookup_named id |> NamedDecl.get_value + | EvalRel n -> + env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) + | EvalEvar ev -> + match EConstr.kind sigma (mkEvar ev) with + | Evar _ -> None + | c -> Some (EConstr.of_kind c) + +let reference_opt_value env sigma eval u = + match eval with + | EvalConst cst -> + let u = EInstance.kind sigma u in + Option.map EConstr.of_constr (constant_opt_value_in env (cst,u)) + | EvalVar id -> + env |> lookup_named id |> NamedDecl.get_value + | EvalRel n -> + env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) + | EvalEvar ev -> + match EConstr.kind sigma (mkEvar ev) with + | Evar _ -> None + | c -> Some (EConstr.of_kind c) + +exception NotEvaluable +let reference_value env sigma c u = + match reference_opt_value env sigma c u with + | None -> raise NotEvaluable + | Some d -> d + +(************************************************************************) +(* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) +(* One reuses the name of the function after reduction of the fixpoint *) + +type constant_evaluation = + | EliminationFix of int * int * (int * (int * constr) list * int) + | EliminationMutualFix of + int * evaluable_reference * + ((int*evaluable_reference) option array * + (int * (int * constr) list * int)) + | EliminationCases of int + | EliminationProj of int + | NotAnElimination + +(* We use a cache registered as a global table *) + +type frozen = constant_evaluation Cmap.t + +let eval_table = Summary.ref (Cmap.empty : frozen) ~name:"evaluation" + +(* [compute_consteval] determines whether c is an "elimination constant" + + either [yn:Tn]..[y1:T1](match yi with f1..fk end g1 ..gp) + + or [yn:Tn]..[y1:T1](Fix(f|t) yi1..yip) + with yi1..yip distinct variables among the yi, not occurring in t + + In the second case, [check_fix_reversibility [T1;...;Tn] args fix] + checks that [args] is a subset of disjoint variables in y1..yn (a necessary + condition for reversibility). It also returns the relevant + information ([i1,Ti1;..;ip,Tip],n) in order to compute an + equivalent of Fix(f|t) such that + + g := [xp:Tip']..[x1:Ti1'](f a1..an) + == [xp:Tip']..[x1:Ti1'](Fix(f|t) yi1..yip) + + with a_k:=y_k if k<>i_j, a_k:=args_k otherwise, and + Tij':=Tij[x1..xi(j-1) <- a1..ai(j-1)] + + Note that the types Tk, when no i_j=k, must not be dependent on + the xp..x1. +*) + +let check_fix_reversibility sigma 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 EConstr.kind sigma d with + | Rel k -> + if + Array.for_all (Vars.noccurn sigma k) tys + && Array.for_all (Vars.noccurn sigma (k+nbfix)) bds + && k <= n + then + (k, List.nth labs (k-1)) + else + raise Elimconst + | _ -> + raise Elimconst) args + in + let reversible_rels = List.map fst li in + if not (List.distinct_f Int.compare reversible_rels) then + raise Elimconst; + List.iteri (fun i t_i -> + if not (Int.List.mem_assoc (i+1) li) then + let fvs = List.map ((+) (i+1)) (Int.Set.elements (free_rels sigma t_i)) in + match List.intersect Int.equal fvs reversible_rels with + | [] -> () + | _ -> raise Elimconst) + labs; + 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,nargs,(nbfix,li,n)) + else + EliminationFix (n-nargs+k+1,nargs,(nbfix,li,n)) + +(* Heuristic to look if global names are associated to other + components of a mutual fixpoint *) + +let invert_name labs l {binder_name=na0} env sigma ref na = + match na.binder_name with + | Name id -> + let minfxargs = List.length l in + begin match na0 with + | Name id' when Id.equal id' id -> + Some (minfxargs,ref) + | _ -> + let refi = match ref with + | EvalRel _ | EvalEvar _ -> None + | EvalVar id' -> Some (EvalVar id) + | EvalConst kn -> + Some (EvalConst (Constant.change_label kn (Label.of_id id))) in + match refi with + | None -> None + | Some ref -> + try match unsafe_reference_opt_value env sigma ref with + | None -> None + | Some c -> + let labs',ccl = decompose_lam sigma c in + let _, l' = whd_betalet_stack sigma ccl in + let labs' = List.map snd labs' in + (* ppedrot: there used to be generic equality on terms here *) + let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in + if List.equal eq_constr labs' labs && + List.equal eq_constr l l' then Some (minfxargs,ref) + else None + with Not_found (* Undefined ref *) -> None + end + | 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 env sigma ref = + let rec srec env n labs onlyproj c = + let c',l = whd_betadeltazeta_stack env sigma c in + match EConstr.kind sigma c' with + | Lambda (id,t,g) when List.is_empty l && not onlyproj -> + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g + | Fix fix when not onlyproj -> + (try check_fix_reversibility sigma labs l fix + with Elimconst -> NotAnElimination) + | Case (_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n + | Case (_,_,d,_) -> srec env n labs true d + | Proj (p, d) when isRel sigma d -> EliminationProj n + | _ -> NotAnElimination + in + match unsafe_reference_opt_value env sigma ref with + | None -> NotAnElimination + | Some c -> srec env 0 [] false c + +let compute_consteval_mutual_fix env sigma ref = + let rec srec env minarg labs ref c = + let c',l = whd_betalet_stack sigma c in + let nargs = List.length l in + match EConstr.kind sigma c' with + | Lambda (na,t,g) when List.is_empty l -> + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g + | Fix ((lv,i),(names,_,_)) -> + (* Last known constant wrapping Fix is ref = [labs](Fix l) *) + (match compute_consteval_direct env sigma ref with + | NotAnElimination -> (*Above const was eliminable but this not!*) + NotAnElimination + | EliminationFix (minarg',minfxargs,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 sigma c' -> + (* Forget all \'s and args and do as if we had started with c' *) + let ref,_ = destEvalRefU sigma c' in + (match unsafe_reference_opt_value env sigma ref with + | None -> anomaly (Pp.str "Should have been trapped by compute_direct.") + | Some c -> srec env (minarg-nargs) [] ref c) + | _ -> (* Should not occur *) NotAnElimination + in + match unsafe_reference_opt_value env sigma ref with + | None -> (* Should not occur *) NotAnElimination + | Some c -> srec env 0 [] ref c + +let compute_consteval env sigma ref = + match compute_consteval_direct env sigma ref with + | EliminationFix (_,_,(nbfix,_,_)) when not (Int.equal nbfix 1) -> + compute_consteval_mutual_fix env sigma ref + | elim -> elim + +let reference_eval env sigma = function + | EvalConst cst as ref -> + (try + Cmap.find cst !eval_table + with Not_found -> begin + let v = compute_consteval env sigma ref in + eval_table := Cmap.add cst v !eval_table; + v + end) + | ref -> compute_consteval env sigma ref + +(* If f is bound to EliminationFix (n',infos), then n' is the minimal + number of args for starting the reduction and infos is + (nbfix,[(yi1,Ti1);...;(yip,Tip)],n) indicating that f converts + to some [y1:T1,...,yn:Tn](Fix(..) yip .. yi1) where the y_{i_j} consist in a + disjoint subset of the yi, i.e. 1 <= ij <= n and the ij are disjoint (in + particular, p <= n). + + f is applied to largs := arg1 .. argn and we need for recursive + calls to build the function + + g := [xp:Tip',...,x1:Ti1'](f a1 ... an) + + s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up) + + This is made possible by setting + a_k:=x_j if k=i_j for some j + a_k:=arg_k otherwise + + The type Tij' is Tij[yi(j-1)..y1 <- ai(j-1)..a1] +*) + +let x = Name default_dependent_ident + +let make_elim_fun (names,(nbfix,lv,n)) u largs = + let lu = List.firstn n largs in + let p = List.length lv in + let lyi = List.map fst lv in + let la = + List.map_i (fun q aq -> + (* k from the comment is q+1 *) + try mkRel (p+1-(List.index Int.equal (n-q) lyi)) + with Not_found -> aq) + 0 (List.map (Vars.lift p) lu) + in + fun i -> + match names.(i) with + | None -> None + | Some (minargs,ref) -> + let body = applist (mkEvalRef ref u, la) in + let g = + List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> + let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in + let tij' = Vars.substl (List.rev subst) tij in + let x = make_annot x Sorts.Relevant in (* TODO relevance *) + mkLambda (x,tij',c)) 1 body (List.rev lv) + in Some (minargs,g) + +(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: + do so that the reduction uses this extra information *) + +let dummy = mkProp +let vfx = Id.of_string "_expanded_fix_" +let vfun = Id.of_string "_eliminator_function_" +let venv = let open Context.Named.Declaration in + val_of_named_context [LocalAssum (make_annot vfx Sorts.Relevant, dummy); + LocalAssum (make_annot vfun Sorts.Relevant, dummy)] + +(* Mark every occurrence of substituted vars (associated to a function) + as a problem variable: an evar that can be instantiated either by + vfx (expanded fixpoint) or vfun (named function). *) +let substl_with_function subst sigma constr = + let evd = ref sigma in + let minargs = ref Evar.Map.empty in + let v = Array.of_list subst in + let rec subst_total k c = match EConstr.kind sigma c with + | Rel i when k < i -> + if i <= k + Array.length v then + match v.(i-k-1) with + | (fx, Some (min, ref)) -> + let sigma = !evd in + let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in + evd := sigma; + minargs := Evar.Map.add evk min !minargs; + Vars.lift k (mkEvar (evk, [|fx;ref|])) + | (fx, None) -> Vars.lift k fx + else mkRel (i - Array.length v) + | _ -> + map_with_binders sigma succ subst_total k c in + let c = subst_total 0 constr in + (c, !evd, !minargs) + +exception Partial + +(* each problem variable that cannot be made totally applied even by + reduction is solved by the expanded fix term. *) +let solve_arity_problem env sigma fxminargs c = + let evm = ref sigma in + let set_fix i = evm := Evd.define i (mkVar vfx) !evm in + let rec check strict c = + let c' = whd_betaiotazeta sigma c in + let (h,rcargs) = decompose_app_vect sigma c' in + match EConstr.kind sigma h with + Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> + let minargs = Evar.Map.find i fxminargs in + if Array.length rcargs < minargs then + if strict then set_fix i + else raise Partial; + Array.iter (check strict) rcargs + | (Var _|Const _) when isEvalRef env sigma h -> + (let ev, u = destEvalRefU sigma h in + match reference_opt_value env sigma ev u with + | Some h' -> + let bak = !evm in + (try Array.iter (check false) rcargs + with Partial -> + evm := bak; + check strict (mkApp(h',rcargs))) + | None -> Array.iter (check strict) rcargs) + | _ -> EConstr.iter sigma (check strict) c' in + check true c; + !evm + +let substl_checking_arity env subst sigma c = + (* we initialize the problem: *) + let body,sigma,minargs = substl_with_function subst sigma c in + (* we collect arity constraints *) + let sigma' = solve_arity_problem env sigma minargs body in + (* we propagate the constraints: solved problems are substituted; + the other ones are replaced by the function symbol *) + let rec nf_fix c = match EConstr.kind sigma c with + | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> + (* FIXME: find a less hackish way of doing this *) + begin match EConstr.kind sigma' c with + | Evar _ -> f + | c -> EConstr.of_kind c + end + | _ -> EConstr.map sigma nf_fix c + in + nf_fix body + +type fix_reduction_result = NotReducible | Reduced of (constr * constr list) + +let reduce_fix whdfun sigma fix stack = + match fix_recarg fix (Stack.append_app_list stack Stack.empty) with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = whdfun sigma recarg in + let stack' = List.assign stack recargnum (applist recarg') in + (match EConstr.kind sigma recarg'hd with + | Construct _ -> Reduced (contract_fix sigma fix, stack') + | _ -> NotReducible) + +let contract_fix_use_function env sigma f + ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = + let nbodies = Array.length recindices in + let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in + let lbodies = List.init nbodies make_Fi in + substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) + +let reduce_fix_use_function env sigma f whfun fix stack = + match fix_recarg fix (Stack.append_app_list stack Stack.empty) with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = + if EConstr.isRel sigma recarg then + (* The recarg cannot be a local def, no worry about the right env *) + (recarg, []) + else + whfun recarg in + let stack' = List.assign stack recargnum (applist recarg') in + (match EConstr.kind sigma recarg'hd with + | Construct _ -> + Reduced (contract_fix_use_function env sigma f fix,stack') + | _ -> NotReducible) + +let contract_cofix_use_function env sigma f + (bodynum,(_names,_,bodies as typedbodies)) = + let nbodies = Array.length bodies in + let make_Fi j = (mkCoFix(j,typedbodies), f j) in + let subbodies = List.init nbodies make_Fi in + substl_checking_arity env (List.rev subbodies) + sigma (nf_beta env sigma bodies.(bodynum)) + +let reduce_mind_case_use_function func env sigma mia = + match EConstr.kind sigma mia.mconstr with + | Construct ((ind_sp,i),u) -> + let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in + applist (mia.mlf.(i-1), real_cargs) + | CoFix (bodynum,(names,_,_) as cofix) -> + let build_cofix_name = + if isConst sigma func then + let minargs = List.length mia.mcargs in + fun i -> + if Int.equal i bodynum then Some (minargs,func) + else match names.(i).binder_name with + | Anonymous -> None + | Name id -> + (* In case of a call to another component of a block of + mutual inductive, try to reuse the global name if + the block was indeed initially built as a global + definition *) + let (kn, u) = destConst sigma func in + let kn = Constant.change_label kn (Label.of_id id) in + let cst = (kn, EInstance.kind sigma u) in + try match constant_opt_value_in env cst with + | None -> None + (* TODO: check kn is correct *) + | Some _ -> Some (minargs,mkConstU (kn, u)) + with Not_found -> None + else + fun _ -> None in + let cofix_def = + contract_cofix_use_function env sigma build_cofix_name cofix in + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + | _ -> assert false + + +let match_eval_ref env sigma constr stack = + match EConstr.kind sigma constr with + | Const (sp, u) -> + reduction_effect_hook env sigma sp + (lazy (EConstr.to_constr sigma (applist (constr,stack)))); + if is_evaluable env (EvalConstRef sp) then Some (EvalConst sp, u) else None + | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, EInstance.empty) + | Rel i -> Some (EvalRel i, EInstance.empty) + | Evar ev -> Some (EvalEvar ev, EInstance.empty) + | _ -> None + +let match_eval_ref_value env sigma constr stack = + match EConstr.kind sigma constr with + | Const (sp, u) -> + reduction_effect_hook env sigma sp + (lazy (EConstr.to_constr sigma (applist (constr,stack)))); + if is_evaluable env (EvalConstRef sp) then + let u = EInstance.kind sigma u in + Some (EConstr.of_constr (constant_value_in env (sp, u))) + else + None + | Proj (p, c) when not (Projection.unfolded p) -> + if is_evaluable env (EvalConstRef (Projection.constant p)) then + Some (mkProj (Projection.unfold p, c)) + else None + | Var id when is_evaluable env (EvalVarRef id) -> + env |> lookup_named id |> NamedDecl.get_value + | Rel n -> + env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) + | _ -> None + +let special_red_case env sigma whfun (ci, p, c, lf) = + let rec redrec s = + let (constr, cargs) = whfun s in + match match_eval_ref env sigma constr cargs with + | Some (ref, u) -> + (match reference_opt_value env sigma ref u with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case sigma gvalue then + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; + mci=ci; mlf=lf} + else + redrec (applist(gvalue, cargs))) + | None -> + if reducible_mind_case sigma constr then + reduce_mind_case sigma + {mP=p; mconstr=constr; mcargs=cargs; + mci=ci; mlf=lf} + else + raise Redelimination + in + redrec c + +let recargs = function + | EvalVar _ | EvalRel _ | EvalEvar _ -> None + | EvalConst c -> ReductionBehaviour.get (ConstRef c) + +let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = + (match EConstr.kind sigma recarg'hd with + | Construct _ -> + let proj_narg = npars + Projection.arg p in + Reduced (List.nth stack' proj_narg, stack) + | _ -> NotReducible) + +let reduce_proj env sigma whfun whfun' c = + let rec redrec s = + match EConstr.kind sigma s with + | Proj (proj, c) -> + let c' = try redrec c with Redelimination -> c in + let constr, cargs = whfun c' in + (match EConstr.kind sigma constr with + | Construct _ -> + let proj_narg = Projection.npars proj + Projection.arg proj in + List.nth cargs proj_narg + | _ -> raise Redelimination) + | Case (n,p,c,brs) -> + let c' = redrec c in + let p = (n,p,c',brs) in + (try special_red_case env sigma whfun' p + with Redelimination -> mkCase p) + | _ -> raise Redelimination + in redrec c + +let whd_nothing_for_iota env sigma s = + let rec whrec (x, stack as s) = + match EConstr.kind sigma x with + | Rel n -> + let open Context.Rel.Declaration in + (match lookup_rel n env with + | LocalDef (_,body,_) -> whrec (lift n body, stack) + | _ -> s) + | Var id -> + let open Context.Named.Declaration in + (match lookup_named id env with + | LocalDef (_,body,_) -> whrec (body, stack) + | _ -> s) + | Evar ev -> s + | Meta ev -> + (try whrec (Evd.meta_value sigma ev, stack) + with Not_found -> s) + | Const (const, u) -> + let u = EInstance.kind sigma u in + (match constant_opt_value_in env (const, u) with + | Some body -> whrec (EConstr.of_constr body, stack) + | None -> s) + | LetIn (_,b,_,c) -> stacklam whrec [b] sigma c stack + | Cast (c,_,_) -> whrec (c, stack) + | App (f,cl) -> whrec (f, Stack.append_app cl stack) + | Lambda (na,t,c) -> + (match Stack.decomp stack with + | Some (a,m) -> stacklam whrec [a] sigma c m + | _ -> s) + + | x -> s + in + EConstr.decompose_app sigma (Stack.zip sigma (whrec (s,Stack.empty))) + +(* [red_elim_const] contracts iota/fix/cofix redexes hidden behind + constants by keeping the name of the constants in the recursive calls; + it fails if no redex is around *) + +let rec red_elim_const env sigma ref u largs = + let nargs = List.length largs in + let largs, unfold_anyway, unfold_nonelim, nocase = + match recargs ref with + | None -> largs, false, false, false + | Some (_,n,f) when nargs < n || List.mem `ReductionNeverUnfold f -> raise Redelimination + | Some (x::l,_,_) when nargs <= List.fold_left max x l -> raise Redelimination + | Some (l,n,f) -> + let is_empty = match l with [] -> true | _ -> false in + reduce_params env sigma largs l, + n >= 0 && is_empty && nargs >= n, + n >= 0 && not is_empty && nargs >= n, + List.mem `ReductionDontExposeCase f + in + try match reference_eval env sigma ref with + | EliminationCases n when nargs >= n -> + let c = reference_value env sigma ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_simpl_stack env sigma in + (special_red_case env sigma whfun (EConstr.destCase sigma c'), lrest), nocase + | EliminationProj n when nargs >= n -> + let c = reference_value env sigma ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_construct_stack env sigma in + let whfun' = whd_simpl_stack env sigma in + (reduce_proj env sigma whfun whfun' c', lrest), nocase + | EliminationFix (min,minfxargs,infos) when nargs >= min -> + let c = reference_value env sigma ref u in + let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in + let whfun = whd_construct_stack env sigma in + (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with + | NotReducible -> raise Redelimination + | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) + | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> + let rec descend (ref,u) args = + let c = reference_value env sigma ref u in + if evaluable_reference_eq sigma ref refgoal then + (c,args) + else + let c', lrest = whd_betalet_stack sigma (applist(c,args)) in + descend (destEvalRefU sigma c') lrest in + let (_, midargs as s) = descend (ref,u) largs in + let d, lrest = whd_nothing_for_iota env sigma (applist s) in + let f = make_elim_fun refinfos u midargs in + let whfun = whd_construct_stack env sigma in + (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with + | NotReducible -> raise Redelimination + | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) + | NotAnElimination when unfold_nonelim -> + let c = reference_value env sigma ref u in + (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + | _ -> raise Redelimination + with Redelimination when unfold_anyway -> + let c = reference_value env sigma ref u in + (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + +and reduce_params env sigma stack l = + let len = List.length stack in + List.fold_left (fun stack i -> + if len <= i then raise Redelimination + else + let arg = List.nth stack i in + let rarg = whd_construct_stack env sigma arg in + match EConstr.kind sigma (fst rarg) with + | Construct _ -> List.assign stack i (applist rarg) + | _ -> raise Redelimination) + stack l + + +(* reduce to whd normal form or to an applied constant that does not hide + a reducible iota/fix/cofix redex (the "simpl" tactic) *) + +and whd_simpl_stack env sigma = + let rec redrec s = + let (x, stack) = decompose_app_vect sigma s in + let stack = Array.to_list stack in + let s' = (x, stack) in + match EConstr.kind sigma x with + | Lambda (na,t,c) -> + (match stack with + | [] -> s' + | a :: rest -> redrec (beta_applist sigma (x, stack))) + | LetIn (n,b,t,c) -> redrec (applist (Vars.substl [b] c, stack)) + | App (f,cl) -> redrec (applist(f, (Array.to_list cl)@stack)) + | Cast (c,_,_) -> redrec (applist(c, stack)) + | Case (ci,p,c,lf) -> + (try + redrec (applist(special_red_case env sigma redrec (ci,p,c,lf), stack)) + with + Redelimination -> s') + | Fix fix -> + (try match reduce_fix (whd_construct_stack env) sigma fix stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s' + with Redelimination -> s') + + | Proj (p, c) -> + (try + let unf = Projection.unfolded p in + if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then + let npars = Projection.npars p in + (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with + | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> + (* simpl never *) s' + | false, Some (l, n, f) when not (List.is_empty l) -> + let l' = List.map_filter (fun i -> + let idx = (i - (npars + 1)) in + if idx < 0 then None else Some idx) l in + let stack = reduce_params env sigma stack l' in + (match reduce_projection env sigma p ~npars + (whd_construct_stack env sigma c) stack + with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + | _ -> + match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + else s' + with Redelimination -> s') + + | _ -> + match match_eval_ref env sigma x stack with + | Some (ref, u) -> + (try + let sapp, nocase = red_elim_const env sigma ref u stack in + let hd, _ as s'' = redrec (applist(sapp)) in + let rec is_case x = match EConstr.kind sigma x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if nocase && is_case hd then raise Redelimination + else s'' + with Redelimination -> s') + | None -> s' + in + redrec + +(* reduce until finding an applied constructor or fail *) + +and whd_construct_stack env sigma s = + let (constr, cargs as s') = whd_simpl_stack env sigma s in + if reducible_mind_case sigma constr then s' + else match match_eval_ref env sigma constr cargs with + | Some (ref, u) -> + (match reference_opt_value env sigma ref u with + | None -> raise Redelimination + | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) + | _ -> raise Redelimination + +(************************************************************************) +(* Special Purpose Reduction Strategies *) + +(* Red reduction tactic: one step of delta reduction + full + beta-iota-fix-cofix-zeta-cast at the head of the conclusion of a + sequence of products; fails if no delta redex is around +*) + +let try_red_product env sigma c = + let simpfun c = clos_norm_flags betaiotazeta env sigma c in + let rec redrec env x = + let x = whd_betaiota sigma x in + match EConstr.kind sigma x with + | App (f,l) -> + (match EConstr.kind sigma f with + | Fix fix -> + let stack = Stack.append_app l Stack.empty 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 (Stack.zip sigma (f,stack'))) + | _ -> simpfun (mkApp (redrec env f, l))) + | Cast (c,_,_) -> redrec env c + | Prod (x,a,b) -> + let open Context.Rel.Declaration in + mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) + | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) + | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) + | Proj (p, c) -> + let c' = + match EConstr.kind sigma c with + | Construct _ -> c + | _ -> redrec env c + in + let npars = Projection.npars p in + (match reduce_projection env sigma p ~npars (whd_betaiotazeta_stack sigma c') [] with + | Reduced s -> simpfun (applist s) + | NotReducible -> raise Redelimination) + | _ -> + (match match_eval_ref env sigma x [] with + | Some (ref, u) -> + (* TO DO: re-fold fixpoints after expansion *) + (* to get true one-step reductions *) + (match reference_opt_value env sigma ref u with + | None -> raise Redelimination + | Some c -> c) + | _ -> raise Redelimination) + in redrec env c + +let red_product env sigma c = + try try_red_product env sigma c + with Redelimination -> user_err (str "No head constant to reduce.") + +(* +(* This old version of hnf uses betadeltaiota instead of itself (resp + whd_construct_state) to reduce the argument of Case (resp Fix); + The new version uses the "simpl" strategy instead. For instance, + + Variable n:nat. + Eval hnf in match (plus (S n) O) with S n => n | _ => O end. + + returned + + (fix plus (n m : nat) {struct n} : nat := + match n with + | O => m + | S p => S (plus p m) + end) n 0 + + while the new version returns (plus n O) + *) + +let whd_simpl_orelse_delta_but_fix_old env sigma c = + let whd_all = whd_all_state env sigma in + let rec redrec (x, stack as s) = + match kind_of_term x with + | Lambda (na,t,c) -> + (match decomp_stack stack with + | None -> s + | Some (a,rest) -> stacklam redrec [a] c rest) + | LetIn (n,b,t,c) -> stacklam redrec [b] c stack + | App (f,cl) -> redrec (f, append_stack cl stack) + | Cast (c,_,_) -> redrec (c, stack) + | Case (ci,p,d,lf) -> + (try + redrec (special_red_case env sigma whd_all (ci,p,d,lf), stack) + with Redelimination -> + s) + | Fix fix -> + (match reduce_fix whd_all fix stack with + | Reduced s' -> redrec s' + | NotReducible -> s) + | _ when isEvalRef env x -> + let ref = destEvalRef x in + (try + redrec (red_elim_const env sigma ref stack) + with Redelimination -> + match reference_opt_value env sigma ref with + | Some c -> + (match kind_of_term (strip_lam c) with + | CoFix _ | Fix _ -> s + | _ -> redrec (c, stack)) + | None -> s) + | _ -> s + in app_stack (redrec (c, empty_stack)) +*) + +let whd_simpl_stack = + if Flags.profile then + let key = CProfile.declare_profile "whd_simpl_stack" in + CProfile.profile3 key whd_simpl_stack + else whd_simpl_stack + +(* Same as [whd_simpl] but also reduces constants that do not hide a + reducible fix, but does this reduction of constants only until it + immediately hides a non reducible fix or a cofix *) + +let whd_simpl_orelse_delta_but_fix env sigma c = + let rec redrec s = + let (constr, stack as s') = whd_simpl_stack env sigma s in + match match_eval_ref_value env sigma constr stack with + | Some c -> + (match EConstr.kind sigma (snd (decompose_lam sigma c)) with + | CoFix _ | Fix _ -> s' + | Proj (p,t) when + (match EConstr.kind sigma constr with + | Const (c', _) -> Constant.equal (Projection.constant p) c' + | _ -> false) -> + let npars = Projection.npars p in + if List.length stack <= npars then + (* Do not show the eta-expanded form *) + s' + else redrec (applist (c, stack)) + | _ -> redrec (applist(c, stack))) + | None -> s' + in + let simpfun = clos_norm_flags betaiota env sigma in + simpfun (applist (redrec c)) + +let hnf_constr = whd_simpl_orelse_delta_but_fix + +(* The "simpl" reduction tactic *) + +let whd_simpl env sigma c = + applist (whd_simpl_stack env sigma c) + +let simpl env sigma c = strong whd_simpl env sigma c + +(* Reduction at specific subterms *) + +let matches_head env sigma c t = + match EConstr.kind sigma t with + | App (f,_) -> Constr_matching.matches env sigma c f + | Proj (p, _) -> Constr_matching.matches env sigma c (mkConstU (Projection.constant p, EInstance.empty)) + | _ -> raise Constr_matching.PatternMatchingFailure + +(** FIXME: Specific function to handle projections: it ignores what happens on the + parameters. This is a temporary fix while rewrite etc... are not up to equivalence + of the projection and its eta expanded form. +*) +let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = + match EConstr.kind sigma c with + | Proj (p, r) -> (* Treat specially for partial applications *) + let t = Retyping.expand_projection env sigma p r [] in + let hdf, al = destApp sigma t in + let a = al.(Array.length al - 1) in + let app = (mkApp (hdf, Array.sub al 0 (Array.length al - 1))) in + let app' = f acc app in + let a' = f acc a in + (match EConstr.kind sigma app' with + | App (hdf', al') when hdf' == hdf -> + (* Still the same projection, we ignore the change in parameters *) + mkProj (p, a') + | _ -> mkApp (app', [| a' |])) + | _ -> map_constr_with_binders_left_to_right sigma g f acc c + +let e_contextually byhead (occs,c) f = begin fun env sigma t -> + let (nowhere_except_in,locs) = Locusops.convert_occs occs in + let maxocc = List.fold_right max locs 0 in + let pos = ref 1 in + (* FIXME: we do suspicious things with this evarmap *) + let evd = ref sigma in + let rec traverse nested (env,c as envc) t = + if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t + else + try + let subst = + if byhead then matches_head env sigma c t + else Constr_matching.matches env sigma c t in + let ok = + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then begin + if Option.has_some nested then + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + (* Skip inner occurrences for stable counting of occurrences *) + if locs != [] then + ignore (traverse_below (Some (!pos-1)) envc t); + let (evm, t) = (f subst) env !evd t in + (evd := evm; t) + end + else + traverse_below nested envc t + with Constr_matching.PatternMatchingFailure -> + traverse_below nested envc t + and traverse_below nested envc t = + (* when byhead, find other occurrences without matching again partial + application with same head *) + match EConstr.kind !evd t with + | App (f,l) when byhead -> mkApp (f, Array.map_left (traverse nested envc) l) + | Proj (p,c) when byhead -> mkProj (p,traverse nested envc c) + | _ -> + change_map_constr_with_binders_left_to_right + (fun d (env,c) -> (push_rel d env,lift_pattern 1 c)) + (traverse nested) envc sigma t + in + let t' = traverse None (env,c) t in + if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; + (!evd, t') + end + +let contextually byhead occs f env sigma t = + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) + +(* linear bindings (following pretty-printer) of the value of name in c. + * n is the number of the next occurrence of name. + * ol is the occurrence list to find. *) + +let match_constr_evaluable_ref sigma c evref = + match EConstr.kind sigma c, evref with + | Const (c,u), EvalConstRef c' when Constant.equal c c' -> Some u + | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty + | _, _ -> None + +let substlin env sigma evalref n (nowhere_except_in,locs) c = + let maxocc = List.fold_right max locs 0 in + let pos = ref n in + assert (List.for_all (fun x -> x >= 0) locs); + let value u = value_of_evaluable_ref env evalref u in + let rec substrec () c = + if nowhere_except_in && !pos > maxocc then c + else + match match_constr_evaluable_ref sigma c evalref with + | Some u -> + let ok = + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then value u else c + | None -> + map_constr_with_binders_left_to_right sigma + (fun _ () -> ()) + substrec () c + in + let t' = substrec () c in + (!pos, t') + +let string_of_evaluable_ref env = function + | EvalVarRef id -> Id.to_string id + | EvalConstRef kn -> + string_of_qualid + (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) + +let unfold env sigma name c = + if is_evaluable env name then + clos_norm_flags (unfold_red name) env sigma c + else + user_err Pp.(str (string_of_evaluable_ref env name^" is opaque.")) + +(* [unfoldoccs : (readable_constraints -> (int list * full_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 occurrences. + * Performs a betaiota reduction after unfolding. *) +let unfoldoccs env sigma (occs,name) c = + let unfo nowhere_except_in locs = + let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in + if Int.equal nbocc 1 then + user_err Pp.(str ((string_of_evaluable_ref env name)^" does not occur.")); + let rest = List.filter (fun o -> o >= nbocc) locs in + let () = match rest with + | [] -> () + | _ -> error_invalid_occurrence rest + in + nf_betaiotazeta env sigma uc + in + match occs with + | NoOccurrences -> c + | AllOccurrences -> unfold env sigma name c + | OnlyOccurrences l -> unfo true l + | AllOccurrencesBut l -> unfo false l + | AtLeastOneOccurrence -> unfo false [] + +(* 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 -> user_err Pp.(str "Not reducible.") in + (* Reason first on the beta-iota-zeta normal form of the constant as + unfold produces it, so that the "unfold f; fold f" configuration works + to refold fix expressions *) + let a = subst_term sigma (clos_norm_flags unfold_side_red env sigma rcom) c in + if not (EConstr.eq_constr sigma a c) then + Vars.subst1 com a + else + (* Then reason on the non beta-iota-zeta form for compatibility - + even if it is probably a useless configuration *) + let a = subst_term sigma rcom c in + Vars.subst1 com a + +let fold_commands cl env sigma c = + List.fold_right (fun com c -> fold_one_com com env sigma c) (List.rev cl) c + + +(* call by value reduction functions *) +let cbv_norm_flags flags env sigma t = + cbv_norm (create_cbv_infos flags env sigma) t + +let cbv_beta = cbv_norm_flags beta +let cbv_betaiota = cbv_norm_flags betaiota +let cbv_betadeltaiota env sigma = cbv_norm_flags all 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) (c, sigma) = + let ta = Retyping.get_type_of env sigma a in + let na = named_hd env sigma ta Anonymous in + let na = make_annot na Sorts.Relevant in (* TODO relevance *) + if occur_meta sigma ta then user_err Pp.(str "Cannot find a type for the generalisation."); + if occur_meta sigma a then + mkLambda (na,ta,c), sigma + else + let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in + mkLambda (na,ta,c'), sigma' + +let pattern_occs loccs_trm = begin fun env sigma c -> + let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in + try + let _ = Typing.unsafe_type_of env sigma abstr_trm in + (sigma, applist(abstr_trm, List.map snd loccs_trm)) + with Type_errors.TypeError (env',t) -> + raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) + end + +(* Used in several tactics. *) + +let check_privacy env ind = + let spec = Inductive.lookup_mind_specif env (fst ind) in + if Inductive.is_private spec then + user_err (str "case analysis on a private type.") + else ind + +let check_not_primitive_record env ind = + let spec = Inductive.lookup_mind_specif env (fst ind) in + if Inductive.is_primitive_record spec then + user_err (str "case analysis on a primitive record type: " ++ + str "use projections or let instead.") + else ind + +(* 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 t = hnf_constr env sigma t in + match EConstr.kind sigma (fst (decompose_app_vect sigma t)) with + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) + | Prod (n,ty,t') -> + let open Context.Rel.Declaration in + if allow_product then + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) + else + user_err (str"Not an inductive definition.") + | _ -> + (* Last chance: we allow to bypass the Opaque flag (as it + was partially the case between V5.10 and V8.1 *) + let t' = whd_all env sigma t in + match EConstr.kind sigma (fst (decompose_app_vect sigma t')) with + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) + | _ -> user_err (str"Not an inductive product.") + in + elimrec env t [] + +let reduce_to_quantified_ind env sigma c = reduce_to_ind_gen true env sigma c +let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma c + +let find_hnf_rectype env sigma t = + let ind,t = reduce_to_atomic_ind env sigma t in + ind, snd (decompose_app sigma t) + +(* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta] + or raise [NotStepReducible] if not a weak-head redex *) + +exception NotStepReducible + +let one_step_reduce env sigma c = + let rec redrec (x, stack) = + match EConstr.kind sigma x with + | Lambda (n,t,c) -> + (match stack with + | [] -> raise NotStepReducible + | a :: rest -> (Vars.subst1 a c, rest)) + | App (f,cl) -> redrec (f, (Array.to_list cl)@stack) + | LetIn (_,f,_,cl) -> (Vars.subst1 f cl,stack) + | Cast (c,_,_) -> redrec (c,stack) + | Case (ci,p,c,lf) -> + (try + (special_red_case env sigma (whd_simpl_stack env sigma) + (ci,p,c,lf), stack) + with Redelimination -> raise NotStepReducible) + | Fix fix -> + (try match reduce_fix (whd_construct_stack env) sigma fix stack with + | Reduced s' -> s' + | NotReducible -> raise NotStepReducible + with Redelimination -> raise NotStepReducible) + | _ when isEvalRef env sigma x -> + let ref,u = destEvalRefU sigma x in + (try + fst (red_elim_const env sigma ref u stack) + with Redelimination -> + match reference_opt_value env sigma ref u with + | Some d -> (d, stack) + | None -> raise NotStepReducible) + + | _ -> raise NotStepReducible + in + applist (redrec (c,[])) + +let error_cannot_recognize ref = + user_err + (str "Cannot recognize a statement based on " ++ + Nametab.pr_global_env Id.Set.empty ref ++ str".") + +let reduce_to_ref_gen allow_product env sigma ref t = + if isIndRef ref then + let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in + begin match ref with + | IndRef mind' when eq_ind mind mind' -> t + | _ -> error_cannot_recognize ref + end + else + (* lazily reduces to match the head of [t] with the expected [ref] *) + let rec elimrec env t l = + let c, _ = decompose_app_vect sigma t in + match EConstr.kind sigma c with + | Prod (n,ty,t') -> + if allow_product then + let open Context.Rel.Declaration in + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) + else + error_cannot_recognize ref + | _ -> + try + if GlobRef.equal (fst (global_of_constr sigma c)) ref + then it_mkProd_or_LetIn t l + else raise Not_found + with Not_found -> + try + let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in + elimrec env t' l + with NotStepReducible -> error_cannot_recognize ref + 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 0000000000..0887d0efd3 --- /dev/null +++ b/pretyping/tacred.mli @@ -0,0 +1,110 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open Evd +open EConstr +open Reductionops +open Pattern +open Locus +open Univ +open Ltac_pretype + +type reduction_tactic_error = + InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error) + +exception ReductionTacticError of reduction_tactic_error + +(** {6 Reduction functions associated to tactics. } *) + +(** Evaluable global reference *) + +val is_evaluable : Environ.env -> evaluable_global_reference -> bool + +val error_not_evaluable : GlobRef.t -> 'a + +val evaluable_of_global_reference : + Environ.env -> GlobRef.t -> evaluable_global_reference + +val global_of_evaluable_reference : + evaluable_global_reference -> GlobRef.t + +exception Redelimination + +(** Red (raise user error if nothing reducible) *) +val red_product : reduction_function + +(** Red (raise Redelimination if nothing reducible) *) +val try_red_product : reduction_function + +(** Simpl *) +val simpl : reduction_function + +(** Simpl only at the head *) +val whd_simpl : reduction_function + +(** Hnf: like whd_simpl but force delta-reduction of constants that do + not immediately hide a non reducible fix or cofix *) +val hnf_constr : reduction_function + +(** Unfold *) +val unfoldn : + (occurrences * evaluable_global_reference) list -> reduction_function + +(** Fold *) +val fold_commands : constr list -> reduction_function + +(** Pattern *) +val pattern_occs : (occurrences * constr) list -> e_reduction_function + +(** Rem: Lazy strategies are defined in Reduction *) + +(** Call by value strategy (uses Closures) *) +val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function + val cbv_beta : reduction_function + val cbv_betaiota : 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 * EInstance.t) * 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 * EInstance.t) * types + +(** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form + [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) +val reduce_to_quantified_ref : + env -> evar_map -> GlobRef.t -> types -> types + +val reduce_to_atomic_ref : + env -> evar_map -> GlobRef.t -> types -> types + +val find_hnf_rectype : + env -> evar_map -> types -> (inductive * EInstance.t) * constr list + +val contextually : bool -> occurrences * constr_pattern -> + (patvar_map -> reduction_function) -> reduction_function + +val e_contextually : bool -> occurrences * constr_pattern -> + (patvar_map -> e_reduction_function) -> e_reduction_function + +(** Returns the same inductive if it is allowed for pattern-matching + raises an error otherwise. **) +val check_privacy : env -> inductive puniverses -> inductive puniverses + +(** Returns the same inductive if it is not a primitive record + raises an error otherwise. **) +val check_not_primitive_record : env -> inductive puniverses -> inductive puniverses diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml new file mode 100644 index 0000000000..ee27aea93f --- /dev/null +++ b/pretyping/typeclasses.ml @@ -0,0 +1,313 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Names +open Globnames +open Term +open Constr +open Vars +open Evd +open Util +open Typeclasses_errors +open Context.Rel.Declaration + +(*i*) + +(* Core typeclasses hints *) +type 'a hint_info_gen = + { hint_priority : int option; + hint_pattern : 'a option } + +type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen + +let get_typeclasses_unique_solutions = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"check that typeclasses proof search returns unique solutions" + ~key:["Typeclasses";"Unique";"Solutions"] + ~value:false + +let (set_typeclass_transparency, set_typeclass_transparency_hook) = Hook.make () +let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency gr local c + +let (classes_transparent_state, classes_transparent_state_hook) = Hook.make () +let classes_transparent_state () = Hook.get classes_transparent_state () + +let get_solve_one_instance, solve_one_instance_hook = Hook.make () + +let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t = + Hook.get get_solve_one_instance env evm t unique + +type direction = Forward | Backward + +(* This module defines type-classes *) +type typeclass = { + (* Universe quantification *) + cl_univs : Univ.AUContext.t; + + (* The class implementation *) + cl_impl : GlobRef.t; + + (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) + cl_context : GlobRef.t option list * Constr.rel_context; + + (* Context of definitions and properties on defs, will not be shared *) + cl_props : Constr.rel_context; + + (* The method implementaions as projections. *) + cl_projs : (Name.t * (direction * hint_info) option + * Constant.t option) list; + + cl_strict : bool; + + cl_unique : bool; +} + +type typeclasses = typeclass GlobRef.Map.t + +type instance = { + is_class: GlobRef.t; + is_info: hint_info; + (* Sections where the instance should be redeclared, + None for discard, Some 0 for none. *) + is_global: int option; + is_impl: GlobRef.t; +} + +type instances = (instance GlobRef.Map.t) GlobRef.Map.t + +let instance_impl is = is.is_impl + +let hint_priority is = is.is_info.hint_priority + +(* + * states management + *) + +let classes : typeclasses ref = Summary.ref GlobRef.Map.empty ~name:"classes" +let instances : instances ref = Summary.ref GlobRef.Map.empty ~name:"instances" + +let typeclass_univ_instance (cl, u) = + assert (Univ.AUContext.size cl.cl_univs == Univ.Instance.length u); + let subst_ctx c = Context.Rel.map (subst_instance_constr u) c in + { cl with cl_context = on_snd subst_ctx cl.cl_context; + cl_props = subst_ctx cl.cl_props} + +let class_info env sigma c = + try GlobRef.Map.find c !classes + with Not_found -> + not_a_class env sigma (EConstr.of_constr (printable_constr_of_global c)) + +let global_class_of_constr env sigma c = + try let gr, u = Termops.global_of_constr sigma c in + GlobRef.Map.find gr !classes, u + with Not_found -> not_a_class env sigma c + +let dest_class_app env sigma c = + let cl, args = EConstr.decompose_app sigma c in + global_class_of_constr env sigma cl, (List.map EConstr.Unsafe.to_constr args) + +let dest_class_arity env sigma c = + let open EConstr in + let rels, c = decompose_prod_assum sigma c in + rels, dest_class_app env sigma c + +let class_of_constr env sigma c = + try Some (dest_class_arity env sigma c) + with e when CErrors.noncritical e -> None + +let is_class_constr sigma c = + try let gr, u = Termops.global_of_constr sigma c in + GlobRef.Map.mem gr !classes + with Not_found -> false + +let rec is_class_type evd c = + let c, _ = Termops.decompose_app_vect evd c in + match EConstr.kind evd c with + | Prod (_, _, t) -> is_class_type evd t + | Cast (t, _, _) -> is_class_type evd t + | _ -> is_class_constr evd c + +let is_class_evar evd evi = + is_class_type evd evi.Evd.evar_concl + +let is_class_constr sigma c = + try let gr, u = Termops.global_of_constr sigma c in + GlobRef.Map.mem gr !classes + with Not_found -> false + +let rec is_maybe_class_type evd c = + let c, _ = Termops.decompose_app_vect evd c in + match EConstr.kind evd c with + | Prod (_, _, t) -> is_maybe_class_type evd t + | Cast (t, _, _) -> is_maybe_class_type evd t + | Evar _ -> true + | _ -> is_class_constr evd c + +let () = Hook.set Evd.is_maybe_typeclass_hook (fun evd c -> is_maybe_class_type evd (EConstr.of_constr c)) + +let load_class cl = + classes := GlobRef.Map.add cl.cl_impl cl !classes + +(** Build the subinstances hints. *) + +let check_instance env sigma c = + try + let (evd, c) = resolve_one_typeclass env sigma + (Retyping.get_type_of env sigma c) in + not (Evd.has_undefined evd) + with e when CErrors.noncritical e -> false + +let build_subclasses ~check env sigma glob { hint_priority = pri } = + let _id = Nametab.basename_of_global glob in + let _next_id = + let i = ref (-1) in + (fun () -> incr i; + Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) + in + let ty, ctx = Typeops.type_of_global_in_context env glob in + let inst, ctx = UnivGen.fresh_instance_from ctx None in + let ty = Vars.subst_instance_constr inst ty in + let ty = EConstr.of_constr ty in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let rec aux pri c ty path = + match class_of_constr env sigma ty with + | None -> [] + | Some (rels, ((tc,u), args)) -> + let instapp = + Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) + in + let instapp = EConstr.Unsafe.to_constr instapp in + let projargs = Array.of_list (args @ [instapp]) in + let projs = List.map_filter + (fun (n, b, proj) -> + match b with + | None -> None + | Some (Backward, _) -> None + | Some (Forward, info) -> + let proj = Option.get proj in + let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in + let u = EConstr.EInstance.kind sigma u in + let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in + if check && check_instance env sigma (EConstr.of_constr body) then None + else + let newpri = + match pri, info.hint_priority with + | Some p, Some p' -> Some (p + p') + | Some p, None -> Some (p + 1) + | _, _ -> None + in + Some (ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs + in + let declare_proj hints (cref, info, body) = + let path' = cref :: path in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in + let rest = aux pri body ty path' in + hints @ (path', info, body) :: rest + in List.fold_left declare_proj [] projs + in + let term = Constr.mkRef (glob, inst) in + (*FIXME subclasses should now get substituted for each particular instance of + the polymorphic superclass *) + aux pri term ty [glob] + +(* + * interface functions + *) + +let load_instance inst = + let insts = + try GlobRef.Map.find inst.is_class !instances + with Not_found -> GlobRef.Map.empty in + let insts = GlobRef.Map.add inst.is_impl inst insts in + instances := GlobRef.Map.add inst.is_class insts !instances + +let remove_instance inst = + let insts = + try GlobRef.Map.find inst.is_class !instances + with Not_found -> assert false in + let insts = GlobRef.Map.remove inst.is_impl insts in + instances := GlobRef.Map.add inst.is_class insts !instances + + +let instance_constructor (cl,u) args = + let lenpars = List.count is_local_assum (snd cl.cl_context) in + let open EConstr in + let pars = fst (List.chop lenpars args) in + match cl.cl_impl with + | IndRef ind -> + let ind = ind, u in + (Some (applist (mkConstructUi (ind, 1), args)), + applist (mkIndU ind, pars)) + | ConstRef cst -> + let cst = cst, u in + let term = match args with + | [] -> None + | _ -> Some (List.last args) + in + (term, applist (mkConstU cst, pars)) + | _ -> assert false + +let typeclasses () = GlobRef.Map.fold (fun _ l c -> l :: c) !classes [] + +let cmap_elements c = GlobRef.Map.fold (fun k v acc -> v :: acc) c [] + +let instances_of c = + try cmap_elements (GlobRef.Map.find c.cl_impl !instances) with Not_found -> [] + +let all_instances () = + GlobRef.Map.fold (fun k v acc -> + GlobRef.Map.fold (fun k v acc -> v :: acc) v acc) + !instances [] + +let instances env sigma r = + let cl = class_info env sigma r in instances_of cl + +let is_class gr = + GlobRef.Map.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes + +open Evar_kinds +type evar_filter = Evar.t -> Evar_kinds.t Lazy.t -> bool + +let make_unresolvables filter evd = + let tcs = Evd.get_typeclass_evars evd in + Evd.set_typeclass_evars evd (Evar.Set.filter (fun x -> not (filter x)) tcs) + +let all_evars _ _ = true +let all_goals _ source = + match Lazy.force source with + | VarInstance _ | GoalEvar -> true + | _ -> false + +let no_goals ev evi = not (all_goals ev evi) +let no_goals_or_obligations _ source = + match Lazy.force source with + | VarInstance _ | GoalEvar | QuestionMark _ -> false + | _ -> true + +let has_typeclasses filter evd = + let tcs = get_typeclass_evars evd in + let check ev = filter ev (lazy (snd (Evd.find evd ev).evar_source)) in + Evar.Set.exists check tcs + +let get_solve_all_instances, solve_all_instances_hook = Hook.make () + +let solve_all_instances env evd filter unique split fail = + Hook.get get_solve_all_instances env evd filter unique split fail + +(** Profiling resolution of typeclasses *) +(* let solve_classeskey = CProfile.declare_profile "solve_typeclasses" *) +(* let solve_problem = CProfile.profile5 solve_classeskey solve_problem *) + +let resolve_typeclasses ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ()) + ?(split=true) ?(fail=true) env evd = + if not (has_typeclasses filter evd) then evd + else solve_all_instances env evd filter unique split fail diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli new file mode 100644 index 0000000000..e42b82c51f --- /dev/null +++ b/pretyping/typeclasses.mli @@ -0,0 +1,140 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Evd +open Environ + +type direction = Forward | Backward + +(* Core typeclasses hints *) +type 'a hint_info_gen = + { hint_priority : int option; + hint_pattern : 'a option } + +type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen + +(** This module defines type-classes *) +type typeclass = { + cl_univs : Univ.AUContext.t; + (** The toplevel universe quantification in which the typeclass lives. In + particular, [cl_props] and [cl_context] are quantified over it. *) + + cl_impl : GlobRef.t; + (** The class implementation: a record parameterized by the context with defs in it or a definition if + the class is a singleton. This acts as the class' global identifier. *) + + cl_context : GlobRef.t option list * Constr.rel_context; + (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. + The global reference gives a direct link to the class itself. *) + + cl_props : Constr.rel_context; + (** Context of definitions and properties on defs, will not be shared *) + + cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; + (** The methods implementations of the typeclass as projections. + Some may be undefinable due to sorting restrictions or simply undefined if + no name is provided. The [int option option] indicates subclasses whose hint has + the given priority. *) + + cl_strict : bool; + (** Whether we use matching or full unification during resolution *) + + cl_unique : bool; + (** Whether we can assume that instances are unique, which allows + no backtracking and sharing of resolution. *) +} + +type instance = { + is_class: GlobRef.t; + is_info: hint_info; + (* Sections where the instance should be redeclared, + None for discard, Some 0 for none. *) + is_global: int option; + is_impl: GlobRef.t; +} + +val instances : env -> evar_map -> GlobRef.t -> instance list +val typeclasses : unit -> typeclass list +val all_instances : unit -> instance list + +val load_class : typeclass -> unit + +val load_instance : instance -> unit +val remove_instance : instance -> unit + +val class_info : env -> evar_map -> GlobRef.t -> typeclass (** raises a UserError if not a class *) + + +(** These raise a UserError if not a class. + Caution: the typeclass structures is not instantiated w.r.t. the universe instance. + This is done separately by typeclass_univ_instance. *) +val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.EInstance.t) * constr list + +(** Get the instantiated typeclass structure for a given universe instance. *) +val typeclass_univ_instance : typeclass Univ.puniverses -> typeclass + +(** Just return None if not a class *) +val class_of_constr : env -> evar_map -> EConstr.constr -> + (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option + +val instance_impl : instance -> GlobRef.t + +val hint_priority : instance -> int option + +val is_class : GlobRef.t -> bool + +(** Returns the term and type for the given instance of the parameters and fields + of the type class. *) + +val instance_constructor : typeclass EConstr.puniverses -> EConstr.t list -> + EConstr.t option * EConstr.t + +(** Filter which evars to consider for resolution. *) +type evar_filter = Evar.t -> Evar_kinds.t Lazy.t -> bool +val all_evars : evar_filter +val all_goals : evar_filter +val no_goals : evar_filter +val no_goals_or_obligations : evar_filter + +(** Resolvability. + Only undefined evars can be marked or checked for resolvability. + They represent type-class search roots. + + A resolvable evar is an evar the type-class engine may try to solve + An unresolvable evar is an evar the type-class engine will NOT try to solve +*) + +val make_unresolvables : (Evar.t -> bool) -> evar_map -> evar_map + +val is_class_evar : evar_map -> evar_info -> bool +val is_class_type : evar_map -> EConstr.types -> bool + +val resolve_typeclasses : ?filter:evar_filter -> ?unique:bool -> + ?split:bool -> ?fail:bool -> env -> evar_map -> evar_map +val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> EConstr.types -> evar_map * EConstr.constr + +val set_typeclass_transparency_hook : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) Hook.t +val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit + +val classes_transparent_state_hook : (unit -> TransparentState.t) Hook.t +val classes_transparent_state : unit -> TransparentState.t + +val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t +val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t + +(** Build the subinstances hints for a given typeclass object. + check tells if we should check for existence of the + subinstances and add only the missing ones. *) + +val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t -> + hint_info -> + (GlobRef.t list * hint_info * constr) list diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml new file mode 100644 index 0000000000..af5b3016c9 --- /dev/null +++ b/pretyping/typeclasses_errors.ml @@ -0,0 +1,29 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Names +open EConstr +open Environ +(*i*) + +type contexts = Parameters | Properties + +type typeclass_error = + | NotAClass of constr + | UnboundMethod of GlobRef.t * lident (* Class name, method *) + +exception TypeClassError of env * Evd.evar_map * typeclass_error + +let typeclass_error env sigma err = raise (TypeClassError (env, sigma, err)) + +let not_a_class env sigma c = typeclass_error env sigma (NotAClass c) + +let unbound_method env sigma cid id = typeclass_error env sigma (UnboundMethod (cid, id)) diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli new file mode 100644 index 0000000000..fd75781ed5 --- /dev/null +++ b/pretyping/typeclasses_errors.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Environ + +type contexts = Parameters | Properties + +type typeclass_error = + | NotAClass of constr + | UnboundMethod of GlobRef.t * lident (** Class name, method *) + +exception TypeClassError of env * Evd.evar_map * typeclass_error + +val typeclass_error : env -> Evd.evar_map -> typeclass_error -> 'a + +val not_a_class : env -> Evd.evar_map -> constr -> 'a + +val unbound_method : env -> Evd.evar_map -> GlobRef.t -> lident -> 'a diff --git a/pretyping/typing.ml b/pretyping/typing.ml new file mode 100644 index 0000000000..be71f44a5e --- /dev/null +++ b/pretyping/typing.ml @@ -0,0 +1,478 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module CVars = Vars + +open Pp +open CErrors +open Util +open Term +open Constr +open Context +open Environ +open EConstr +open Vars +open Reductionops +open Inductive +open Inductiveops +open Typeops +open Arguments_renaming +open Pretype_errors +open Context.Rel.Declaration + +let meta_type evd mv = + let ty = + try Evd.meta_ftype evd mv + with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in + meta_instance evd ty + +let inductive_type_knowing_parameters env sigma (ind,u) jl = + let u = Unsafe.to_instance u in + let mspec = lookup_mind_specif env ind in + let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr ~abort_on_undefined_evars:false sigma j.uj_type)) jl in + Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp + +let type_judgment env sigma j = + match EConstr.kind sigma (whd_all env sigma j.uj_type) with + | Sort s -> sigma, {utj_val = j.uj_val; utj_type = ESorts.kind sigma s } + | Evar ev -> + let (sigma,s) = Evardefine.define_evar_as_sort env sigma ev in + sigma, { utj_val = j.uj_val; utj_type = s } + | _ -> error_not_a_type env sigma j + +let assumption_of_judgment env sigma j = + try + let sigma, j = type_judgment env sigma j in + sigma, j.utj_val + with Type_errors.TypeError _ | PretypeError _ -> + error_assumption env sigma j + +let judge_of_applied_inductive_knowing_parameters env sigma funj ind argjv = + let rec apply_rec sigma n typ = function + | [] -> + sigma, { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = + let ar = inductive_type_knowing_parameters env sigma ind argjv in + hnf_prod_appvect env sigma (EConstr.of_constr ar) (Array.map j_val argjv) } + | hj::restjl -> + let sigma, (c1,c2) = + match EConstr.kind sigma (whd_all env sigma typ) with + | Prod (_,c1,c2) -> sigma, (c1,c2) + | Evar ev -> + let (sigma,t) = Evardefine.define_evar_as_product env sigma ev in + let (_,c1,c2) = destProd sigma t in + sigma, (c1,c2) + | _ -> + error_cant_apply_not_functional env sigma funj argjv + in + begin match Evarconv.unify_leq_delay env sigma hj.uj_type c1 with + | sigma -> + apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl + | exception Evarconv.UnableToUnify _ -> + error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv + end + in + apply_rec sigma 1 funj.uj_type (Array.to_list argjv) + +let judge_of_apply env sigma funj argjv = + let rec apply_rec sigma n typ = function + | [] -> + sigma, { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ } + | hj::restjl -> + let sigma, (c1,c2) = + match EConstr.kind sigma (whd_all env sigma typ) with + | Prod (_,c1,c2) -> sigma, (c1,c2) + | Evar ev -> + let (sigma,t) = Evardefine.define_evar_as_product env sigma ev in + let (_,c1,c2) = destProd sigma t in + sigma, (c1,c2) + | _ -> + error_cant_apply_not_functional env sigma funj argjv + in + begin match Evarconv.unify_leq_delay env sigma hj.uj_type c1 with + | sigma -> + apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl + | exception Evarconv.UnableToUnify _ -> + error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv + end + in + apply_rec sigma 1 funj.uj_type (Array.to_list argjv) + +let check_branch_types env sigma (ind,u) cj (lfj,explft) = + if not (Int.equal (Array.length lfj) (Array.length explft)) then + error_number_branches env sigma cj (Array.length explft); + Array.fold_left2_i (fun i sigma lfj explft -> + match Evarconv.unify_leq_delay env sigma lfj.uj_type explft with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> + error_ill_formed_branch env sigma cj.uj_val ((ind,i+1),u) lfj.uj_type explft) + sigma lfj explft + +let max_sort l = + if Sorts.List.mem InType l then InType else + if Sorts.List.mem InSet l then InSet else InProp + +let is_correct_arity env sigma c pj ind specif params = + let arsign = make_arity_signature env sigma true (make_ind_family (ind,params)) in + let allowed_sorts = elim_sorts specif in + let error () = Pretype_errors.error_elim_arity env sigma ind c pj None in + let rec srec env sigma pt ar = + let pt' = whd_all env sigma pt in + match EConstr.kind sigma pt', ar with + | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> + begin match Evarconv.unify_leq_delay env sigma a1 a1' with + | exception Evarconv.UnableToUnify _ -> error () + | sigma -> + srec (push_rel (LocalAssum (na1,a1)) env) sigma t ar' + end + | Sort s, [] -> + let s = ESorts.kind sigma s in + if not (Sorts.List.mem (Sorts.family s) allowed_sorts) + then error () + else sigma, s + | Evar (ev,_), [] -> + let sigma, s = Evd.fresh_sort_in_family sigma (max_sort allowed_sorts) in + let sigma = Evd.define ev (mkSort s) sigma in + sigma, s + | _, (LocalDef _ as d)::ar' -> + srec (push_rel d env) sigma (lift 1 pt') ar' + | _ -> + error () + in + srec env sigma pj.uj_type (List.rev arsign) + +let lambda_applist_assum sigma n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Not enough arguments.") + else match EConstr.kind sigma t, l with + | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in + app n [] c l + +let type_case_branches env sigma (ind,largs) pj c = + let specif = lookup_mind_specif env (fst ind) in + let nparams = inductive_params specif in + let (params,realargs) = List.chop nparams largs in + let p = pj.uj_val in + let params = List.map EConstr.Unsafe.to_constr params in + let sigma, ps = is_correct_arity env sigma c pj ind specif params in + let lc = build_branches_type ind specif params (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in + let lc = Array.map EConstr.of_constr lc in + let n = (snd specif).Declarations.mind_nrealdecls in + let ty = whd_betaiota sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in + sigma, (lc, ty, Sorts.relevance_of_sort ps) + +let judge_of_case env sigma ci pj cj lfj = + let ((ind, u), spec) = + try find_mrectype env sigma cj.uj_type + with Not_found -> error_case_not_inductive env sigma cj in + let indspec = ((ind, EInstance.kind sigma u), spec) in + let sigma, (bty,rslty,rci) = type_case_branches env sigma indspec pj cj.uj_val in + let () = check_case_info env (fst indspec) rci ci in + let sigma = check_branch_types env sigma (fst indspec) cj (lfj,bty) in + sigma, { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); + uj_type = rslty } + +let check_type_fixpoint ?loc env sigma lna lar vdefj = + let lt = Array.length vdefj in + assert (Int.equal (Array.length lar) lt); + Array.fold_left2_i (fun i sigma defj ar -> + match Evarconv.unify_leq_delay env sigma defj.uj_type (lift lt ar) with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> + error_ill_typed_rec_body ?loc env sigma + i lna vdefj lar) + sigma vdefj lar + + +(* FIXME: might depend on the level of actual parameters!*) +let check_allowed_sort env sigma ind c p = + let specif = lookup_mind_specif env (fst ind) in + let sorts = elim_sorts specif in + let pj = Retyping.get_judgment_of env sigma p in + let _, s = splay_prod env sigma pj.uj_type in + let ksort = match EConstr.kind sigma s with + | Sort s -> Sorts.family (ESorts.kind sigma s) + | _ -> error_elim_arity env sigma ind c pj None in + if not (List.exists ((==) ksort) sorts) then + let s = inductive_sort_family (snd specif) in + error_elim_arity env sigma ind c pj + (Some(sorts,ksort,s,Type_errors.error_elim_explain ksort s)) + else + Sorts.relevance_of_sort_family ksort + +let judge_of_cast env sigma cj k tj = + let expected_type = tj.utj_val in + match Evarconv.unify_leq_delay env sigma cj.uj_type expected_type with + | exception Evarconv.UnableToUnify _ -> + error_actual_type_core env sigma cj expected_type; + | sigma -> + sigma, { uj_val = mkCast (cj.uj_val, k, expected_type); + uj_type = expected_type } + +let check_fix env sigma pfix = + let inj c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in + let (idx, (ids, cs, ts)) = pfix in + check_fix env (idx, (ids, Array.map inj cs, Array.map inj ts)) + +let check_cofix env sigma pcofix = + let inj c = EConstr.to_constr sigma c in + let (idx, (ids, cs, ts)) = pcofix in + check_cofix env (idx, (ids, Array.map inj cs, Array.map inj ts)) + +(* The typing machine with universes and existential variables. *) + +let judge_of_sprop = + { uj_val = EConstr.mkSProp; + uj_type = EConstr.type1 } + +let judge_of_prop = + { uj_val = EConstr.mkProp; + uj_type = EConstr.mkSort Sorts.type1 } + +let judge_of_set = + { uj_val = EConstr.mkSet; + uj_type = EConstr.mkSort Sorts.type1 } + +let judge_of_type u = + let uu = Univ.Universe.super u in + { uj_val = EConstr.mkType u; + uj_type = EConstr.mkType uu } + +let judge_of_relative env v = + Environ.on_judgment EConstr.of_constr (judge_of_relative env v) + +let judge_of_variable env id = + Environ.on_judgment EConstr.of_constr (judge_of_variable env id) + +let judge_of_projection env sigma p cj = + let pty = lookup_projection p env in + let (ind,u), args = + try find_mrectype env sigma cj.uj_type + with Not_found -> error_case_not_inductive env sigma cj + in + let u = EInstance.kind sigma u in + let ty = EConstr.of_constr (CVars.subst_instance_constr u pty) in + let ty = substl (cj.uj_val :: List.rev args) ty in + {uj_val = EConstr.mkProj (p,cj.uj_val); + uj_type = ty} + +let judge_of_abstraction env name var j = + let r = Sorts.relevance_of_sort var.utj_type in + { uj_val = mkLambda (make_annot name r, var.utj_val, j.uj_val); + uj_type = mkProd (make_annot name r, var.utj_val, j.uj_type) } + +let judge_of_product env name t1 t2 = + let r = Sorts.relevance_of_sort t1.utj_type in + let s = sort_of_product env t1.utj_type t2.utj_type in + { uj_val = mkProd (make_annot name r, t1.utj_val, t2.utj_val); + uj_type = mkSort s } + +let judge_of_letin env name defj typj j = + let r = Sorts.relevance_of_sort typj.utj_type in + { uj_val = mkLetIn (make_annot name r, defj.uj_val, typj.utj_val, j.uj_val) ; + uj_type = subst1 defj.uj_val j.uj_type } + +let check_hyps_inclusion env sigma f x hyps = + let evars = Evarutil.safe_evar_value sigma, Evd.universes sigma in + let f x = EConstr.Unsafe.to_constr (f x) in + Typeops.check_hyps_inclusion env ~evars f x hyps + +let type_of_constant env sigma (c,u) = + let open Declarations in + let cb = Environ.lookup_constant c env in + let () = check_hyps_inclusion env sigma mkConstU (c,u) cb.const_hyps in + let u = EInstance.kind sigma u in + let ty, csts = Environ.constant_type env (c,u) in + let sigma = Evd.add_constraints sigma csts in + sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstRef c))) + +let type_of_inductive env sigma (ind,u) = + let open Declarations in + let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in + let () = check_hyps_inclusion env sigma mkIndU (ind,u) mib.mind_hyps in + let u = EInstance.kind sigma u in + let ty, csts = Inductive.constrained_type_of_inductive env (specif,u) in + let sigma = Evd.add_constraints sigma csts in + sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.IndRef ind))) + +let type_of_constructor env sigma ((ind,_ as ctor),u) = + let open Declarations in + let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in + let () = check_hyps_inclusion env sigma mkIndU (ind,u) mib.mind_hyps in + let u = EInstance.kind sigma u in + let ty, csts = Inductive.constrained_type_of_constructor (ctor,u) specif in + let sigma = Evd.add_constraints sigma csts in + sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstructRef ctor))) + +let judge_of_int env v = + Environ.on_judgment EConstr.of_constr (judge_of_int env v) + +(* cstr must be in n.f. w.r.t. evars and execute returns a judgement + where both the term and type are in n.f. *) +let rec execute env sigma cstr = + let cstr = whd_evar sigma cstr in + match EConstr.kind sigma cstr with + | Meta n -> + sigma, { uj_val = cstr; uj_type = meta_type sigma n } + + | Evar ev -> + let ty = EConstr.existential_type sigma ev in + let sigma, jty = execute env sigma ty in + let sigma, jty = assumption_of_judgment env sigma jty in + sigma, { uj_val = cstr; uj_type = jty } + + | Rel n -> + sigma, judge_of_relative env n + + | Var id -> + sigma, judge_of_variable env id + + | Const c -> + let sigma, ty = type_of_constant env sigma c in + sigma, make_judge cstr ty + + | Ind ind -> + let sigma, ty = type_of_inductive env sigma ind in + sigma, make_judge cstr ty + + | Construct ctor -> + let sigma, ty = type_of_constructor env sigma ctor in + sigma, make_judge cstr ty + + | Case (ci,p,c,lf) -> + let sigma, cj = execute env sigma c in + let sigma, pj = execute env sigma p in + let sigma, lfj = execute_array env sigma lf in + judge_of_case env sigma ci pj cj lfj + + | Fix ((vn,i as vni),recdef) -> + let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in + let fix = (vni,recdef') in + check_fix env sigma fix; + sigma, make_judge (mkFix fix) tys.(i) + + | CoFix (i,recdef) -> + let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in + let cofix = (i,recdef') in + check_cofix env sigma cofix; + sigma, make_judge (mkCoFix cofix) tys.(i) + + | Sort s -> + begin match ESorts.kind sigma s with + | SProp -> + if Environ.sprop_allowed env then sigma, judge_of_sprop + else error_disallowed_sprop env sigma + | Prop -> sigma, judge_of_prop + | Set -> sigma, judge_of_set + | Type u -> sigma, judge_of_type u + end + + | Proj (p, c) -> + let sigma, cj = execute env sigma c in + sigma, judge_of_projection env sigma p cj + + | App (f,args) -> + let sigma, jl = execute_array env sigma args in + (match EConstr.kind sigma f with + | Ind (ind, u) when EInstance.is_empty u && Environ.template_polymorphic_ind ind env -> + let sigma, fj = execute env sigma f in + judge_of_applied_inductive_knowing_parameters env sigma fj (ind, u) jl + | _ -> + (* No template polymorphism *) + let sigma, fj = execute env sigma f in + judge_of_apply env sigma fj jl) + + | Lambda (name,c1,c2) -> + let sigma, j = execute env sigma c1 in + let sigma, var = type_judgment env sigma j in + let name = check_binder_annot var.utj_type name in + let env1 = push_rel (LocalAssum (name, var.utj_val)) env in + let sigma, j' = execute env1 sigma c2 in + sigma, judge_of_abstraction env1 name.binder_name var j' + + | Prod (name,c1,c2) -> + let sigma, j = execute env sigma c1 in + let sigma, varj = type_judgment env sigma j in + let name = check_binder_annot varj.utj_type name in + let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in + let sigma, j' = execute env1 sigma c2 in + let sigma, varj' = type_judgment env1 sigma j' in + sigma, judge_of_product env name.binder_name varj varj' + + | LetIn (name,c1,c2,c3) -> + let sigma, j1 = execute env sigma c1 in + let sigma, j2 = execute env sigma c2 in + let sigma, j2 = type_judgment env sigma j2 in + let sigma, _ = judge_of_cast env sigma j1 DEFAULTcast j2 in + let name = check_binder_annot j2.utj_type name in + let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in + let sigma, j3 = execute env1 sigma c3 in + sigma, judge_of_letin env name.binder_name j1 j2 j3 + + | Cast (c,k,t) -> + let sigma, cj = execute env sigma c in + let sigma, tj = execute env sigma t in + let sigma, tj = type_judgment env sigma tj in + judge_of_cast env sigma cj k tj + + | Int i -> + sigma, judge_of_int env i + +and execute_recdef env sigma (names,lar,vdef) = + let sigma, larj = execute_array env sigma lar in + let sigma, lara = Array.fold_left_map (assumption_of_judgment env) sigma larj in + let env1 = push_rec_types (names,lara,vdef) env in + let sigma, vdefj = execute_array env1 sigma vdef in + let vdefv = Array.map j_val vdefj in + let sigma = check_type_fixpoint env1 sigma names lara vdefj in + sigma, (names,lara,vdefv) + +and execute_array env = Array.fold_left_map (execute env) + +let check env sigma c t = + let sigma, j = execute env sigma c in + match Evarconv.unify_leq_delay env sigma j.uj_type t with + | exception Evarconv.UnableToUnify _ -> + error_actual_type_core env sigma j t + | sigma -> sigma + +(* Type of a constr *) + +let unsafe_type_of env sigma c = + let sigma, j = execute env sigma c in + j.uj_type + +(* Sort of a type *) + +let sort_of env sigma c = + let sigma, j = execute env sigma c in + let sigma, a = type_judgment env sigma j in + sigma, a.utj_type + +(* Try to solve the existential variables by typing *) + +let type_of ?(refresh=false) env sigma c = + let sigma, j = execute env sigma c in + (* side-effect on evdref *) + if refresh then + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma j.uj_type + else sigma, j.uj_type + +let solve_evars env sigma c = + let sigma, j = execute env sigma c in + (* side-effect on evdref *) + sigma, nf_evar sigma j.uj_val + +let _ = Evarconv.set_solve_evars (fun env sigma c -> solve_evars env sigma c) diff --git a/pretyping/typing.mli b/pretyping/typing.mli new file mode 100644 index 0000000000..f68820429b --- /dev/null +++ b/pretyping/typing.mli @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Environ +open EConstr +open Evd + +(** This module provides the typing machine with existential variables + and universes. *) + +(** Typecheck a term and return its type. May trigger an evarmap leak. *) +val unsafe_type_of : env -> evar_map -> constr -> types + +(** Typecheck a term and return its type + updated evars, optionally refreshing + universes *) +val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types + +(** Typecheck a type and return its sort *) +val sort_of : env -> evar_map -> types -> evar_map * Sorts.t + +(** Typecheck a term has a given type (assuming the type is OK) *) +val check : env -> evar_map -> constr -> types -> evar_map + +(** Returns the instantiated type of a metavariable *) +val meta_type : evar_map -> metavariable -> types + +(** Solve existential variables using typing *) +val solve_evars : env -> evar_map -> constr -> evar_map * constr + +(** Raise an error message if incorrect elimination for this inductive + (first constr is term to match, second is return predicate) *) +val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> + Sorts.relevance + +(** Raise an error message if bodies have types not unifiable with the + expected ones *) +val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map -> + Names.Name.t Context.binder_annot array -> types array -> unsafe_judgment array -> evar_map + +val judge_of_sprop : unsafe_judgment +val judge_of_prop : unsafe_judgment +val judge_of_set : unsafe_judgment +val judge_of_apply : env -> evar_map -> unsafe_judgment -> unsafe_judgment array -> + evar_map * unsafe_judgment +val judge_of_abstraction : Environ.env -> Name.t -> + unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment +val judge_of_product : Environ.env -> Name.t -> + unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment +val judge_of_projection : env -> evar_map -> Projection.t -> unsafe_judgment -> unsafe_judgment +val judge_of_int : Environ.env -> Uint63.t -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml new file mode 100644 index 0000000000..9ba51dcfa9 --- /dev/null +++ b/pretyping/unification.ml @@ -0,0 +1,2039 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open CErrors +open Pp +open Util +open Names +open Constr +open Context +open Termops +open Environ +open EConstr +open Vars +open Namegen +open Evd +open Reduction +open Reductionops +open Evarutil +open Evardefine +open Evarsolve +open Pretype_errors +open Retyping +open Coercion +open Recordops +open Locus +open Locusops +open Find_subterm + +type metabinding = (metavariable * EConstr.constr * (instance_constraint * instance_typing_status)) + +type subst0 = + (evar_map * + metabinding list * + (Environ.env * EConstr.existential * EConstr.t) list) + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +let keyed_unification = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Unification is keyed"; + optkey = ["Keyed";"Unification"]; + optread = (fun () -> !keyed_unification); + optwrite = (fun a -> keyed_unification:=a); +}) + +let is_keyed_unification () = !keyed_unification + +let debug_unification = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Print states sent to tactic unification"; + optkey = ["Debug";"Tactic";"Unification"]; + optread = (fun () -> !debug_unification); + optwrite = (fun a -> debug_unification:=a); +}) + +(** Making this unification algorithm correct w.r.t. the evar-map abstraction + breaks too much stuff. So we redefine incorrect functions here. *) + +let unsafe_occur_meta_or_existential c = + let c = EConstr.Unsafe.to_constr c in + let rec occrec c = match Constr.kind c with + | Evar _ -> raise Occur + | Meta _ -> raise Occur + | _ -> Constr.iter occrec c + in try occrec c; false with Occur -> true + + +let occur_meta_or_undefined_evar evd c = + (* This is performance-critical. Using the evar-insensitive API changes the + resulting heuristic. *) + let c = EConstr.Unsafe.to_constr c in + let rec occrec c = match Constr.kind c with + | Meta _ -> raise Occur + | Evar (ev,args) -> + (match evar_body (Evd.find evd ev) with + | Evar_defined c -> + occrec (EConstr.Unsafe.to_constr c); Array.iter occrec args + | Evar_empty -> raise Occur) + | _ -> Constr.iter occrec c + in try occrec c; false with Occur | Not_found -> true + +let occur_meta_evd sigma mv c = + let rec occrec c = + (* Note: evars are not instantiated by terms with metas *) + let c = whd_meta sigma c in + match EConstr.kind sigma c with + | Meta mv' when Int.equal mv mv' -> raise Occur + | _ -> EConstr.iter sigma occrec c + in try occrec c; false with Occur -> true + +(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, + gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) + +let abstract_scheme env evd c l lname_typ = + let mkLambda_name env (n,a,b) = + mkLambda (map_annot (named_hd env evd a) n, a, b) + in + List.fold_left2 + (fun (t,evd) (locc,a) decl -> + let na = RelDecl.get_annot decl in + let ta = RelDecl.get_type decl in + let na = match EConstr.kind evd a with Var id -> {na with binder_name=Name id} | _ -> na in +(* [occur_meta ta] test removed for support of eelim/ecase but consequences + are unclear... + if occur_meta ta then error "cannot find a type for the generalisation" + else *) + if occur_meta evd a then mkLambda_name env (na,ta,t), evd + else + let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in + mkLambda_name env (na,ta,t'), evd') + (c,evd) + (List.rev l) + lname_typ + +(* Precondition: resulting abstraction is expected to be of type [typ] *) + +let abstract_list_all env evd typ c l = + let ctxt,_ = splay_prod_n env evd (List.length l) typ in + let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in + let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in + let evd,typp = + try Typing.type_of env evd p + with + | UserError _ -> + error_cannot_find_well_typed_abstraction env evd p l None + | Type_errors.TypeError (env',x) -> + (* FIXME: plug back the typing information *) + error_cannot_find_well_typed_abstraction env evd p l None + | Pretype_errors.PretypeError (env',evd,TypingError x) -> + error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in + evd,(p,typp) + +let set_occurrences_of_last_arg args = + Evarconv.AtOccurrences AllOccurrences :: + List.tl (Array.map_to_list (fun _ -> Evarconv.Unspecified Abstraction.Abstract) args) + +let occurrence_test _ _ _ env sigma _ c1 c2 = + match EConstr.eq_constr_universes env sigma c1 c2 with + | None -> false, sigma + | Some cstr -> + try true, Evd.add_universe_constraints sigma cstr + with UniversesDiffer -> false, sigma + +let abstract_list_all_with_dependencies env evd typ c l = + let (evd, ev) = new_evar env evd typ in + let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in + let n = List.length l in + let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in + let evd,b = + Evarconv.second_order_matching + (Evarconv.default_flags_of TransparentState.empty) + env evd ev' (occurrence_test, argoccs) c in + if b then + let p = nf_evar evd ev in + evd, p + else error_cannot_find_well_typed_abstraction env evd + c l None + +(* A refinement of [conv_pb]: the integers tells how many arguments + were applied in the context of the conversion problem; if the number + is non zero, steps of eta-expansion will be allowed +*) + +let opp_status = function + | IsSuperType -> IsSubType + | IsSubType -> IsSuperType + | Conv -> Conv + +let add_type_status (x,y) = ((x,TypeNotProcessed),(y,TypeNotProcessed)) + +let extract_instance_status = function + | CUMUL -> add_type_status (IsSubType, IsSuperType) + | CONV -> add_type_status (Conv, Conv) + +let rec subst_meta_instances sigma bl c = + match EConstr.kind sigma c with + | Meta i -> + let select (j,_,_) = Int.equal i j in + (try pi2 (List.find select bl) with Not_found -> c) + | _ -> EConstr.map sigma (subst_meta_instances sigma bl) c + +(** [env] should be the context in which the metas live *) + +let pose_all_metas_as_evars env evd t = + let evdref = ref evd in + let rec aux t = match EConstr.kind !evdref t with + | Meta mv -> + (match Evd.meta_opt_fvalue !evdref mv with + | Some ({rebus=c},_) -> c + | None -> + let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in + let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in + let ty = nf_betaiota env evd ty in + let src = Evd.evar_source_of_meta mv !evdref in + let evd, ev = Evarutil.new_evar env !evdref ~src ty in + evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) evd; + ev) + | _ -> + EConstr.map !evdref aux t in + let c = aux t in + (* side-effect *) + (!evdref, c) + +let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst : subst0) = + match EConstr.kind sigma f with + | Meta k -> + (* We enforce that the Meta does not depend on the [nb] + extra assumptions added by unification to the context *) + let env' = pop_rel_context nb env in + let sigma,c = pose_all_metas_as_evars env' sigma c in + let c = solve_pattern_eqn env sigma l c in + let pb = (Conv,TypeNotProcessed) in + if noccur_between sigma 1 nb c then + sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst + else + let l = List.map of_alias l in + error_cannot_unify_local env sigma (applist (f, l),c,c) + | Evar ev -> + let env' = pop_rel_context nb env in + let sigma,c = pose_all_metas_as_evars env' sigma c in + sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst + | _ -> assert false + +let push d (env,n) = (push_rel_assum d env,n+1) + +(*******************************) + +(* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n] + renvoie deux listes: + + metasubst:(int*constr)list récolte les instances des (Meta k) + evarsubst:(constr*constr)list récolte les instances des (Const "?k") + + Attention : pas d'unification entre les différences instances d'une + même meta ou evar, il peut rester des doublons *) + +(* Unification order: *) +(* Left to right: unifies first argument and then the other arguments *) +(*let unify_l2r x = List.rev x +(* Right to left: unifies last argument and then the other arguments *) +let unify_r2l x = x + +let sort_eqns = unify_r2l +*) + +type core_unify_flags = { + modulo_conv_on_closed_terms : TransparentState.t option; + (* What this flag controls was activated with all constants transparent, *) + (* even for auto, since Coq V5.10 *) + + use_metas_eagerly_in_conv_on_closed_terms : bool; + (* This refinement of the conversion on closed terms is activable *) + (* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *) + + use_evars_eagerly_in_conv_on_closed_terms : bool; + + modulo_delta : TransparentState.t; + (* This controls which constants are unfoldable; this is on for apply *) + (* (but not simple apply) since Feb 2008 for 8.2 *) + + modulo_delta_types : TransparentState.t; + + check_applied_meta_types : bool; + (* This controls whether meta's applied to arguments have their *) + (* type unified with the type of their instance *) + + use_pattern_unification : bool; + (* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *) + (* This says if pattern unification is tried *) + + use_meta_bound_pattern_unification : bool; + (* This is implied by use_pattern_unification; has no particular *) + (* reasons to be set differently than use_pattern_unification *) + (* except for compatibility of "auto". *) + (* This was on for all tactics, including auto, since Sep 2006 for 8.1 *) + (* This allowed for instance to unify "forall x:?A, ?B x" with "A' -> B'" *) + (* when ?B is a Meta. *) + + frozen_evars : Evar.Set.t; + (* Evars of this set are considered axioms and never instantiated *) + (* Useful e.g. for autorewrite *) + + restrict_conv_on_strict_subterms : bool; + (* No conversion at the root of the term; potentially useful for rewrite *) + + modulo_betaiota : bool; + (* Support betaiota in the reduction *) + (* Note that zeta is always used *) + + modulo_eta : bool; + (* Support eta in the reduction *) +} + +type unify_flags = { + core_unify_flags : core_unify_flags; + (* Governs unification of problems of the form "t(?x) = u(?x)" in apply *) + + merge_unify_flags : core_unify_flags; + (* These are the flags to be used when trying to unify *) + (* several instances of the same metavariable *) + (* Typical situation is when we give a pattern to be matched *) + (* syntactically against a subterm but we want the metas of the *) + (* pattern to be modulo convertibility *) + + subterm_unify_flags : core_unify_flags; + (* Governs unification of problems of the form "?X a1..an = u" in apply, *) + (* hence in rewrite and elim *) + + allow_K_in_toplevel_higher_order_unification : bool; + (* Tells in second-order abstraction over subterms which have not *) + (* been found in term are allowed (used for rewrite, elim, or *) + (* apply with a lemma whose type has the form "?X a1 ... an") *) + + resolve_evars : bool + (* This says if type classes instances resolution must be used to infer *) + (* the remaining evars *) +} + +(* Default flag for unifying a type against a type (e.g. apply) *) +(* We set all conversion flags (no flag should be modified anymore) *) +let default_core_unify_flags () = + let ts = TransparentState.full in { + modulo_conv_on_closed_terms = Some ts; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = ts; + modulo_delta_types = ts; + check_applied_meta_types = true; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = Evar.Set.empty; + restrict_conv_on_strict_subterms = false; + modulo_betaiota = true; + modulo_eta = true; + } + +(* Default flag for first-order or second-order unification of a type *) +(* against another type (e.g. apply) *) +(* We set all conversion flags (no flag should be modified anymore) *) +let default_unify_flags () = + let flags = default_core_unify_flags () in { + core_unify_flags = flags; + merge_unify_flags = flags; + subterm_unify_flags = { flags with modulo_delta = TransparentState.var_full }; + allow_K_in_toplevel_higher_order_unification = false; (* Why not? *) + resolve_evars = false +} + +let set_no_delta_core_flags flags = { flags with + modulo_conv_on_closed_terms = None; + modulo_delta = TransparentState.empty; + check_applied_meta_types = false; + use_pattern_unification = false; + use_meta_bound_pattern_unification = true; + modulo_betaiota = false +} + +let set_no_delta_flags flags = { + core_unify_flags = set_no_delta_core_flags flags.core_unify_flags; + merge_unify_flags = set_no_delta_core_flags flags.merge_unify_flags; + subterm_unify_flags = set_no_delta_core_flags flags.subterm_unify_flags; + allow_K_in_toplevel_higher_order_unification = + flags.allow_K_in_toplevel_higher_order_unification; + resolve_evars = flags.resolve_evars +} + +(* For the first phase of keyed unification, restrict + to conversion (including beta-iota) only on closed terms *) +let set_no_delta_open_core_flags flags = { flags with + modulo_delta = TransparentState.empty; + modulo_betaiota = false; +} + +let set_no_delta_open_flags flags = { + core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags; + merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags; + subterm_unify_flags = set_no_delta_open_core_flags flags.subterm_unify_flags; + allow_K_in_toplevel_higher_order_unification = + flags.allow_K_in_toplevel_higher_order_unification; + resolve_evars = flags.resolve_evars +} + +(* Default flag for the "simple apply" version of unification of a *) +(* type against a type (e.g. apply) *) +(* We set only the flags available at the time the new "apply" extended *) +(* out of "simple apply" *) +let default_no_delta_core_unify_flags () = { (default_core_unify_flags ()) with + modulo_delta = TransparentState.empty; + check_applied_meta_types = false; + use_pattern_unification = false; + use_meta_bound_pattern_unification = true; + modulo_betaiota = false; +} + +let default_no_delta_unify_flags ts = + let flags = default_no_delta_core_unify_flags () in + let flags = { flags with + modulo_conv_on_closed_terms = Some ts; + modulo_delta_types = ts + } in + { + core_unify_flags = flags; + merge_unify_flags = flags; + subterm_unify_flags = flags; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +(* Default flags for looking for subterms in elimination tactics *) +(* Not used in practice at the current date, to the exception of *) +(* allow_K) because only closed terms are involved in *) +(* induction/destruct/case/elim and w_unify_to_subterm_list does not *) +(* call w_unify for induction/destruct/case/elim (13/6/2011) *) +let elim_core_flags sigma = { (default_core_unify_flags ()) with + modulo_betaiota = false; + frozen_evars = + fold_undefined (fun evk _ evars -> Evar.Set.add evk evars) + sigma Evar.Set.empty; +} + +let elim_flags_evars sigma = + let flags = elim_core_flags sigma in { + core_unify_flags = flags; + merge_unify_flags = flags; + subterm_unify_flags = { flags with modulo_delta = TransparentState.empty }; + allow_K_in_toplevel_higher_order_unification = true; + resolve_evars = false +} + +let elim_flags () = elim_flags_evars Evd.empty + +let elim_no_delta_core_flags () = { (elim_core_flags Evd.empty) with + modulo_delta = TransparentState.empty; + check_applied_meta_types = false; + use_pattern_unification = false; + modulo_betaiota = false; +} + +let elim_no_delta_flags () = + let flags = elim_no_delta_core_flags () in { + core_unify_flags = flags; + merge_unify_flags = flags; + subterm_unify_flags = flags; + allow_K_in_toplevel_higher_order_unification = true; + resolve_evars = false +} + +(* On types, we don't restrict unification, but possibly for delta *) +let set_flags_for_type flags = { flags with + modulo_delta = flags.modulo_delta_types; + modulo_conv_on_closed_terms = Some flags.modulo_delta_types; + use_pattern_unification = true; + modulo_betaiota = true; + modulo_eta = true; +} + +let use_evars_pattern_unification flags = + flags.use_pattern_unification + +let use_metas_pattern_unification sigma flags nb l = + flags.use_pattern_unification + || flags.use_meta_bound_pattern_unification && + Array.for_all (fun c -> isRel sigma c && destRel sigma c <= nb) l + +type key = + | IsKey of CClosure.table_key + | IsProj of Projection.t * EConstr.constr + +let expand_table_key env = function + | ConstKey cst -> constant_opt_value_in env cst + | VarKey id -> (try named_body id env with Not_found -> None) + | RelKey _ -> None + +let unfold_projection env p stk = + let s = Stack.Proj (p, Cst_stack.empty) in + s :: stk + +let expand_key ts env sigma = function + | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) + | Some (IsProj (p, c)) -> + let red = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (c, unfold_projection env p []))) + in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red + | None -> None + +let isApp_or_Proj sigma c = + match kind sigma c with + | App _ | Proj _ -> true + | _ -> false + +type unirec_flags = { + at_top: bool; + with_types: bool; + with_cs : bool; +} + +let subterm_restriction opt flags = + not opt.at_top && flags.restrict_conv_on_strict_subterms + +let key_of env sigma b flags f = + if subterm_restriction b flags then None else + match EConstr.kind sigma f with + | Const (cst, u) when is_transparent env (ConstKey cst) && + (TransparentState.is_transparent_constant flags.modulo_delta cst + || Recordops.is_primitive_projection cst) -> + let u = EInstance.kind sigma u in + Some (IsKey (ConstKey (cst, u))) + | Var id when is_transparent env (VarKey id) && + TransparentState.is_transparent_variable flags.modulo_delta id -> + Some (IsKey (VarKey id)) + | Proj (p, c) when Projection.unfolded p + || (is_transparent env (ConstKey (Projection.constant p)) && + (TransparentState.is_transparent_constant flags.modulo_delta (Projection.constant p))) -> + Some (IsProj (p, c)) + | _ -> None + + +let translate_key = function + | ConstKey (cst,u) -> ConstKey cst + | VarKey id -> VarKey id + | RelKey n -> RelKey n + +let translate_key = function + | IsKey k -> translate_key k + | IsProj (c, _) -> ConstKey (Projection.constant c) + +let oracle_order env cf1 cf2 = + match cf1 with + | None -> + (match cf2 with + | None -> None + | Some k2 -> Some false) + | Some k1 -> + match cf2 with + | None -> Some true + | Some k2 -> + match k1, k2 with + | IsProj (p, _), IsKey (ConstKey (p',_)) + when Constant.equal (Projection.constant p) p' -> + Some (not (Projection.unfolded p)) + | IsKey (ConstKey (p,_)), IsProj (p', _) + when Constant.equal p (Projection.constant p') -> + Some (Projection.unfolded p') + | _ -> + Some (Conv_oracle.oracle_order (fun x -> x) + (Environ.oracle env) false (translate_key k1) (translate_key k2)) + +let is_rigid_head sigma flags t = + match EConstr.kind sigma t with + | Const (cst,u) -> not (TransparentState.is_transparent_constant flags.modulo_delta cst) + | Ind (i,u) -> true + | Construct _ | Int _ -> true + | Fix _ | CoFix _ -> true + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ + | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _) + | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) + +let force_eqs c = + let open UnivProblem in + Set.fold + (fun c acc -> + let c' = match c with + (* Should we be forcing weak constraints? *) + | ULub (l, r) | UWeak (l, r) -> UEq (Univ.Universe.make l,Univ.Universe.make r) + | ULe _ | UEq _ -> c + in + Set.add c' acc) + c Set.empty + +let constr_cmp pb env sigma flags t u = + let cstrs = + if pb == Reduction.CONV then EConstr.eq_constr_universes env sigma t u + else EConstr.leq_constr_universes env sigma t u + in + match cstrs with + | Some cstrs -> + begin try Some (Evd.add_universe_constraints sigma cstrs) + with Univ.UniverseInconsistency _ -> None + | Evd.UniversesDiffer -> + if is_rigid_head sigma flags t then + try Some (Evd.add_universe_constraints sigma (force_eqs cstrs)) + with Univ.UniverseInconsistency _ -> None + else None + end + | None -> + None + +let do_reduce ts (env, nb) sigma c = + Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state + ts env sigma Cst_stack.empty (c, Stack.empty))) + +let isAllowedEvar sigma flags c = match EConstr.kind sigma c with + | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) + | _ -> false + + +let subst_defined_metas_evars sigma (bl,el) c = + (* This seems to be performance-critical, and using the + evar-insensitive primitives blow up the time passed in this + function. *) + let c = EConstr.Unsafe.to_constr c in + let rec substrec c = match Constr.kind c with + | Meta i -> + let select (j,_,_) = Int.equal i j in + substrec (EConstr.Unsafe.to_constr (pi2 (List.find select bl))) + | Evar (evk,args) -> + let eq c1 c2 = Constr.equal c1 (EConstr.Unsafe.to_constr c2) in + let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.for_all2 eq args args' in + (try substrec (EConstr.Unsafe.to_constr (pi3 (List.find select el))) + with Not_found -> Constr.map substrec c) + | _ -> Constr.map substrec c + in try Some (EConstr.of_constr (substrec c)) with Not_found -> None + +let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM tyN = + match subst_defined_metas_evars sigma (metasubst,[]) tyM with + | None -> sigma + | Some m -> + match subst_defined_metas_evars sigma (metasubst,[]) tyN with + | None -> sigma + | Some n -> + if is_ground_term sigma m && is_ground_term sigma n then + match infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n with + | Some sigma -> sigma + | None -> error_cannot_unify env sigma (m,n) + else sigma + + +let rec is_neutral env sigma ts t = + let (f, l) = decompose_app_vect sigma t in + match EConstr.kind sigma f with + | Const (c, u) -> + not (Environ.evaluable_constant c env) || + not (is_transparent env (ConstKey c)) || + not (TransparentState.is_transparent_constant ts c) + | Var id -> + not (Environ.evaluable_named id env) || + not (is_transparent env (VarKey id)) || + not (TransparentState.is_transparent_variable ts id) + | Rel n -> true + | Evar _ | Meta _ -> true + | Case (_, p, c, cl) -> is_neutral env sigma ts c + | Proj (p, c) -> is_neutral env sigma ts c + | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ -> false + | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) + | Fix _ -> false (* This is an approximation *) + | App _ -> assert false + +let is_eta_constructor_app env sigma ts f l1 term = + match EConstr.kind sigma f with + | Construct (((_, i as ind), j), u) when j == 1 -> + let open Declarations in + let mib = lookup_mind (fst ind) env in + (match mib.Declarations.mind_record with + | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite && + let (_, projs, _, _) = info.(i) in + Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> + (* Check that the other term is neutral *) + is_neutral env sigma ts term + | _ -> false) + | _ -> false + +let eta_constructor_app env sigma f l1 term = + match EConstr.kind sigma f with + | Construct (((_, i as ind), j), u) -> + let mib = lookup_mind (fst ind) env in + (match get_projections env ind with + | Some projs -> + let npars = mib.Declarations.mind_nparams in + let pars, l1' = Array.chop npars l1 in + let arg = Array.append pars [|term|] in + let l2 = Array.map (fun p -> mkApp (mkConstU (Projection.Repr.constant p,u), arg)) projs in + l1', l2 + | _ -> assert false) + | _ -> assert false + +let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = + let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = + let cM = Evarutil.whd_head_evar sigma curm + and cN = Evarutil.whd_head_evar sigma curn in + let () = + if !debug_unification then + Feedback.msg_debug ( + Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ + Termops.Internal.print_constr_env curenv sigma cN) + in + match (EConstr.kind sigma cM, EConstr.kind sigma cN) with + | Meta k1, Meta k2 -> + if Int.equal k1 k2 then substn else + let stM,stN = extract_instance_status pb in + let sigma = + if opt.with_types && flags.check_applied_meta_types then + let tyM = Typing.meta_type sigma k1 in + let tyN = Typing.meta_type sigma k2 in + let l, r = if k2 < k1 then tyN, tyM else tyM, tyN in + check_compatibility curenv CUMUL flags substn l r + else sigma + in + if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst + else sigma,(k2,cM,stM)::metasubst,evarsubst + | Meta k, _ + when not (occur_metavariable sigma k cN) (* helps early trying alternatives *) -> + let sigma = + if opt.with_types && flags.check_applied_meta_types then + (try + let tyM = Typing.meta_type sigma k in + let tyN = get_type_of curenv ~lax:true sigma cN in + check_compatibility curenv CUMUL flags substn tyN tyM + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma) + else sigma + in + (* Here we check that [cN] does not contain any local variables *) + if Int.equal nb 0 then + sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst + else if noccur_between sigma 1 nb cN then + (sigma, + (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, + evarsubst) + else error_cannot_unify_local curenv sigma (m,n,cN) + | _, Meta k + when not (occur_metavariable sigma k cM) (* helps early trying alternatives *) -> + let sigma = + if opt.with_types && flags.check_applied_meta_types then + (try + let tyM = get_type_of curenv ~lax:true sigma cM in + let tyN = Typing.meta_type sigma k in + check_compatibility curenv CUMUL flags substn tyM tyN + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma) + else sigma + in + (* Here we check that [cM] does not contain any local variables *) + if Int.equal nb 0 then + (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst) + else if noccur_between sigma 1 nb cM + then + (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst, + evarsubst) + else error_cannot_unify_local curenv sigma (m,n,cM) + | Evar (evk,_ as ev), Evar (evk',_) + when not (Evar.Set.mem evk flags.frozen_evars) + && Evar.equal evk evk' -> + begin match constr_cmp cv_pb env sigma flags cM cN with + | Some sigma -> + sigma, metasubst, evarsubst + | None -> + sigma,metasubst,((curenv,ev,cN)::evarsubst) + end + | Evar (evk,_ as ev), _ + when not (Evar.Set.mem evk flags.frozen_evars) + && not (occur_evar sigma evk cN) -> + let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in + if Int.Set.subset cnvars cmvars then + sigma,metasubst,((curenv,ev,cN)::evarsubst) + else error_cannot_unify_local curenv sigma (m,n,cN) + | _, Evar (evk,_ as ev) + when not (Evar.Set.mem evk flags.frozen_evars) + && not (occur_evar sigma evk cM) -> + let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in + if Int.Set.subset cmvars cnvars then + sigma,metasubst,((curenv,ev,cM)::evarsubst) + else error_cannot_unify_local curenv sigma (m,n,cN) + | Sort s1, Sort s2 -> + (try + let s1 = ESorts.kind sigma s1 in + let s2 = ESorts.kind sigma s2 in + let sigma' = + if pb == CUMUL + then Evd.set_leq_sort curenv sigma s1 s2 + else Evd.set_eq_sort curenv sigma s1 s2 + in (sigma', metasubst, evarsubst) + with e when CErrors.noncritical e -> + error_cannot_unify curenv sigma (m,n)) + + | Lambda (na,t1,c1), Lambda (__,t2,c2) -> + unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} + (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 + | Prod (na,t1,c1), Prod (_,t2,c2) -> + unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true} + (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 + | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN + | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) + + (* Fast path for projections. *) + | Proj (p1,c1), Proj (p2,c2) when Constant.equal + (Projection.constant p1) (Projection.constant p2) -> + (try unify_same_proj curenvnb cv_pb {opt with at_top = true} + substn c1 c2 + with ex when precatchable_exception ex -> + unify_not_same_head curenvnb pb opt substn cM cN) + + (* eta-expansion *) + | Lambda (na,t1,c1), _ when flags.modulo_eta -> + unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn + c1 (mkApp (lift 1 cN,[|mkRel 1|])) + | _, Lambda (na,t2,c2) when flags.modulo_eta -> + unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn + (mkApp (lift 1 cM,[|mkRel 1|])) c2 + + (* For records *) + | App (f1, l1), _ when flags.modulo_eta && + (* This ensures cN is an evar, meta or irreducible constant/variable + and not a constructor. *) + is_eta_constructor_app curenv sigma flags.modulo_delta f1 l1 cN -> + (try + let l1', l2' = eta_constructor_app curenv sigma f1 l1 cN in + let opt' = {opt with at_top = true; with_cs = false} in + Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' + with ex when precatchable_exception ex -> + match EConstr.kind sigma cN with + | App(f2,l2) when + (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> + unify_app_pattern false curenvnb pb opt substn cM f1 l1 cN f2 l2 + | _ -> raise ex) + + | _, App (f2, l2) when flags.modulo_eta && + is_eta_constructor_app curenv sigma flags.modulo_delta f2 l2 cM -> + (try + let l2', l1' = eta_constructor_app curenv sigma f2 l2 cM in + let opt' = {opt with at_top = true; with_cs = false} in + Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' + with ex when precatchable_exception ex -> + match EConstr.kind sigma cM with + | App(f1,l1) when + (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> + unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 + | _ -> raise ex) + + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> + (try + let opt' = {opt with at_top = true; with_types = false} in + Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true}) + (unirec_rec curenvnb CONV opt' + (unirec_rec curenvnb CONV opt' substn p1 p2) c1 c2) + cl1 cl2 + with ex when precatchable_exception ex -> + reduce curenvnb pb opt substn cM cN) + + | Fix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(_,tl2,bl2)) when + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 -> + (try + let opt' = {opt with at_top = true; with_types = false} in + let curenvnb' = Array.fold_right2 (fun na t -> push (na,t)) lna1 tl1 curenvnb in + Array.fold_left2 (unirec_rec curenvnb' CONV opt') + (Array.fold_left2 (unirec_rec curenvnb CONV opt') substn tl1 tl2) bl1 bl2 + with ex when precatchable_exception ex -> + reduce curenvnb pb opt substn cM cN) + + | CoFix (i1,(lna1,tl1,bl1)), CoFix (i2,(_,tl2,bl2)) when + Int.equal i1 i2 -> + (try + let opt' = {opt with at_top = true; with_types = false} in + let curenvnb' = Array.fold_right2 (fun na t -> push (na,t)) lna1 tl1 curenvnb in + Array.fold_left2 (unirec_rec curenvnb' CONV opt') + (Array.fold_left2 (unirec_rec curenvnb CONV opt') substn tl1 tl2) bl1 bl2 + with ex when precatchable_exception ex -> + reduce curenvnb pb opt substn cM cN) + + | App (f1,l1), _ when + (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> + unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN cN [||] + + | _, App (f2,l2) when + (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> + unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2 + + | App (f1,l1), App (f2,l2) -> + unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 + + | App (f1,l1), Proj(p2,c2) -> + unify_app curenvnb pb opt substn cM f1 l1 cN cN [||] + + | Proj (p1,c1), App(f2,l2) -> + unify_app curenvnb pb opt substn cM cM [||] cN f2 l2 + + | _ -> + unify_not_same_head curenvnb pb opt substn cM cN + + and unify_app_pattern dir curenvnb pb opt (sigma, _, _ as substn) cM f1 l1 cN f2 l2 = + let f, l, t = if dir then f1, l1, cN else f2, l2, cM in + match is_unification_pattern curenvnb sigma f (Array.to_list l) t with + | None -> + (match EConstr.kind sigma t with + | App (f',l') -> + if dir then unify_app curenvnb pb opt substn cM f1 l1 t f' l' + else unify_app curenvnb pb opt substn t f' l' cN f2 l2 + | Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 + | _ -> unify_not_same_head curenvnb pb opt substn cM cN) + | Some l -> + solve_pattern_eqn_array curenvnb f l t substn + + and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn : subst0) cM f1 l1 cN f2 l2 = + try + let needs_expansion p c' = + match EConstr.kind sigma c' with + | Meta _ -> true + | Evar _ -> true + | Const (c, u) -> Constant.equal c (Projection.constant p) + | _ -> false + in + let expand_proj c c' l = + match EConstr.kind sigma c with + | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> + (try destApp sigma (Retyping.expand_projection curenv sigma p t (Array.to_list l)) + with RetypeError _ -> (* Unification can be called on ill-typed terms, due + to FO and eta in particular, fail gracefully in that case *) + (c, l)) + | _ -> (c, l) + in + let f1, l1 = expand_proj f1 f2 l1 in + let f2, l2 = expand_proj f2 f1 l2 in + let opta = {opt with at_top = true; with_types = false} in + let optf = {opt with at_top = true; with_types = true} in + let (f1,l1,f2,l2) = adjust_app_array_size f1 l1 f2 l2 in + if Array.length l1 == 0 then error_cannot_unify (fst curenvnb) sigma (cM,cN) + else + Array.fold_left2 (unirec_rec curenvnb CONV opta) + (unirec_rec curenvnb CONV optf substn f1 f2) l1 l2 + with ex when precatchable_exception ex -> + try reduce curenvnb pb {opt with with_types = false} substn cM cN + with ex when precatchable_exception ex -> + try canonical_projections curenvnb pb opt cM cN substn + with ex when precatchable_exception ex -> + expand curenvnb pb {opt with with_types = false} substn cM f1 l1 cN f2 l2 + + and unify_same_proj (curenv, nb as curenvnb) cv_pb opt substn c1 c2 = + let substn = unirec_rec curenvnb CONV opt substn c1 c2 in + try (* Force unification of the types to fill in parameters *) + let ty1 = get_type_of curenv ~lax:true sigma c1 in + let ty2 = get_type_of curenv ~lax:true sigma c2 in + unify_0_with_initial_metas substn true curenv cv_pb + { flags with modulo_conv_on_closed_terms = Some TransparentState.full; + modulo_delta = TransparentState.full; + modulo_eta = true; + modulo_betaiota = true } + ty1 ty2 + with RetypeError _ -> substn + + and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = + try canonical_projections curenvnb pb opt cM cN substn + with ex when precatchable_exception ex -> + match constr_cmp cv_pb env sigma flags cM cN with + | Some sigma -> (sigma, metas, evars) + | None -> + try reduce curenvnb pb opt substn cM cN + with ex when precatchable_exception ex -> + let (f1,l1) = + match EConstr.kind sigma cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + let (f2,l2) = + match EConstr.kind sigma cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + expand curenvnb pb opt substn cM f1 l1 cN f2 l2 + + and reduce curenvnb pb opt (sigma, metas, evars as substn) cM cN = + if flags.modulo_betaiota && not (subterm_restriction opt flags) then + let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in + if not (EConstr.eq_constr sigma cM cM') then + unirec_rec curenvnb pb opt substn cM' cN + else + let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in + if not (EConstr.eq_constr sigma cN cN') then + unirec_rec curenvnb pb opt substn cM cN' + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + + and expand (curenv,_ as curenvnb) pb opt (sigma,metasubst,evarsubst as substn : subst0) cM f1 l1 cN f2 l2 = + let res = + (* Try full conversion on meta-free terms. *) + (* Back to 1995 (later on called trivial_unify in 2002), the + heuristic was to apply conversion on meta-free (but not + evar-free!) terms in all cases (i.e. for apply but also for + auto and rewrite, even though auto and rewrite did not use + modulo conversion in the rest of the unification + algorithm). By compatibility we need to support this + separately from the main unification algorithm *) + (* The exploitation of known metas has been added in May 2007 + (it is used by apply and rewrite); it might now be redundant + with the support for delta-expansion (which is used + essentially for apply)... *) + if subterm_restriction opt flags then None else + match flags.modulo_conv_on_closed_terms with + | None -> None + | Some convflags -> + let subst = ((if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms), (if flags.use_evars_eagerly_in_conv_on_closed_terms then evarsubst else es)) in + match subst_defined_metas_evars sigma subst cM with + | None -> (* some undefined Metas in cM *) None + | Some m1 -> + match subst_defined_metas_evars sigma subst cN with + | None -> (* some undefined Metas in cN *) None + | Some n1 -> + (* No subterm restriction there, too much incompatibilities *) + let sigma = + if opt.with_types then + try (* Ensure we call conversion on terms of the same type *) + let tyM = get_type_of curenv ~lax:true sigma m1 in + let tyN = get_type_of curenv ~lax:true sigma n1 in + check_compatibility curenv CUMUL flags substn tyM tyN + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma + else sigma + in + match infer_conv ~pb ~ts:convflags curenv sigma m1 n1 with + | Some sigma -> + Some (sigma, metasubst, evarsubst) + | None -> + if is_ground_term sigma m1 && is_ground_term sigma n1 then + error_cannot_unify curenv sigma (cM,cN) + else None + in + match res with + | Some substn -> substn + | None -> + let cf1 = key_of curenv sigma opt flags f1 and cf2 = key_of curenv sigma opt flags f2 in + match oracle_order curenv cf1 cf2 with + | None -> error_cannot_unify curenv sigma (cM,cN) + | Some true -> + (match expand_key flags.modulo_delta curenv sigma cf1 with + | Some c -> + unirec_rec curenvnb pb opt substn + (whd_betaiotazeta sigma (mkApp(c,l1))) cN + | None -> + (match expand_key flags.modulo_delta curenv sigma cf2 with + | Some c -> + unirec_rec curenvnb pb opt substn cM + (whd_betaiotazeta sigma (mkApp(c,l2))) + | None -> + error_cannot_unify curenv sigma (cM,cN))) + | Some false -> + (match expand_key flags.modulo_delta curenv sigma cf2 with + | Some c -> + unirec_rec curenvnb pb opt substn cM + (whd_betaiotazeta sigma (mkApp(c,l2))) + | None -> + (match expand_key flags.modulo_delta curenv sigma cf1 with + | Some c -> + unirec_rec curenvnb pb opt substn + (whd_betaiotazeta sigma (mkApp(c,l1))) cN + | None -> + error_cannot_unify curenv sigma (cM,cN))) + + and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = + let f1 () = + if isApp_or_Proj sigma cM then + let f1l1 = whd_nored_state sigma (cM,Stack.empty) in + if is_open_canonical_projection curenv sigma f1l1 then + let f2l2 = whd_nored_state sigma (cN,Stack.empty) in + solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + in + if not opt.with_cs || + begin match flags.modulo_conv_on_closed_terms with + | None -> true + | Some _ -> subterm_restriction opt flags + end then + error_cannot_unify (fst curenvnb) sigma (cM,cN) + else + try f1 () with e when precatchable_exception e -> + if isApp_or_Proj sigma cN then + let f2l2 = whd_nored_state sigma (cN, Stack.empty) in + if is_open_canonical_projection curenv sigma f2l2 then + let f1l1 = whd_nored_state sigma (cM, Stack.empty) in + solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + + and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) = + let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2 + with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) + in + if Reductionops.Stack.compare_shape ts ts1 then + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let (evd,ks,_) = + List.fold_left + (fun (evd,ks,m) b -> + if match n with Some n -> Int.equal m n | None -> false then + (evd,t2::ks, m-1) + else + let mv = new_meta () in + let evd' = meta_declare mv (substl ks b) evd in + (evd', mkMeta mv :: ks, m - 1)) + (sigma,[],List.length bs) bs + in + try + let opt' = {opt with with_types = false} in + let substn = Reductionops.Stack.fold2 + (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) + (evd,ms,es) us2 us in + let substn = Reductionops.Stack.fold2 + (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) + substn params1 params in + let substn = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in + let app = mkApp (c, Array.rev_of_list ks) in + (* let substn = unirec_rec curenvnb pb b false substn t cN in *) + unirec_rec curenvnb pb opt' substn c1 app + with Reductionops.Stack.IncompatibleFold2 -> + error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + in + + if !debug_unification then Feedback.msg_debug (str "Starting unification"); + let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in + try + let res = + if subterm_restriction opt flags || + occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n + then + None + else + let ans = match flags.modulo_conv_on_closed_terms with + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | _ -> constr_cmp cv_pb env sigma flags m n in + match ans with + | Some sigma -> ans + | None -> + if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + | Some cv, dl -> + let open TransparentState in + Id.Pred.subset dl.tr_var cv.tr_var && Cpred.subset dl.tr_cst cv.tr_cst + | None, dl -> TransparentState.is_empty dl) + then error_cannot_unify env sigma (m, n) else None + in + let a = match res with + | Some sigma -> sigma, ms, es + | None -> unirec_rec (env,0) cv_pb opt subst m n in + if !debug_unification then Feedback.msg_debug (str "Leaving unification with success"); + a + with e -> + let e = CErrors.push e in + if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure"); + iraise e + + +let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env + +let left = true +let right = false + +let rec unify_with_eta keptside flags env sigma c1 c2 = +(* Question: try whd_all on ci if not two lambdas? *) + match EConstr.kind sigma c1, EConstr.kind sigma c2 with + | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) -> + let env' = push_rel_assum (na,t1) env in + let sigma,metas,evars = unify_0 env sigma CONV flags t1 t2 in + let side,(sigma,metas',evars') = + unify_with_eta keptside flags env' sigma c1' c2' + in (side,(sigma,metas@metas',evars@evars')) + | (Lambda (na,t,c1'),_)-> + let env' = push_rel_assum (na,t) env in + let side = left in (* expansion on the right: we keep the left side *) + unify_with_eta side flags env' sigma + c1' (mkApp (lift 1 c2,[|mkRel 1|])) + | (_,Lambda (na,t,c2')) -> + let env' = push_rel_assum (na,t) env in + let side = right in (* expansion on the left: we keep the right side *) + unify_with_eta side flags env' sigma + (mkApp (lift 1 c1,[|mkRel 1|])) c2' + | _ -> + (keptside,unify_0 env sigma CONV flags c1 c2) + +(* We solved problems [?n =_pb u] (i.e. [u =_(opp pb) ?n]) and [?n =_pb' u'], + we now compute the problem on [u =? u'] and decide which of u or u' is kept + + Rem: the upper constraint is lost in case u <= ?n <= u' (and symmetrically + in the case u' <= ?n <= u) + *) + +let merge_instances env sigma flags st1 st2 c1 c2 = + match (opp_status st1, st2) with + | (Conv, Conv) -> + let side = left (* arbitrary choice, but agrees with compatibility *) in + let (side,res) = unify_with_eta side flags env sigma c1 c2 in + (side,Conv,res) + | ((IsSubType | Conv as oppst1), + (IsSubType | Conv)) -> + let res = unify_0 env sigma CUMUL flags c2 c1 in + if eq_instance_constraint oppst1 st2 then (* arbitrary choice *) (left, st1, res) + else if eq_instance_constraint st2 IsSubType then (left, st1, res) + else (right, st2, res) + | ((IsSuperType | Conv as oppst1), + (IsSuperType | Conv)) -> + let res = unify_0 env sigma CUMUL flags c1 c2 in + if eq_instance_constraint oppst1 st2 then (* arbitrary choice *) (left, st1, res) + else if eq_instance_constraint st2 IsSuperType then (left, st1, res) + else (right, st2, res) + | (IsSuperType,IsSubType) -> + (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1) + with e when CErrors.noncritical e -> + (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2)) + | (IsSubType,IsSuperType) -> + (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2) + with e when CErrors.noncritical e -> + (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) + +(* Unification + * + * Procedure: + * (1) The function [unify mc wc M N] produces two lists: + * (a) a list of bindings Meta->RHS + * (b) a list of bindings EVAR->RHS + * + * The Meta->RHS bindings cannot themselves contain + * meta-vars, so they get applied eagerly to the other + * bindings. This may or may not close off all RHSs of + * the EVARs. For each EVAR whose RHS is closed off, + * we can just apply it, and go on. For each which + * is not closed off, we need to do a mimick step - + * in general, we have something like: + * + * ?X == (c e1 e2 ... ei[Meta(k)] ... en) + * + * so we need to do a mimick step, converting ?X + * into + * + * ?X -> (c ?z1 ... ?zn) + * + * of the proper types. Then, we can decompose the + * equation into + * + * ?z1 --> e1 + * ... + * ?zi --> ei[Meta(k)] + * ... + * ?zn --> en + * + * and keep on going. Whenever we find that a R.H.S. + * is closed, we can, as before, apply the constraint + * directly. Whenever we find an equation of the form: + * + * ?z -> Meta(n) + * + * we can reverse the equation, put it into our metavar + * substitution, and keep going. + * + * The most efficient mimick possible is, for each + * Meta-var remaining in the term, to declare a + * new EVAR of the same type. This is supposedly + * determinable from the clausale form context - + * we look up the metavar, take its type there, + * and apply the metavar substitution to it, to + * close it off. But this might not always work, + * since other metavars might also need to be resolved. *) + +let applyHead env evd n c = + let rec apprec n c cty evd = + if Int.equal n 0 then + (evd, c) + else + match EConstr.kind evd (whd_all env evd cty) with + | Prod (_,c1,c2) -> + let (evd',evar) = + Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in + apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' + | _ -> user_err Pp.(str "Apply_Head_Then") + in + apprec n c (Typing.unsafe_type_of env evd c) evd + +let is_mimick_head sigma ts f = + match EConstr.kind sigma f with + | Const (c,u) -> not (TransparentState.is_transparent_constant ts c) + | Var id -> not (TransparentState.is_transparent_variable ts id) + | (Rel _|Construct _|Ind _) -> true + | _ -> false + +let try_to_coerce env evd c cty tycon = + let j = make_judge c cty in + let (evd',j') = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in + let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in + let evd' = Evd.map_metas_fvalue (fun c -> nf_evar evd' c) evd' in + (evd',j'.uj_val) + +let w_coerce_to_type env evd c cty mvty = + let evd,tycon = pose_all_metas_as_evars env evd mvty in + try try_to_coerce env evd c cty tycon + with e when precatchable_exception e -> + (* inh_conv_coerce_rigid_to should have reasoned modulo reduction + but there are cases where it though it was not rigid (like in + fst (nat,nat)) and stops while it could have seen that it is rigid *) + let cty = Tacred.hnf_constr env evd cty in + try_to_coerce env evd c cty tycon + +let w_coerce env evd mv c = + let cty = get_type_of env evd c in + let mvty = Typing.meta_type evd mv in + w_coerce_to_type env evd c cty mvty + +let unify_to_type env sigma flags c status u = + let sigma, c = refresh_universes (Some false) env sigma c in + let t = get_type_of env sigma (nf_meta sigma c) in + let t = nf_betaiota env sigma (nf_meta sigma t) in + unify_0 env sigma CUMUL flags t u + +let unify_type env sigma flags mv status c = + let mvty = Typing.meta_type sigma mv in + let mvty = nf_meta sigma mvty in + unify_to_type env sigma + (set_flags_for_type flags) + c status mvty + +(* Move metas that may need coercion at the end of the list of instances *) + +let order_metas metas = + let rec order latemetas = function + | [] -> List.rev latemetas + | (_,_,(_,CoerceToType) as meta)::metas -> + order (meta::latemetas) metas + | (_,_,(_,_) as meta)::metas -> + meta :: order latemetas metas + in order [] metas + +(* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) + +let solve_simple_evar_eqn flags env evd ev rhs = + match solve_simple_eqn Evarconv.evar_unify flags env evd (None,ev,rhs) with + | UnifFailure (evd,reason) -> + error_cannot_unify env evd ~reason (mkEvar ev,rhs); + | Success evd -> evd + +(* [w_merge env sigma b metas evars] merges common instances in metas + or in evars, possibly generating new unification problems; if [b] + is true, unification of types of metas is required *) + +let w_merge env with_types flags (evd,metas,evars : subst0) = + let eflags = Evarconv.default_flags_of flags.modulo_delta_types in + let rec w_merge_rec evd metas evars eqns = + + (* Process evars *) + match evars with + | (curenv,(evk,_ as ev),rhs)::evars' -> + if Evd.is_defined evd evk then + let v = mkEvar ev in + let (evd,metas',evars'') = + unify_0 curenv evd CONV flags rhs v in + w_merge_rec evd (metas'@metas) (evars''@evars') eqns + else begin + (* This can make rhs' ill-typed if metas are *) + let rhs' = subst_meta_instances evd metas rhs in + match EConstr.kind evd rhs with + | App (f,cl) when occur_meta evd rhs' -> + if occur_evar evd evk rhs' then + error_occur_check curenv evd evk rhs'; + if is_mimick_head evd flags.modulo_delta f then + let evd' = + mimick_undefined_evar evd flags f (Array.length cl) evk in + w_merge_rec evd' metas evars eqns + else + let evd' = + let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in + try solve_simple_evar_eqn eflags curenv evd' ev rhs'' + with Retyping.RetypeError _ -> + error_cannot_unify curenv evd' (mkEvar ev,rhs'') + in w_merge_rec evd' metas evars' eqns + | _ -> + let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in + let evd' = + try solve_simple_evar_eqn eflags curenv evd' ev rhs'' + with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') + in + w_merge_rec evd' metas evars' eqns + end + | [] -> + + (* Process metas *) + match metas with + | (mv,c,(status,to_type))::metas -> + let ((evd,c),(metas'',evars'')),eqns = + if with_types && to_type != TypeProcessed then + begin match to_type with + | CoerceToType -> + (* Some coercion may have to be inserted *) + (w_coerce env evd mv c,([],[])),eqns + | _ -> + (* No coercion needed: delay the unification of types *) + ((evd,c),([],[])),(mv,status,c)::eqns + end + else + ((evd,c),([],[])),eqns + in + if meta_defined evd mv then + let {rebus=c'},(status',_) = meta_fvalue evd mv in + let (take_left,st,(evd,metas',evars')) = + merge_instances env evd flags status' status c' c + in + let evd' = + if take_left then evd + else meta_reassign mv (c,(st,TypeProcessed)) evd + in + w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns + else + let evd' = + if occur_meta_evd evd mv c then + if isMetaOf evd mv (whd_all env evd c) then evd + else error_cannot_unify env evd (mkMeta mv,c) + else + meta_assign mv (c,(status,TypeProcessed)) evd in + w_merge_rec evd' (metas''@metas) evars'' eqns + | [] -> + (* Process type eqns *) + let rec process_eqns failures = function + | (mv,status,c)::eqns -> + (match (try Inl (unify_type env evd flags mv status c) + with e when CErrors.noncritical e -> Inr e) + with + | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns + | Inl (evd,metas,evars) -> + w_merge_rec evd metas evars (List.map fst failures @ eqns)) + | [] -> + (match failures with + | [] -> evd + | ((mv,status,c),e)::_ -> raise e) + in process_eqns [] eqns + + and mimick_undefined_evar evd flags hdc nargs sp = + let ev = Evd.find_undefined evd sp in + let sp_env = reset_with_named_context (evar_filtered_hyps ev) env in + let (evd', c) = applyHead sp_env evd nargs hdc in + let (evd'',mc,ec) = + unify_0 sp_env evd' CUMUL flags + (get_type_of sp_env evd' c) ev.evar_concl in + let evd''' = w_merge_rec evd'' mc ec [] in + if evd' == evd''' + then Evd.define sp c evd''' + else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in + + let check_types evd = + let metas = Evd.meta_list evd in + let eqns = List.fold_left (fun acc (mv, b) -> + match b with + | Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, t.rebus) :: acc + | _ -> acc) [] metas + in w_merge_rec evd [] [] eqns + in + let res = (* merge constraints *) + w_merge_rec evd (order_metas metas) + (* Assign evars in the order of assignments during unification *) + (List.rev evars) [] + in + if with_types then check_types res else res + +let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = + let metas,evd = retract_coercible_metas evd in + w_merge env true flags.merge_unify_flags (evd,metas,[]) + +(* [w_unify env evd M N] + performs a unification of M and N, generating a bunch of + unification constraints in the process. These constraints + are processed, one-by-one - they may either generate new + bindings, or, if there is already a binding, new unifications, + which themselves generate new constraints. This continues + until we get failure, or we run out of constraints. + [clenv_typed_unify M N clenv] expects in addition that expected + types of metavars are unifiable with the types of their instances *) + +let head_app sigma m = + fst (whd_nored_state sigma (m, Stack.empty)) + +let isEvar_or_Meta sigma c = match EConstr.kind sigma c with +| Evar _ | Meta _ -> true +| _ -> false + +let check_types env flags (sigma,_,_ as subst) m n = + if isEvar_or_Meta sigma (head_app sigma m) then + unify_0_with_initial_metas subst true env CUMUL + flags + (get_type_of env sigma n) + (get_type_of env sigma m) + else if isEvar_or_Meta sigma (head_app sigma n) then + unify_0_with_initial_metas subst true env CUMUL + flags + (get_type_of env sigma m) + (get_type_of env sigma n) + else subst + +let try_resolve_typeclasses env evd flag m n = + if flag then + Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false + ~fail:true env evd + else evd + +let w_unify_core_0 env evd with_types cv_pb flags m n = + let (mc1,evd') = retract_coercible_metas evd in + let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) m n in + let subst2 = + unify_0_with_initial_metas (sigma,ms,es) false env cv_pb + flags.core_unify_flags m n + in + let evd = w_merge env with_types flags.merge_unify_flags subst2 in + try_resolve_typeclasses env evd flags.resolve_evars m n + +let w_typed_unify env evd = w_unify_core_0 env evd true + +let w_typed_unify_array env evd flags f1 l1 f2 l2 = + let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in + let (mc1,evd') = retract_coercible_metas evd in + let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in + let subst = fold_subst (evd', [], []) f1 f2 in + let subst = Array.fold_left2 fold_subst subst l1 l2 in + let evd = w_merge env true flags.merge_unify_flags subst in + try_resolve_typeclasses env evd flags.resolve_evars + (mkApp(f1,l1)) (mkApp(f2,l2)) + +(* takes a substitution s, an open term op and a closed term cl + try to find a subterm of cl which matches op, if op is just a Meta + FAIL because we cannot find a binding *) + +let iter_fail f a = + let n = Array.length a in + let rec ffail i = + if Int.equal i n then user_err Pp.(str "iter_fail") + else + try f a.(i) + with ex when precatchable_exception ex -> ffail (i+1) + in ffail 0 + +(* make_abstraction: a variant of w_unify_to_subterm which works on + contexts, with evars, and possibly with occurrences *) + +let indirectly_dependent sigma c d decls = + not (isVar sigma c) && + (* This test is not needed if the original term is a variable, but + it is needed otherwise, as e.g. when abstracting over "2" in + "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious + way to see that the second hypothesis depends indirectly over 2 *) + let open Context.Named.Declaration in + List.exists (fun d' -> exists (fun c -> Termops.local_occur_var sigma (NamedDecl.get_id d') c) d) decls + +let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = + let sigma = Pretyping.solve_remaining_evars flags env current_sigma ~initial:pending in + (sigma, nf_evar sigma c) + +let default_matching_core_flags sigma = + let ts = TransparentState.full in { + modulo_conv_on_closed_terms = Some TransparentState.empty; + use_metas_eagerly_in_conv_on_closed_terms = false; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = TransparentState.empty; + modulo_delta_types = ts; + check_applied_meta_types = true; + use_pattern_unification = false; + use_meta_bound_pattern_unification = false; + frozen_evars = Evar.Map.domain (Evd.undefined_map sigma); + restrict_conv_on_strict_subterms = false; + modulo_betaiota = false; + modulo_eta = false; +} + +let default_matching_merge_flags sigma = + let ts = TransparentState.full in + let flags = default_matching_core_flags sigma in { + flags with + modulo_conv_on_closed_terms = Some ts; + modulo_delta = ts; + modulo_betaiota = true; + modulo_eta = true; + use_pattern_unification = true; +} + +let default_matching_flags sigma = + let flags = default_matching_core_flags sigma in { + core_unify_flags = flags; + merge_unify_flags = default_matching_merge_flags sigma; + subterm_unify_flags = flags; (* does not matter *) + resolve_evars = false; + allow_K_in_toplevel_higher_order_unification = false; +} + +(* This supports search of occurrences of term from a pattern *) +(* from_prefix is useful e.g. for subterms in an inductive type: we can say *) +(* "destruct t" and it finds "t u" *) + +exception PatternNotFound + +let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = + let flags = + if from_prefix_of_ind then + let flags = default_matching_flags pending in + { flags with core_unify_flags = { flags.core_unify_flags with + modulo_conv_on_closed_terms = Some TransparentState.full; + restrict_conv_on_strict_subterms = true } } + else default_matching_flags pending in + let n = Array.length (snd (decompose_app_vect sigma c)) in + let matching_fun _ t = + try + let t',l2 = + if from_prefix_of_ind then + (* We check for fully applied subterms of the form "u u1 .. un" *) + (* of inductive type knowing only a prefix "u u1 .. ui" *) + let t,l = decompose_app sigma t in + let l1,l2 = + try List.chop n l with Failure _ -> raise (NotUnifiable None) in + if not (List.for_all (fun c -> Vars.closed0 sigma c) l2) then raise (NotUnifiable None) + else + applist (t,l1), l2 + else t, [] in + let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in + let ty = Retyping.get_type_of env sigma t in + if not (is_correct_type ty) then raise (NotUnifiable None); + Some(sigma, t, l2) + with + | PretypeError (_,_,CannotUnify (c1,c2,Some e)) -> + raise (NotUnifiable (Some (c1,c2,e))) + (* MS: This is pretty bad, it catches Not_found for example *) + | e when CErrors.noncritical e -> raise (NotUnifiable None) in + let merge_fun c1 c2 = + match c1, c2 with + | Some (evd,c1,x), Some (_,c2,_) -> + begin match infer_conv ~pb:CONV env evd c1 c2 with + | Some evd -> Some (evd, c1, x) + | None -> raise (NotUnifiable None) + end + | Some _, None -> c1 + | None, Some _ -> c2 + | None, None -> None in + { match_fun = matching_fun; merge_fun = merge_fun; + testing_state = None; last_found = None }, + (fun test -> match test.testing_state with + | None -> None + | Some (sigma,_,l) -> + let c = applist (local_strong whd_meta sigma c, l) in + Some (sigma, c)) + +let make_eq_test env evd c = + let out cstr = + match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, c) + in + (make_eq_univs_test env evd c, out) + +let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = + let id = + let t = match ty with Some t -> t | None -> get_type_of env sigma c in + let x = id_of_name_using_hdchar env sigma t name in + let ids = Environ.ids_of_named_context_val (named_context_val env) in + if name == Anonymous then next_ident_away_in_goal x ids else + if mem_named_context_val x (named_context_val env) then + user_err ~hdr:"Unification.make_abstraction_core" + (str "The variable " ++ Id.print x ++ str " is already declared.") + else + x + in + let likefirst = clause_with_generic_occurrences occs in + let mkvarid () = EConstr.mkVar id in + let compute_dependency _ d (sign,depdecls) = + let d = map_named_decl EConstr.of_constr d in + let hyp = NamedDecl.get_id d in + match occurrences_of_hyp hyp occs with + | NoOccurrences, InHyp -> + (push_named_context_val d sign,depdecls) + | (AllOccurrences | AtLeastOneOccurrence), InHyp as occ -> + let occ = if likefirst then LikeFirst else AtOccs occ in + let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in + if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl + && not (indirectly_dependent sigma c d depdecls) + then + if check_occs && not (in_every_hyp occs) + then raise (PretypeError (env,sigma,NoOccurrenceFound (c,Some hyp))) + else (push_named_context_val d sign, depdecls) + else + (push_named_context_val newdecl sign, newdecl :: depdecls) + | occ -> + (* There are specific occurrences, hence not like first *) + let newdecl = replace_term_occ_decl_modulo sigma (AtOccs occ) test mkvarid d in + (push_named_context_val newdecl sign, newdecl :: depdecls) in + try + let sign,depdecls = + fold_named_context compute_dependency env + ~init:(empty_named_context_val,[]) in + let ccl = match occurrences_of_goal occs with + | NoOccurrences -> concl + | occ -> + let occ = if likefirst then LikeFirst else AtOccs occ in + replace_term_occ_modulo sigma occ test mkvarid concl + in + let lastlhyp = + if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in + let res = match out test with + | None -> None + | Some (sigma, c) -> Some (sigma,c) + in + (id,sign,depdecls,lastlhyp,ccl,res) + with + SubtermUnificationError e -> + raise (PretypeError (env,sigma,CannotUnifyOccurrences e)) + +(** [make_abstraction] is the main entry point to abstract over a term + or pattern at some occurrences; it returns: + - the id used for the abstraction + - the type of the abstraction + - the declarations from the context which depend on the term or pattern + - the most recent hyp before which there is no dependency in the term of pattern + - the abstracted conclusion + - an evar universe context effect to apply on the goal + - the term or pattern to abstract fully instantiated +*) + +type prefix_of_inductive_support_flag = bool + +type abstraction_request = +| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * (evar_map * constr) * clause * bool +| AbstractExact of Name.t * constr * types option * clause * bool + +type 'r abstraction_result = + Names.Id.t * named_context_val * + named_declaration list * Names.Id.t option * + types * (evar_map * constr) option + +let make_abstraction env evd ccl abs = + match abs with + | AbstractPattern (from_prefix,check,name,c,occs,check_occs) -> + make_abstraction_core name + (make_pattern_test from_prefix check env evd c) + env evd (snd c) None occs check_occs ccl + | AbstractExact (name,c,ty,occs,check_occs) -> + make_abstraction_core name + (make_eq_test env evd c) + env evd c ty occs check_occs ccl + +let keyed_unify env evd kop = + if not !keyed_unification then fun cl -> true + else + match kop with + | None -> fun _ -> true + | Some kop -> + fun cl -> + let kc = Keys.constr_key (fun c -> EConstr.kind evd c) cl in + match kc with + | None -> false + | Some kc -> Keys.equiv_keys kop kc + +(* Tries to find an instance of term [cl] in term [op]. + Unifies [cl] to every subterm of [op] until it finds a match. + Fails if no match is found *) +let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = + let bestexn = ref None in + let kop = Keys.constr_key (fun c -> EConstr.kind evd c) op in + let rec matchrec cl = + let cl = strip_outer_cast evd cl in + (try + if closed0 evd cl && not (isEvar evd cl) && keyed_unify env evd kop cl then + (try + if !keyed_unification then + let f1, l1 = decompose_app_vect evd op in + let f2, l2 = decompose_app_vect evd cl in + w_typed_unify_array env evd flags f1 l1 f2 l2,cl + else w_typed_unify env evd CONV flags op cl,cl + with ex when Pretype_errors.unsatisfiable_exception ex -> + bestexn := Some ex; user_err Pp.(str "Unsat")) + else user_err Pp.(str "Bound 1") + with ex when precatchable_exception ex -> + (match EConstr.kind evd cl with + | App (f,args) -> + let n = Array.length args in + assert (n>0); + let c1 = mkApp (f,Array.sub args 0 (n-1)) in + let c2 = args.(n-1) in + (try + matchrec c1 + with ex when precatchable_exception ex -> + matchrec c2) + | Case(_,_,c,lf) -> (* does not search in the predicate *) + (try + matchrec c + with ex when precatchable_exception ex -> + iter_fail matchrec lf) + | LetIn(_,c1,_,c2) -> + (try + matchrec c1 + with ex when precatchable_exception ex -> + matchrec c2) + + | Proj (p,c) -> matchrec c + + | Fix(_,(_,types,terms)) -> + (try + iter_fail matchrec types + with ex when precatchable_exception ex -> + iter_fail matchrec terms) + + | CoFix(_,(_,types,terms)) -> + (try + iter_fail matchrec types + with ex when precatchable_exception ex -> + iter_fail matchrec terms) + + | Prod (_,t,c) -> + (try + matchrec t + with ex when precatchable_exception ex -> + matchrec c) + + | Lambda (_,t,c) -> + (try + matchrec t + with ex when precatchable_exception ex -> + matchrec c) + + | Cast (_, _, _) (* Is this expected? *) + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ + | Construct _ | Int _ -> user_err Pp.(str "Match_subterm"))) + in + try matchrec cl + with ex when precatchable_exception ex -> + match !bestexn with + | None -> raise (PretypeError (env,evd,NoOccurrenceFound (op, None))) + | Some e -> raise e + +(* Tries to find all instances of term [cl] in term [op]. + Unifies [cl] to every subterm of [op] and return all the matches. + Fails if no match is found *) +let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = + let return a b = + let (evd,c as a) = a () in + if List.exists (fun (evd',c') -> EConstr.eq_constr evd' c c') b then b else a :: b + in + let fail str _ = user_err (Pp.str str) in + let bind f g a = + let a1 = try f a + with ex + when precatchable_exception ex -> a + in try g a1 + with ex + when precatchable_exception ex -> a1 + in + let bind_iter f a = + let n = Array.length a in + let rec ffail i = + if Int.equal i n then fun a -> a + else bind (f a.(i)) (ffail (i+1)) + in ffail 0 + in + let rec matchrec cl = + let cl = strip_outer_cast evd cl in + (bind + (if closed0 evd cl + then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) + else fail "Bound 1") + (match EConstr.kind evd cl with + | App (f,args) -> + let n = Array.length args in + assert (n>0); + let c1 = mkApp (f,Array.sub args 0 (n-1)) in + let c2 = args.(n-1) in + bind (matchrec c1) (matchrec c2) + + | Case(_,_,c,lf) -> (* does not search in the predicate *) + bind (matchrec c) (bind_iter matchrec lf) + + | Proj (p,c) -> matchrec c + + | LetIn(_,c1,_,c2) -> + bind (matchrec c1) (matchrec c2) + + | Fix(_,(_,types,terms)) -> + bind (bind_iter matchrec types) (bind_iter matchrec terms) + + | CoFix(_,(_,types,terms)) -> + bind (bind_iter matchrec types) (bind_iter matchrec terms) + + | Prod (_,t,c) -> + bind (matchrec t) (matchrec c) + + | Lambda (_,t,c) -> + bind (matchrec t) (matchrec c) + + | Cast (_, _, _) -> fail "Match_subterm" (* Is this expected? *) + + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ + | Construct _ | Int _ -> fail "Match_subterm")) + + in + let res = matchrec cl [] in + match res with + | [] -> + raise (PretypeError (env,evd,NoOccurrenceFound (op, None))) + | _ -> res + +let w_unify_to_subterm_list env evd flags hdmeta oplist t = + List.fold_right + (fun op (evd,l) -> + let op = whd_meta evd op in + if isMeta evd op then + if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) + else error_abstraction_over_meta env evd hdmeta (destMeta evd op) + else + let allow_K = flags.allow_K_in_toplevel_higher_order_unification in + let flags = + if unsafe_occur_meta_or_existential op || !keyed_unification then + (* This is up to delta for subterms w/o metas ... *) + flags + else + (* up to Nov 2014, unification was bypassed on evar/meta-free terms; + now it is called in a minimalistic way, at least to possibly + unify pre-existing non frozen evars of the goal or of the + pattern *) + set_no_delta_flags flags in + let t' = (strip_outer_cast evd op,t) in + let (evd',cl) = + try + if is_keyed_unification () then + try (* First try finding a subterm w/o conversion on open terms *) + let flags = set_no_delta_open_flags flags in + w_unify_to_subterm env evd ~flags t' + with e -> + (* If this fails, try with full conversion *) + w_unify_to_subterm env evd ~flags t' + else w_unify_to_subterm env evd ~flags t' + with PretypeError (env,_,NoOccurrenceFound _) when + allow_K || + (* w_unify_to_subterm does not go through evars, so + the next step, which was already in <= 8.4, is + needed at least for compatibility of rewrite *) + dependent evd op t -> (evd,op) + in + if not allow_K && + (* ensure we found a different instance *) + List.exists (fun op -> EConstr.eq_constr evd' op cl) l + then error_non_linear_unification env evd hdmeta cl + else (evd',cl::l)) + oplist + (evd,[]) + +let secondOrderAbstraction env evd flags typ (p, oplist) = + (* Remove delta when looking for a subterm *) + let flags = { flags with core_unify_flags = flags.subterm_unify_flags } in + let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in + let typp = Typing.meta_type evd' p in + let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in + match infer_conv ~pb:CUMUL env evd' predtyp typp with + | None -> + error_wrong_abstraction_type env evd' + (Evd.meta_name evd p) pred typp predtyp; + | Some evd' -> + w_merge env false flags.merge_unify_flags + (evd',[p,pred,(Conv,TypeProcessed)],[]) + +let secondOrderDependentAbstraction env evd flags typ (p, oplist) = + let typp = Typing.meta_type evd p in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in + w_merge env false flags.merge_unify_flags + (evd,[p,pred,(Conv,TypeProcessed)],[]) + + +let secondOrderAbstractionAlgo dep = + if dep then secondOrderDependentAbstraction else secondOrderAbstraction + +let w_unify2 env evd flags dep cv_pb ty1 ty2 = + let c1, oplist1 = whd_nored_stack evd ty1 in + let c2, oplist2 = whd_nored_stack evd ty2 in + match EConstr.kind evd c1, EConstr.kind evd c2 with + | Meta p1, _ -> + (* Find the predicate *) + secondOrderAbstractionAlgo dep env evd flags ty2 (p1, oplist1) + | _, Meta p2 -> + (* Find the predicate *) + secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2) + | _ -> user_err Pp.(str "w_unify2") + +(* The unique unification algorithm works like this: If the pattern is + flexible, and the goal has a lambda-abstraction at the head, then + we do a first-order unification. + + If the pattern is not flexible, then we do a first-order + unification, too. + + If the pattern is flexible, and the goal doesn't have a + lambda-abstraction head, then we second-order unification. *) + +(* We decide here if first-order or second-order unif is used for Apply *) +(* We apply a term of type (ai:Ai)C and try to solve a goal C' *) +(* The type C is in clenv.templtyp.rebus with a lot of Meta to solve *) + +(* 3-4-99 [HH] New fo/so choice heuristic : + In case we have to unify (Meta(1) args) with ([x:A]t args') + we first try second-order unification and if it fails first-order. + Before, second-order was used if the type of Meta(1) and [x:A]t was + convertible and first-order otherwise. But if failed if e.g. the type of + Meta(1) had meta-variables in it. *) +let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = + let hd1,l1 = decompose_app_vect evd (whd_nored evd ty1) in + let hd2,l2 = decompose_app_vect evd (whd_nored evd ty2) in + let is_empty1 = Array.is_empty l1 in + let is_empty2 = Array.is_empty l2 in + match EConstr.kind evd hd1, not is_empty1, EConstr.kind evd hd2, not is_empty2 with + (* Pattern case *) + | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true) + when Int.equal (Array.length l1) (Array.length l2) -> + (try + w_typed_unify_array env evd flags hd1 l1 hd2 l2 + with ex when precatchable_exception ex -> + try + w_unify2 env evd flags false cv_pb ty1 ty2 + with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e) + + (* Second order case *) + | (Meta _, true, _, _ | _, _, Meta _, true) -> + (try + w_unify2 env evd flags false cv_pb ty1 ty2 + with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e + | ex when precatchable_exception ex -> + try + w_typed_unify_array env evd flags hd1 l1 hd2 l2 + with ex' when precatchable_exception ex' -> + (* Last chance, use pattern-matching with typed + dependencies (done late for compatibility) *) + try + w_unify2 env evd flags true cv_pb ty1 ty2 + with ex' when precatchable_exception ex' -> + raise ex) + + (* General case: try first order *) + | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + +(* Profiling *) + +let w_unify env evd cv_pb flags ty1 ty2 = + w_unify env evd cv_pb ~flags:flags ty1 ty2 + +let w_unify = + if Flags.profile then + let wunifkey = CProfile.declare_profile "w_unify" in + CProfile.profile6 wunifkey w_unify + else w_unify + +let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = + w_unify env evd cv_pb flags ty1 ty2 diff --git a/pretyping/unification.mli b/pretyping/unification.mli new file mode 100644 index 0000000000..a45b8f1dd8 --- /dev/null +++ b/pretyping/unification.mli @@ -0,0 +1,128 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open EConstr +open Environ +open Evd + +type core_unify_flags = { + modulo_conv_on_closed_terms : TransparentState.t option; + use_metas_eagerly_in_conv_on_closed_terms : bool; + use_evars_eagerly_in_conv_on_closed_terms : bool; + modulo_delta : TransparentState.t; + modulo_delta_types : TransparentState.t; + check_applied_meta_types : bool; + use_pattern_unification : bool; + use_meta_bound_pattern_unification : bool; + frozen_evars : Evar.Set.t; + restrict_conv_on_strict_subterms : bool; + modulo_betaiota : bool; + modulo_eta : bool; +} + +type unify_flags = { + core_unify_flags : core_unify_flags; + merge_unify_flags : core_unify_flags; + subterm_unify_flags : core_unify_flags; + allow_K_in_toplevel_higher_order_unification : bool; + resolve_evars : bool +} + +val default_core_unify_flags : unit -> core_unify_flags +val default_no_delta_core_unify_flags : unit -> core_unify_flags + +val default_unify_flags : unit -> unify_flags +val default_no_delta_unify_flags : TransparentState.t -> unify_flags + +val elim_flags : unit -> unify_flags +val elim_no_delta_flags : unit -> unify_flags + +val is_keyed_unification : unit -> bool + +(** The "unique" unification function *) +val w_unify : + env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map + +(** [w_unify_to_subterm env m (c,t)] performs unification of [c] with a + subterm of [t]. Constraints are added to [m] and the matched + subterm of [t] is also returned. *) +val w_unify_to_subterm : + env -> evar_map -> ?flags:unify_flags -> constr * constr -> evar_map * constr + +val w_unify_to_subterm_all : + env -> evar_map -> ?flags:unify_flags -> constr * constr -> (evar_map * constr) list + +val w_unify_meta_types : env -> ?flags:unify_flags -> evar_map -> evar_map + +(** [w_coerce_to_type env evd c ctyp typ] tries to coerce [c] of type + [ctyp] so that its gets type [typ]; [typ] may contain metavariables *) +val w_coerce_to_type : env -> evar_map -> constr -> types -> types -> + evar_map * constr + +(* Looking for subterms in contexts at some occurrences, possibly with pattern*) + +exception PatternNotFound + +type prefix_of_inductive_support_flag = bool + +type abstraction_request = +| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Names.Name.t * (evar_map * constr) * Locus.clause * bool +| AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool + +val finish_evar_resolution : ?flags:Pretyping.inference_flags -> + env -> evar_map -> (evar_map * constr) -> evar_map * constr + +type 'r abstraction_result = + Names.Id.t * named_context_val * + named_declaration list * Names.Id.t option * + types * (evar_map * constr) option + +val make_abstraction : env -> evar_map -> constr -> + abstraction_request -> 'r abstraction_result + +val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr + +(*i This should be in another module i*) + +(** [abstract_list_all env evd t c l] + abstracts the terms in l over c to get a term of type t + (exported for inv.ml) *) +val abstract_list_all : + env -> evar_map -> constr -> constr -> constr list -> evar_map * (constr * types) + +(* For tracing *) + +type metabinding = (metavariable * constr * (instance_constraint * instance_typing_status)) + +type subst0 = + (evar_map * + metabinding list * + (Environ.env * existential * t) list) + +val w_merge : env -> bool -> core_unify_flags -> subst0 -> evar_map + +val unify_0 : Environ.env -> + Evd.evar_map -> + Evd.conv_pb -> + core_unify_flags -> + types -> + types -> + subst0 + +val unify_0_with_initial_metas : + subst0 -> + bool -> + Environ.env -> + Evd.conv_pb -> + core_unify_flags -> + types -> + types -> + subst0 diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml new file mode 100644 index 0000000000..62e9e477f7 --- /dev/null +++ b/pretyping/vnorm.ml @@ -0,0 +1,408 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Declarations +open Term +open Constr +open Context +open Vars +open Environ +open Inductive +open Reduction +open Vmvalues +open Vm +open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(*******************************************) +(* Calcul de la forme normal d'un terme *) +(*******************************************) + +let crazy_type = mkSet + +let decompose_prod env t = + let (name,dom,codom) = destProd (whd_all env t) in + let name = map_annot (function + | Anonymous -> Name (Id.of_string "x") + | Name _ as na -> na) name + in + (name,dom,codom) + +exception Find_at of int + +(* rend le numero du constructeur correspondant au tag [tag], + [cst] = true si c'est un constructeur constant *) + +let invert_tag cst tag reloc_tbl = + try + for j = 0 to Array.length reloc_tbl - 1 do + let tagj,arity = reloc_tbl.(j) in + let no_arity = Int.equal arity 0 in + if Int.equal tag tagj && (cst && no_arity || not (cst || no_arity)) then + raise (Find_at j) + else () + done;raise Not_found + with Find_at j -> (j+1) + (* Argggg, ces constructeurs de ... qui commencent a 1*) + +let find_rectype_a env c = + let (t, l) = decompose_appvect (whd_all env c) in + match kind t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +(* Instantiate inductives and parameters in constructor type *) + +let type_constructor mind mib u (ctx, typ) params = + let typ = it_mkProd_or_LetIn typ ctx in + let s = ind_subst mind mib u in + let ctyp = substl s typ in + let ctyp = subst_instance_constr u ctyp in + let ndecls = Context.Rel.length mib.mind_params_ctxt in + if Int.equal ndecls 0 then ctyp + else + let _,ctyp = decompose_prod_n_assum ndecls ctyp in + substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + ctyp + + + +let construct_of_constr const env tag typ = + let (t, allargs) = decompose_appvect (whd_all env typ) in + match Constr.kind t with + | Ind ((mind,_ as ind), u as indu) -> + let mib,mip = lookup_mind_specif env ind in + let nparams = mib.mind_nparams in + let i = invert_tag const tag mip.mind_reloc_tbl in + let params = Array.sub allargs 0 nparams in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstructUi(indu,i), params), ctyp) + | _ -> + assert (Constr.equal t (Typeops.type_of_int env)); + (mkInt (Uint63.of_int tag), t) + +let construct_of_constr_const env tag typ = + fst (construct_of_constr true env tag typ) + +let construct_of_constr_block = construct_of_constr false + +let type_of_ind env (ind, u) = + type_of_inductive env (Inductive.lookup_mind_specif env ind, u) + +let build_branches_type env sigma (mind,_ as _ind) mib mip u params p = + let rtbl = mip.mind_reloc_tbl in + (* [build_one_branch i cty] construit le type de la ieme branche (commence + a 0) et les lambda correspondant aux realargs *) + let build_one_branch i cty = + let typi = type_constructor mind mib u cty params in + let decl,indapp = Reductionops.splay_prod env sigma (EConstr.of_constr typi) in + let decl = List.map (on_snd EConstr.Unsafe.to_constr) decl in + let indapp = EConstr.Unsafe.to_constr indapp in + let decl_with_letin,_ = decompose_prod_assum typi in + let ((ind,u),cargs) = find_rectype_a env indapp in + let nparams = Array.length params in + let carity = snd (rtbl.(i)) in + let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in + let codom = + let ndecl = List.length decl in + let papp = mkApp(lift ndecl p,crealargs) in + let cstr = ith_constructor_of_inductive ind (i+1) in + let relargs = Array.init carity (fun i -> mkRel (carity-i)) in + let params = Array.map (lift ndecl) params in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,u),params),relargs) in + mkApp(papp,[|dep_cstr|]) + in + decl, decl_with_letin, codom + in Array.mapi build_one_branch mip.mind_nf_lc + +let build_case_type p realargs c = + mkApp(mkApp(p, realargs), [|c|]) + +(* La fonction de normalisation *) + +let rec nf_val env sigma v t = nf_whd env sigma (Vmvalues.whd_val v) t + +and nf_vtype env sigma v = nf_val env sigma v crazy_type + +and nf_whd env sigma whd typ = + match whd with + | Vprod p -> + let dom = nf_vtype env sigma (dom p) in + let name = Name (Id.of_string "x") in + let vc = reduce_fun (nb_rel env) (codom p) in + let r = Retyping.relevance_of_type env sigma (EConstr.of_constr dom) in + let name = make_annot name r in + let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vc in + mkProd(name,dom,codom) + | Vfun f -> nf_fun env sigma f typ + | Vfix(f,None) -> nf_fix env sigma f + | Vfix(f,Some vargs) -> fst (nf_fix_app env sigma f vargs) + | Vcofix(cf,_,None) -> nf_cofix env sigma cf + | Vcofix(cf,_,Some vargs) -> + let cfd = nf_cofix env sigma cf in + let i,(_,ta,_) = destCoFix cfd in + let t = ta.(i) in + let _, args = nf_args env sigma vargs t in + mkApp(cfd,args) + | Vconstr_const n -> + construct_of_constr_const env n typ + | Vconstr_block b -> + let tag = btag b in + let (tag,ofs) = + if tag = Obj.last_non_constant_constructor_tag then + match whd_val (bfield b 0) with + | Vconstr_const tag -> (tag+Obj.last_non_constant_constructor_tag, 1) + | _ -> assert false + else (tag, 0) in + let capp,ctyp = construct_of_constr_block env tag typ in + let args = nf_bargs env sigma b ofs ctyp in + mkApp(capp,args) + | Vint64 i -> i |> Uint63.of_int64 |> mkInt + | Vatom_stk(Aid idkey, stk) -> + constr_type_of_idkey env sigma idkey stk + | Vatom_stk(Aind ((mi,i) as ind), stk) -> + let mib = Environ.lookup_mind mi env in + let nb_univs = + Univ.AUContext.size (Declareops.inductive_polymorphic_context mib) + in + let mk u = + let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) + in + nf_univ_args ~nb_univs mk env sigma stk + | Vatom_stk(Asort s, stk) -> + assert (List.is_empty stk); mkSort s + | Vuniv_level lvl -> + assert false + +and nf_univ_args ~nb_univs mk env sigma stk = + let u = + if Int.equal nb_univs 0 then Univ.Instance.empty + else match stk with + | Zapp args :: _ -> + let inst = + Array.init nb_univs (fun i -> uni_lvl_val (arg args i)) + in + Univ.Instance.of_array inst + | _ -> assert false + in + let (t,ty) = mk u in + nf_stk ~from:nb_univs env sigma t ty stk + +and nf_evar env sigma evk stk = + let evi = try Evd.find sigma evk with Not_found -> assert false in + let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in + let concl = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in + if List.is_empty hyps then + nf_stk env sigma (mkEvar (evk, [||])) concl stk + else match stk with + | Zapp args :: stk -> + (* We assume that there is no consecutive Zapp nodes in a VM stack. Is that + really an invariant? *) + (* Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) + let hyps = Context.Named.drop_bodies hyps in + let fold accu d = Term.mkNamedProd_or_LetIn d accu in + let t = List.fold_left fold concl hyps in + let t, args = nf_args env sigma args t in + let inst, args = Array.chop (List.length hyps) args in + let c = mkApp (mkEvar (evk, inst), args) in + nf_stk env sigma c t stk + | _ -> + CErrors.anomaly (Pp.str "Argument size mismatch when decompiling an evar") + +and constr_type_of_idkey env sigma (idkey : Vmvalues.id_key) stk = + match idkey with + | ConstKey cst -> + let cbody = Environ.lookup_constant cst env in + let nb_univs = + Univ.AUContext.size (Declareops.constant_polymorphic_context cbody) + in + let mk u = + let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) + in + nf_univ_args ~nb_univs mk env sigma stk + | VarKey id -> + let ty = NamedDecl.get_type (lookup_named id env) in + nf_stk env sigma (mkVar id) ty stk + | RelKey i -> + let n = (nb_rel env - i) in + let ty = RelDecl.get_type (lookup_rel n env) in + nf_stk env sigma (mkRel n) (lift n ty) stk + | EvarKey evk -> + nf_evar env sigma evk stk + +and nf_stk ?from:(from=0) env sigma c t stk = + match stk with + | [] -> c + | Zapp vargs :: stk -> + if nargs vargs >= from then + let t, args = nf_args ~from:from env sigma vargs t in + nf_stk env sigma (mkApp(c,args)) t stk + else + let rest = from - nargs vargs in + nf_stk ~from:rest env sigma c t stk + | Zfix (f,vargs) :: stk -> + assert (from = 0) ; + let fa, typ = nf_fix_app env sigma f vargs in + let _,_,codom = decompose_prod env typ in + nf_stk env sigma (mkApp(fa,[|c|])) (subst1 c codom) stk + | Zswitch sw :: stk -> + assert (from = 0) ; + let ((mind,_ as ind), u), allargs = find_rectype_a env t in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nparams = mib.mind_nparams in + let params,realargs = Util.Array.chop nparams allargs in + let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in + let pT = + hnf_prod_applist_assum env nparamdecls (type_of_ind env (ind,u)) (Array.to_list params) in + let p = nf_predicate env sigma (ind,u) mip params (type_of_switch sw) pT in + (* Calcul du type des branches *) + let btypes = build_branches_type env sigma ind mib mip u params p in + (* calcul des branches *) + let bsw = branch_of_switch (nb_rel env) sw in + let mkbranch i (n,v) = + let decl,decl_with_letin,codom = btypes.(i) in + let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in + Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin + in + let branchs = Array.mapi mkbranch bsw in + let tcase = build_case_type p realargs c in + let ci = sw.sw_annot.Vmvalues.ci in + nf_stk env sigma (mkCase(ci, p, c, branchs)) tcase stk + | Zproj p :: stk -> + assert (from = 0) ; + let p' = Projection.make p true in + let ty = Inductiveops.type_of_projection_knowing_arg env sigma p' (EConstr.of_constr c) (EConstr.of_constr t) in + nf_stk env sigma (mkProj(p',c)) ty stk + +and nf_predicate env sigma ind mip params v pT = + match kind (whd_allnolet env pT) with + | LetIn (name,b,t,pT) -> + let body = + nf_predicate (push_rel (LocalDef (name,b,t)) env) sigma ind mip params v pT in + mkLetIn (name,b,t,body) + | Prod (name,dom,codom) -> begin + match whd_val v with + | Vfun f -> + let k = nb_rel env in + let vb = reduce_fun k f in + let body = + nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in + mkLambda(name,dom,body) + | _ -> assert false + end + | _ -> + match whd_val v with + | Vfun f -> + let k = nb_rel env in + let vb = reduce_fun k f in + let name = Name (Id.of_string "c") in + let n = mip.mind_nrealargs in + let rargs = Array.init n (fun i -> mkRel (n-i)) in + let params = if Int.equal n 0 then params else Array.map (lift n) params in + let dom = mkApp(mkIndU ind,Array.append params rargs) in + let r = Inductive.relevance_of_inductive env (fst ind) in + let name = make_annot name r in + let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vb in + mkLambda(name,dom,body) + | _ -> assert false + +and nf_args env sigma vargs ?from:(f=0) t = + let t = ref t in + let len = nargs vargs - f in + let args = + Array.init len + (fun i -> + let _,dom,codom = decompose_prod env !t in + let c = nf_val env sigma (arg vargs (f+i)) dom in + t := subst1 c codom; c) in + !t,args + +and nf_bargs env sigma b ofs t = + let t = ref t in + let len = bsize b - ofs in + let args = + Array.init len + (fun i -> + let _,dom,codom = decompose_prod env !t in + let c = nf_val env sigma (bfield b (i+ofs)) dom in + t := subst1 c codom; c) in + args + +and nf_fun env sigma f typ = + let k = nb_rel env in + let vb = reduce_fun k f in + let name,dom,codom = + try decompose_prod env typ + with DestKO -> + CErrors.anomaly + Pp.(strbrk "Returned a functional value in type " ++ + Termops.Internal.print_constr_env env sigma (EConstr.of_constr typ)) + in + let body = nf_val (push_rel (LocalAssum (name,dom)) env) sigma vb codom in + mkLambda(name,dom,body) + +and nf_fix env sigma f = + let init = current_fix f in + let rec_args = rec_args f in + let k = nb_rel env in + let vb, vt = reduce_fix k f in + let ndef = Array.length vt in + let ft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in + let name = Name (Id.of_string "Ffix") in + let names = Array.map (fun t -> + make_annot name @@ + Retyping.relevance_of_type env sigma (EConstr.of_constr t)) ft in + (* Body argument of the tuple is ignored by push_rec_types *) + let env = push_rec_types (names,ft,ft) env in + (* We lift here because the types of arguments (in tt) will be evaluated + in an environment where the fixpoints have been pushed *) + let norm_vb v t = nf_fun env sigma v (lift ndef t) in + let fb = Util.Array.map2 norm_vb vb ft in + mkFix ((rec_args,init),(names,ft,fb)) + +and nf_fix_app env sigma f vargs = + let fd = nf_fix env sigma f in + let (_,i),(_,ta,_) = destFix fd in + let t = ta.(i) in + let t, args = nf_args env sigma vargs t in + mkApp(fd,args),t + +and nf_cofix env sigma cf = + let init = current_cofix cf in + let k = nb_rel env in + let vb,vt = reduce_cofix k cf in + let cft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in + let name = Name (Id.of_string "Fcofix") in + let names = Array.map (fun t -> + make_annot name @@ + Retyping.relevance_of_type env sigma (EConstr.of_constr t)) cft in + let env = push_rec_types (names,cft,cft) env in + let cfb = Util.Array.map2 (fun v t -> nf_val env sigma v t) vb cft in + mkCoFix (init,(names,cft,cfb)) + +let cbv_vm env sigma c t = + if Termops.occur_meta sigma c then + CErrors.user_err Pp.(str "vm_compute does not support metas."); + (* This evar-normalizes terms beforehand *) + let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in + let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in + let v = Csymtable.val_of_constr env c in + EConstr.of_constr (nf_val env sigma v t) + +let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = + Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) + ~catch_incon:true ~pb env sigma t1 t2 + +let _ = if Coq_config.bytecode_compiler then Reductionops.set_vm_infer_conv vm_infer_conv diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli new file mode 100644 index 0000000000..3e0eabb013 --- /dev/null +++ b/pretyping/vnorm.mli @@ -0,0 +1,15 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open EConstr +open Environ + +(** {6 Reduction functions } *) +val cbv_vm : env -> Evd.evar_map -> constr -> types -> constr |