diff options
Diffstat (limited to 'pretyping')
| -rw-r--r-- | pretyping/indrec.ml | 15 | ||||
| -rw-r--r-- | pretyping/pretyping.ml | 11 | ||||
| -rw-r--r-- | pretyping/pretyping.mli | 8 |
3 files changed, 19 insertions, 15 deletions
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index c92c9a75a0..b5d81f762a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -530,22 +530,25 @@ let change_sort_arity sort = 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 = + let rec drec ctx np elim = match kind elim with | Prod (n,t,c) -> + let ctx = LocalAssum (n, t) :: ctx in 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))) + mkLambda (n, t', mkApp(term, Context.Rel.to_extended_vect mkRel 0 ctx)) else - let c',term' = drec (np-1) c in + let c',term' = drec ctx (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') + | LetIn (n,b,t,c) -> + let ctx = LocalDef (n, b, t) :: ctx in + let c',term' = drec ctx 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 + let ty, term = drec [] npars ty in !evdref, ty, term (**********************************************************************) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4bab3bd6ea..ded159e484 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -187,7 +187,7 @@ let interp_sort_info ?loc evd l = in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l -type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr +type inference_hook = env -> evar_map -> Evar.t -> (evar_map * constr) option type inference_flags = { use_typeclasses : bool; @@ -247,17 +247,16 @@ let apply_typeclasses ~program_mode env sigma frozen fail_evar = else sigma in sigma -let apply_inference_hook hook env sigma frozen = match frozen with +let apply_inference_hook (hook : inference_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 + match hook env sigma evk with + | Some (sigma, c) -> Evd.define evk c sigma - with Exit -> - sigma + | None -> sigma else sigma) pending sigma diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 700ca93c33..abbb745161 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -44,8 +44,6 @@ type typing_constraint = | OfType of types (** A term of the expected type *) | WithoutTypeConstraint (** A term of unknown expected type *) -type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr - type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; @@ -103,13 +101,17 @@ val understand_ltac : inference_flags -> val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context +(** [hook env sigma ev] returns [Some (sigma', term)] if [ev] can be + instantiated with a solution, [None] otherwise. Used to extend + [solve_remaining_evars] below. *) +type inference_hook = env -> evar_map -> Evar.t -> (evar_map * constr) option + (** 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 |