Enable canonical `fun _ => _` projections.

2 files changed, 12 insertions, 0 deletions

diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 5eb8a88698..d6ba84d0bf 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -232,7 +232,17 @@ let occur_rigidly flags env evd (evk,_) t =
 let check_conv_record env sigma (t1,sk1) (t2,sk2) =
   let open ValuePattern in
   let (proji, u), arg = Termops.global_app_of_constr sigma t1 in
+  let t2, sk2' = decompose_app_vect sigma (shrink_eta env t2) in
+  let sk2 = Stack.append_app sk2' sk2 in
   let (sigma, solution), sk2_effective =
+    let t2 =
+      let rec remove_lambda t2 =
+        match EConstr.kind sigma t2 with
+        | Lambda (_,_,t2) -> remove_lambda t2
+        | Cast (t2,_,_) -> remove_lambda t2
+        | App (t2,_) -> t2
+        | _ -> t2 in
+      if Stack.is_empty sk2 then remove_lambda t2 else t2 in
     try
       match EConstr.kind sigma t2 with
         Prod (_,a,b) -> (* assert (l2=[]); *)
diff --git a/pretyping/structures.ml b/pretyping/structures.ml
index 3ef6e98373..145663d3b9 100644
--- a/pretyping/structures.ml
+++ b/pretyping/structures.ml
@@ -161,6 +161,7 @@ let rec of_constr env t =
     let patt, n, args = of_constr env f in
     patt, n, args @ Array.to_list vargs
   | Rel n -> Default_cs, Some n, []
+  | Lambda (_, _, b) -> let patt, _, _ = of_constr env b in patt, None, []
   | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b]
   | Proj (p, c) -> Proj_cs (Names.Projection.repr p), None, [c]
   | Sort s -> Sort_cs (Sorts.family s), None, []
@@ -222,6 +223,7 @@ let compute_canonical_projections env ~warn (gref,ind) =
   let lpj = keep_true_projections lpj in
   let nenv = Termops.push_rels_assum sign env in
   List.fold_left2 (fun acc (spopt, canonical) t ->
+      let t = EConstr.Unsafe.to_constr (shrink_eta env (EConstr.of_constr t)) in
       if canonical
       then
         Option.cata (fun proji_sp ->