fix: construction of CompleteLattice instance for eta-reduced definitions (#10144)

This PR changes the construction of a `CompleteLattice` instance on
predicates (maps intro `Prop`) inside of
`coinductive_fixpoint`/`inductive_fixpoint` machinery.

Consider a following endomap on predicates of the type ` α → Prop`:
```lean4
def DefFunctor (r : α → α → Prop) (infSeq : α → Prop) : α → Prop :=
   λ x : α => ∃ y, r x y ∧ infSeq y
```
The following eta-reduced expression failed to elaborate:
```lean4
def def1 (r : α → α → Prop) : α → Prop := DefFunctor r (def1 r)
  coinductive_fixpoint monotonicity sorry
```

At the same time, eta-expanded variant would elaborate correctly:
```lean4
def def2 (r : α → α → Prop) : α → Prop := fun x => DefFunctor r (def2 r) x
  coinductive_fixpoint monotonicity sorry
```

This PR fixes the above issue, by changing the way how `CompleteLattice`
instance on the space of predicates is constructed, to allow for the
eta-reduced case, as outlined above.

src/Lean/Elab/PreDefinition/PartialFixpoint/Main.lean

@@ -91,17 +91,20 @@ def partialFixpoint (preDefs : Array PreDefinition) : TermElabM Unit := do
   -- ∀ x y, CCPO (r x y), but crucially constructed using `instCCPOPi`
   let insts ← preDefs.mapIdxM fun i preDef => withRef hints[i]!.ref do
     lambdaTelescope preDef.value fun xs _body => do
+      trace[Elab.definition.partialFixpoint] "preDef.value: {preDef.value}, xs: {xs}, _body: {_body}"
       let type ← instantiateForall preDef.type xs
       let inst ←
         match hints[i]!.fixpointType with
         | .coinductiveFixpoint =>
-          unless type.isProp do
-            throwError "`coinductive_fixpoint` can be only used to define predicates"
-          pure (mkConst ``ReverseImplicationOrder.instCompleteLattice)
+          forallTelescopeReducing type fun xs e => do
+            unless e.isProp do
+              throwError "`coinductive_fixpoint` can be only used to define predicates"
+            mkInstPiOfInstsForall xs (mkConst ``ReverseImplicationOrder.instCompleteLattice)
         | .inductiveFixpoint =>
-          unless type.isProp do
-            throwError "`inductive_fixpoint` can be only used to define predicates"
-          pure (mkConst ``ImplicationOrder.instCompleteLattice)
+          forallTelescopeReducing type fun xs e => do
+            unless e.isProp do
+              throwError "`inductive_fixpoint` can be only used to define predicates"
+            mkInstPiOfInstsForall xs (mkConst ``ImplicationOrder.instCompleteLattice)
         | .partialFixpoint => try
             synthInstance (← mkAppM ``CCPO #[type])
           catch _ =>
@@ -128,10 +131,7 @@ def partialFixpoint (preDefs : Array PreDefinition) : TermElabM Unit := do
     -- Or:     CompleteLattice (∀ x y, rᵢ x y)
     let insts' ← insts.mapM fun inst =>
       lambdaTelescope inst fun xs inst => do
-        let mut inst := inst
-        for x in xs.reverse do
-          inst ← mkInstPiOfInstForall x inst
-        pure inst
+        mkInstPiOfInstsForall xs inst
 
     -- Either: CCPO ((∀ x y, r₁ x y) ×' (∀ x y, r₂ x y))
     -- Or:     CompleteLattice ((∀ x y, r₁ x y) ×' (∀ x y, r₂ x y))

src/Lean/Meta/Order.lean

@@ -36,6 +36,14 @@ def mkInstPiOfInstForall (x : Expr) (inst : Expr) : MetaM Expr := do
   else
     throwError "mkInstPiOfInstForall: unexpected type of {inst}"
 
+/-- An n-ary version of `mkInstPiOfInstForall`. Takes an array of arguments instead.
+--/
+def mkInstPiOfInstsForall (xs : Array Expr) (inst : Expr) : MetaM Expr := do
+  let mut inst := inst
+  for x in xs.reverse do
+    inst ← mkInstPiOfInstForall x inst
+  pure inst
+
 /--
 Given a function `f : α → α`, an instance `inst : CCPO α`
 and a monotonicity proof `hmono : monotone f`, constructs a least fixpoint of `f`

tests/lean/run/coinductive_instance.lean

@@ -0,0 +1,13 @@
+def DefFunctor (r : α → α → Prop) (infSeq : α → Prop) : α → Prop :=
+   λ x : α => ∃ y, r x y ∧ infSeq y
+
+def def1 (r : α → α → Prop) : α → Prop := DefFunctor r (def1 r)
+  coinductive_fixpoint monotonicity sorry
+
+def def2 (r : α → α → Prop) : α → Prop := fun x => DefFunctor r (def2 r) x
+  coinductive_fixpoint monotonicity sorry
+
+def Set α := α → Prop
+
+def def3 (r : α → α → Prop) : Set α := DefFunctor r (def3 r)
+  coinductive_fixpoint monotonicity sorry