/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen

! This file was ported from Lean 3 source module data.fun_like.equiv
! leanprover-community/mathlib commit f340f229b1f461aa1c8ee11e0a172d0a3b301a4a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.FunLike.Embedding

/-!
# Typeclass for a type `F` with an injective map to `A ≃ B`

This typeclass is primarily for use by isomorphisms like `MonoidEquiv` and `LinearEquiv`.

## Basic usage of `EquivLike`

A typical type of morphisms should be declared as:
```
structure MyIso (A B : Type _) [MyClass A] [MyClass B]
  extends Equiv A B :=
(map_op' : ∀ {x y : A}, toFun (MyClass.op x y) = MyClass.op (toFun x) (toFun y))

namespace MyIso

variables (A B : Type _) [MyClass A] [MyClass B]

-- This instance is optional if you follow the "Isomorphism class" design below:
instance : EquivLike (MyIso A B) A (λ _, B) :=
{ coe := MyIso.toEquiv.toFun,
  inv := MyIso.toEquiv.invFun,
  left_inv := MyIso.toEquiv.left_inv,
  right_inv := MyIso.toEquiv.right_inv,
  coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply `EquivLike.coe` directly. -/
instance : CoeFun (MyIso A B) := FunLike.instCoeFunForAll

@[ext] theorem ext {f g : MyIso A B} (h : ∀ x, f x = g x) : f = g := FunLike.ext f g h

/-- Copy of a `MyIso` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : MyIso A B) (f' : A → B) (f_inv : B → A) (h : f' = ⇑f) : MyIso A B :=
{ toFun := f',
  invFun := f_inv,
  left_inv := h.symm ▸ f.left_inv,
  right_inv := h.symm ▸ f.right_inv,
  map_op' := h.symm ▸ f.map_op' }

end MyIso
```

This file will then provide a `CoeFun` instance and various
extensionality and simp lemmas.

## Isomorphism classes extending `EquivLike`

The `EquivLike` design provides further benefits if you put in a bit more work.
The first step is to extend `EquivLike` to create a class of those types satisfying
the axioms of your new type of isomorphisms.
Continuing the example above:

```

/-- `MyIsoClass F A B` states that `F` is a type of `MyClass.op`-preserving morphisms.
You should extend this class when you extend `MyIso`. -/
class MyIsoClass (F : Type _) (A B : outParam <| Type _) [MyClass A] [MyClass B]
  extends EquivLike F A (λ _, B), MyHomClass F A B

end

-- You can replace `MyIso.EquivLike` with the below instance:
instance : MyIsoClass (MyIso A B) A B :=
{ coe := MyIso.toFun,
  inv := MyIso.invFun,
  left_inv := MyIso.left_inv,
  right_inv := MyIso.right_inv,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := MyIso.map_op' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

The second step is to add instances of your new `MyIsoClass` for all types extending `MyIso`.
Typically, you can just declare a new class analogous to `MyIsoClass`:

```
structure CoolerIso (A B : Type _) [CoolClass A] [CoolClass B]
  extends MyIso A B :=
(map_cool' : toFun CoolClass.cool = CoolClass.cool)

section
set_option old_structure_cmd true

class CoolerIsoClass (F : Type _) (A B : outParam <| Type _) [CoolClass A] [CoolClass B]
  extends MyIsoClass F A B :=
(map_cool : ∀ (f : F), f CoolClass.cool = CoolClass.cool)

end

@[simp] lemma map_cool {F A B : Type _} [CoolClass A] [CoolClass B] [CoolerIsoClass F A B]
  (f : F) : f CoolClass.cool = CoolClass.cool :=
CoolerIsoClass.map_cool

instance : CoolerIsoClass (CoolerIso A B) A B :=
{ coe := CoolerIso.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := CoolerIso.map_op',
  map_cool := CoolerIso.map_cool' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : MyIso A B) : sorry := sorry
lemma do_something {F : Type _} [MyIsoClass F A B] (f : F) : sorry := sorry
```

This means anything set up for `MyIso`s will automatically work for `CoolerIsoClass`es,
and defining `CoolerIsoClass` only takes a constant amount of effort,
instead of linearly increasing the work per `MyIso`-related declaration.

-/

/-- The class `EquivLike E α β` expresses that terms of type `E` have an
injective coercion to bijections between `α` and `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `ZeroEquivClass`, `MulEquivClass`, `MonoidEquivClass`, ....
-/
class EquivLike (E : Sort _) (α β : outParam (Sort _)) where
  /-- The coercion to a function in the forward direction. -/
  coe : E → α → β
  /-- The coercion to a function in the backwards direction. -/
  inv : E → β → α
  /-- The coercions are left inverses. -/
  left_inv : ∀ e, Function.LeftInverse (inv e) (coe e)
  /-- The coercions are right inverses. -/
  right_inv : ∀ e, Function.RightInverse (inv e) (coe e)
  /-- If two coercions to functions are jointly injective. -/
  coe_injective' : ∀ e g, coe e = coe g → inv e = inv g → e = g
  -- This is mathematically equivalent to either of the coercions to functions being injective, but
  -- the `inv` hypothesis makes this easier to prove with `congr'`
#align equiv_like EquivLike

namespace EquivLike

variable {E F α β γ : Sort _} [iE : EquivLike E α β] [iF : EquivLike F β γ]

theorem inv_injective : Function.Injective (EquivLike.inv : E → β → α) := fun e g h ↦
  coe_injective' e g ((right_inv e).eq_rightInverse (h.symm ▸ left_inv g)) h
#align equiv_like.inv_injective EquivLike.inv_injective

instance (priority := 100) toEmbeddingLike : EmbeddingLike E α β where
  coe := (coe : E → α → β)
  coe_injective' e g h :=
    coe_injective' e g h ((left_inv e).eq_rightInverse (h.symm ▸ right_inv g))
  injective' e := (left_inv e).injective

protected theorem injective (e : E) : Function.Injective e :=
  EmbeddingLike.injective e
#align equiv_like.injective EquivLike.injective

protected theorem surjective (e : E) : Function.Surjective e :=
  (right_inv e).surjective
#align equiv_like.surjective EquivLike.surjective

protected theorem bijective (e : E) : Function.Bijective (e : α → β) :=
  ⟨EquivLike.injective e, EquivLike.surjective e⟩
#align equiv_like.bijective EquivLike.bijective

@[simp]
theorem injective_comp (e : E) (f : β → γ) : Function.Injective (f ∘ e) ↔ Function.Injective f :=
  Function.Injective.of_comp_iff' f (EquivLike.bijective e)
#align equiv_like.injective_comp EquivLike.injective_comp

@[simp]
theorem surjective_comp (e : E) (f : β → γ) : Function.Surjective (f ∘ e) ↔ Function.Surjective f :=
  (EquivLike.surjective e).of_comp_iff f
#align equiv_like.surjective_comp EquivLike.surjective_comp

@[simp]
theorem bijective_comp (e : E) (f : β → γ) : Function.Bijective (f ∘ e) ↔ Function.Bijective f :=
  (EquivLike.bijective e).of_comp_iff f
#align equiv_like.bijective_comp EquivLike.bijective_comp

/-- This lemma is only supposed to be used in the generic context, when working with instances
of classes extending `EquivLike`.
For concrete isomorphism types such as `Equiv`, you should use `Equiv.symm_apply_apply`
or its equivalent.

TODO: define a generic form of `Equiv.symm`. -/
@[simp]
theorem inv_apply_apply (e : E) (a : α) : EquivLike.inv e (e a) = a :=
  left_inv _ _
#align equiv_like.inv_apply_apply EquivLike.inv_apply_apply

/-- This lemma is only supposed to be used in the generic context, when working with instances
of classes extending `EquivLike`.
For concrete isomorphism types such as `Equiv`, you should use `Equiv.apply_symm_apply`
or its equivalent.

TODO: define a generic form of `Equiv.symm`. -/
@[simp]
theorem apply_inv_apply (e : E) (b : β) : e (EquivLike.inv e b) = b :=
  right_inv _ _
#align equiv_like.apply_inv_apply EquivLike.apply_inv_apply

theorem comp_injective (f : α → β) (e : F) : Function.Injective (e ∘ f) ↔ Function.Injective f :=
  EmbeddingLike.comp_injective f e
#align equiv_like.comp_injective EquivLike.comp_injective

@[simp]
theorem comp_surjective (f : α → β) (e : F) : Function.Surjective (e ∘ f) ↔ Function.Surjective f :=
  Function.Surjective.of_comp_iff' (EquivLike.bijective e) f
#align equiv_like.comp_surjective EquivLike.comp_surjective

@[simp]
theorem comp_bijective (f : α → β) (e : F) : Function.Bijective (e ∘ f) ↔ Function.Bijective f :=
  (EquivLike.bijective e).of_comp_iff' f
#align equiv_like.comp_bijective EquivLike.comp_bijective

/-- This is not an instance to avoid slowing down every single `Subsingleton` typeclass search.-/
lemma subsingleton_dom [Subsingleton β] : Subsingleton F :=
⟨fun f g ↦ FunLike.ext f g $ fun _ ↦ (right_inv f).injective $ Subsingleton.elim _ _⟩
#align equiv_like.subsingleton_dom EquivLike.subsingleton_dom

end EquivLike


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Monad encapsulating continuation passing programming style, similar to
Haskell's `Cont`, `ContT` and `MonadCont`:
<http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Cont.html>

! This file was ported from Lean 3 source module control.monad.cont
! leanprover-community/mathlib commit d6814c584384ddf2825ff038e868451a7c956f31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Monad.Basic
import Mathbin.Control.Monad.Writer

universe u v w u₀ u₁ v₀ v₁

structure MonadCont.Label (α : Type w) (m : Type u → Type v) (β : Type u) where
  apply : α → m β
#align monad_cont.label MonadCont.Label

def MonadCont.goto {α β} {m : Type u → Type v} (f : MonadCont.Label α m β) (x : α) :=
  f.apply x
#align monad_cont.goto MonadCont.goto

class MonadCont (m : Type u → Type v) where
  callCc : ∀ {α β}, (MonadCont.Label α m β → m α) → m α
#align monad_cont MonadCont

open MonadCont

class IsLawfulMonadCont (m : Type u → Type v) [Monad m] [MonadCont m] extends LawfulMonad m where
  callCc_bind_right {α ω γ} (cmd : m α) (next : Label ω m γ → α → m ω) :
    (callCc fun f => cmd >>= next f) = cmd >>= fun x => callCc fun f => next f x
  callCc_bind_left {α} (β) (x : α) (dead : Label α m β → β → m α) :
    (callCc fun f : Label α m β => goto f x >>= dead f) = pure x
  callCc_dummy {α β} (dummy : m α) : (callCc fun f : Label α m β => dummy) = dummy
#align is_lawful_monad_cont IsLawfulMonadCont

export IsLawfulMonadCont ()

def ContT (r : Type u) (m : Type u → Type v) (α : Type w) :=
  (α → m r) → m r
#align cont_t ContT

@[reducible]
def Cont (r : Type u) (α : Type w) :=
  ContT r id α
#align cont Cont

namespace ContT

export MonadCont (Label goto)

variable {r : Type u} {m : Type u → Type v} {α β γ ω : Type w}

def run : ContT r m α → (α → m r) → m r :=
  id
#align cont_t.run ContT.run

def map (f : m r → m r) (x : ContT r m α) : ContT r m α :=
  f ∘ x
#align cont_t.map ContT.map

theorem run_contT_map_contT (f : m r → m r) (x : ContT r m α) : run (map f x) = f ∘ run x :=
  rfl
#align cont_t.run_cont_t_map_cont_t ContT.run_contT_map_contT

def withContT (f : (β → m r) → α → m r) (x : ContT r m α) : ContT r m β := fun g => x <| f g
#align cont_t.with_cont_t ContT.withContT

theorem run_withContT (f : (β → m r) → α → m r) (x : ContT r m α) :
    run (withContT f x) = run x ∘ f :=
  rfl
#align cont_t.run_with_cont_t ContT.run_withContT

@[ext]
protected theorem ext {x y : ContT r m α} (h : ∀ f, x.run f = y.run f) : x = y := by ext <;> apply h
#align cont_t.ext ContT.ext

instance : Monad (ContT r m) where
  pure α x f := f x
  bind α β x f g := x fun i => f i g

instance : LawfulMonad (ContT r m)
    where
  id_map := by
    intros
    rfl
  pure_bind := by
    intros
    ext
    rfl
  bind_assoc := by
    intros
    ext
    rfl

def monadLift [Monad m] {α} : m α → ContT r m α := fun x f => x >>= f
#align cont_t.monad_lift ContT.monadLift

instance [Monad m] : HasMonadLift m (ContT r m) where monadLift α := ContT.monadLift

theorem monadLift_bind [Monad m] [LawfulMonad m] {α β} (x : m α) (f : α → m β) :
    (monadLift (x >>= f) : ContT r m β) = monadLift x >>= monadLift ∘ f :=
  by
  ext
  simp only [monad_lift, HasMonadLift.monadLift, (· ∘ ·), (· >>= ·), bind_assoc, id.def, run,
    ContT.monadLift]
#align cont_t.monad_lift_bind ContT.monadLift_bind

instance : MonadCont (ContT r m) where callCc α β f g := f ⟨fun x h => g x⟩ g

instance : IsLawfulMonadCont (ContT r m)
    where
  callCc_bind_right := by intros <;> ext <;> rfl
  callCc_bind_left := by intros <;> ext <;> rfl
  callCc_dummy := by intros <;> ext <;> rfl

instance (ε) [MonadExcept ε m] : MonadExcept ε (ContT r m)
    where
  throw x e f := throw e
  catch α act h f := catch (act f) fun e => h e f

instance : MonadRun (fun α => (α → m r) → ULift.{u, v} (m r)) (ContT.{u, v, u} r m)
    where run α f x := ⟨f x⟩

end ContT

variable {m : Type u → Type v} [Monad m]

def ExceptT.mkLabel {α β ε} : Label (Except.{u, u} ε α) m β → Label α (ExceptT ε m) β
  | ⟨f⟩ => ⟨fun a => monadLift <| f (Except.ok a)⟩
#align except_t.mk_label ExceptTₓ.mkLabel

theorem ExceptT.goto_mkLabel {α β ε : Type _} (x : Label (Except.{u, u} ε α) m β) (i : α) :
    goto (ExceptT.mkLabel x) i = ⟨Except.ok <$> goto x (Except.ok i)⟩ := by cases x <;> rfl
#align except_t.goto_mk_label ExceptTₓ.goto_mkLabel

def ExceptT.callCc {ε} [MonadCont m] {α β : Type _} (f : Label α (ExceptT ε m) β → ExceptT ε m α) :
    ExceptT ε m α :=
  ExceptT.mk (callCc fun x : Label _ m β => ExceptT.run <| f (ExceptT.mkLabel x) : m (Except ε α))
#align except_t.call_cc ExceptTₓ.callCc

instance {ε} [MonadCont m] : MonadCont (ExceptT ε m) where callCc α β := ExceptT.callCc

instance {ε} [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (ExceptT ε m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, ExceptT.callCc, call_cc_bind_right]
    ext
    dsimp
    congr with ⟨⟩ <;> simp [ExceptT.bindCont, @call_cc_dummy m _]
  callCc_bind_left := by
    intros
    simp [call_cc, ExceptT.callCc, call_cc_bind_right, ExceptT.goto_mkLabel, map_eq_bind_pure_comp,
      bind_assoc, @call_cc_bind_left m _]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, ExceptT.callCc, @call_cc_dummy m _]
    ext
    rfl

def OptionT.mkLabel {α β} : Label (Option.{u} α) m β → Label α (OptionT m) β
  | ⟨f⟩ => ⟨fun a => monadLift <| f (some a)⟩
#align option_t.mk_label OptionTₓ.mkLabel

theorem OptionT.goto_mkLabel {α β : Type _} (x : Label (Option.{u} α) m β) (i : α) :
    goto (OptionT.mkLabel x) i = ⟨some <$> goto x (some i)⟩ := by cases x <;> rfl
#align option_t.goto_mk_label OptionTₓ.goto_mkLabel

def OptionT.callCc [MonadCont m] {α β : Type _} (f : Label α (OptionT m) β → OptionT m α) :
    OptionT m α :=
  OptionT.mk (callCc fun x : Label _ m β => OptionT.run <| f (OptionT.mkLabel x) : m (Option α))
#align option_t.call_cc OptionTₓ.callCc

instance [MonadCont m] : MonadCont (OptionT m) where callCc α β := OptionT.callCc

instance [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (OptionT m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, OptionT.callCc, call_cc_bind_right]
    ext
    dsimp
    congr with ⟨⟩ <;> simp [OptionT.bindCont, @call_cc_dummy m _]
  callCc_bind_left := by
    intros
    simp [call_cc, OptionT.callCc, call_cc_bind_right, OptionT.goto_mkLabel, map_eq_bind_pure_comp,
      bind_assoc, @call_cc_bind_left m _]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, OptionT.callCc, @call_cc_dummy m _]
    ext
    rfl

/- warning: writer_t.mk_label -> WriterTₓ.mkLabel is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u3}} {β : Type.{u1}} {ω : Type.{u1}} [_inst_2 : One.{u1} ω], (MonadCont.Label.{u1, u2, max u3 u1} (Prod.{u3, u1} α ω) m β) -> (MonadCont.Label.{u1, max u1 u2, u3} α (WriterTₓ.{u1, u2} ω m) β)
but is expected to have type
  forall {m : Type.{u2} -> Type.{u3}} [_inst_1 : Monad.{u2, u3} m] {α : Type.{u1}} {β : Type.{u2}} {ω : Type.{u2}} [_inst_2 : One.{u2} ω], (MonadCont.Label.{u2, u3, max u1 u2} (Prod.{u1, u2} α ω) m β) -> (MonadCont.Label.{u2, max u2 u3, u1} α (WriterTₓ.{u2, u3} ω m) β)
Case conversion may be inaccurate. Consider using '#align writer_t.mk_label WriterTₓ.mkLabelₓ'. -/
def WriterT.mkLabel {α β ω} [One ω] : Label (α × ω) m β → Label α (WriterT ω m) β
  | ⟨f⟩ => ⟨fun a => monadLift <| f (a, 1)⟩
#align writer_t.mk_label WriterTₓ.mkLabel

theorem WriterT.goto_mkLabel {α β ω : Type _} [One ω] (x : Label (α × ω) m β) (i : α) :
    goto (WriterT.mkLabel x) i = monadLift (goto x (i, 1)) := by cases x <;> rfl
#align writer_t.goto_mk_label WriterTₓ.goto_mkLabel

def WriterT.callCc [MonadCont m] {α β ω : Type _} [One ω]
    (f : Label α (WriterT ω m) β → WriterT ω m α) : WriterT ω m α :=
  ⟨callCc (WriterT.run ∘ f ∘ WriterT.mkLabel : Label (α × ω) m β → m (α × ω))⟩
#align writer_t.call_cc WriterTₓ.callCc

instance (ω) [Monad m] [One ω] [MonadCont m] : MonadCont (WriterT ω m)
    where callCc α β := WriterT.callCc

/- warning: state_t.mk_label -> StateTₓ.mkLabel is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u1}} {β : Type.{u1}} {σ : Type.{u1}}, (MonadCont.Label.{u1, u2, u1} (Prod.{u1, u1} α σ) m (Prod.{u1, u1} β σ)) -> (MonadCont.Label.{u1, max u1 u2, u1} α (StateTₓ.{u1, u2} σ m) β)
but is expected to have type
  forall {m : Type.{u1} -> Type.{u2}} {_inst_1 : Type.{u1}} {α : Type.{u1}} {β : Type.{u1}}, (MonadCont.Label.{u1, u2, u1} (Prod.{u1, u1} _inst_1 β) m (Prod.{u1, u1} α β)) -> (MonadCont.Label.{u1, max u1 u2, u1} _inst_1 (StateTₓ.{u1, u2} β m) α)
Case conversion may be inaccurate. Consider using '#align state_t.mk_label StateTₓ.mkLabelₓ'. -/
def StateT.mkLabel {α β σ : Type u} : Label (α × σ) m (β × σ) → Label α (StateT σ m) β
  | ⟨f⟩ => ⟨fun a => ⟨fun s => f (a, s)⟩⟩
#align state_t.mk_label StateTₓ.mkLabel

theorem StateT.goto_mkLabel {α β σ : Type u} (x : Label (α × σ) m (β × σ)) (i : α) :
    goto (StateT.mkLabel x) i = ⟨fun s => goto x (i, s)⟩ := by cases x <;> rfl
#align state_t.goto_mk_label StateTₓ.goto_mkLabel

def StateT.callCc {σ} [MonadCont m] {α β : Type _} (f : Label α (StateT σ m) β → StateT σ m α) :
    StateT σ m α :=
  ⟨fun r => callCc fun f' => (f <| StateT.mkLabel f').run r⟩
#align state_t.call_cc StateTₓ.callCc

instance {σ} [MonadCont m] : MonadCont (StateT σ m) where callCc α β := StateT.callCc

instance {σ} [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (StateT σ m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, StateT.callCc, call_cc_bind_right, (· >>= ·), StateT.bind]
    ext
    dsimp
    congr with ⟨x₀, x₁⟩
    rfl
  callCc_bind_left := by
    intros
    simp [call_cc, StateT.callCc, call_cc_bind_left, (· >>= ·), StateT.bind, StateT.goto_mkLabel]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, StateT.callCc, call_cc_bind_right, (· >>= ·), StateT.bind, @call_cc_dummy m _]
    ext
    rfl

/- warning: reader_t.mk_label -> ReaderTₓ.mkLabel is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u3}} {β : Type.{u1}} (ρ : Type.{u1}), (MonadCont.Label.{u1, u2, u3} α m β) -> (MonadCont.Label.{u1, max u1 u2, u3} α (ReaderTₓ.{u1, u2} ρ m) β)
but is expected to have type
  forall {m : Type.{u2} -> Type.{u3}} [_inst_1 : Monad.{u2, u3} m] {α : Type.{u1}} {β : Type.{u2}} (ρ : Type.{u2}), (MonadCont.Label.{u2, u3, u1} α m β) -> (MonadCont.Label.{u2, max u2 u3, u1} α (ReaderTₓ.{u2, u3} ρ m) β)
Case conversion may be inaccurate. Consider using '#align reader_t.mk_label ReaderTₓ.mkLabelₓ'. -/
def ReaderT.mkLabel {α β} (ρ) : Label α m β → Label α (ReaderT ρ m) β
  | ⟨f⟩ => ⟨monadLift ∘ f⟩
#align reader_t.mk_label ReaderTₓ.mkLabel

theorem ReaderT.goto_mkLabel {α ρ β} (x : Label α m β) (i : α) :
    goto (ReaderT.mkLabel ρ x) i = monadLift (goto x i) := by cases x <;> rfl
#align reader_t.goto_mk_label ReaderTₓ.goto_mkLabel

def ReaderT.callCc {ε} [MonadCont m] {α β : Type _} (f : Label α (ReaderT ε m) β → ReaderT ε m α) :
    ReaderT ε m α :=
  ⟨fun r => callCc fun f' => (f <| ReaderT.mkLabel _ f').run r⟩
#align reader_t.call_cc ReaderTₓ.callCc

instance {ρ} [MonadCont m] : MonadCont (ReaderT ρ m) where callCc α β := ReaderT.callCc

instance {ρ} [MonadCont m] [IsLawfulMonadCont m] : IsLawfulMonadCont (ReaderT ρ m)
    where
  callCc_bind_right := by
    intros
    simp [call_cc, ReaderT.callCc, call_cc_bind_right]
    ext
    rfl
  callCc_bind_left := by
    intros
    simp [call_cc, ReaderT.callCc, call_cc_bind_left, ReaderT.goto_mkLabel]
    ext
    rfl
  callCc_dummy := by
    intros
    simp [call_cc, ReaderT.callCc, @call_cc_dummy m _]
    ext
    rfl

/-- reduce the equivalence between two continuation passing monads to the equivalence between
their underlying monad -/
def ContT.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ r₁ : Type u₀}
    {α₂ r₂ : Type u₁} (F : m₁ r₁ ≃ m₂ r₂) (G : α₁ ≃ α₂) : ContT r₁ m₁ α₁ ≃ ContT r₂ m₂ α₂
    where
  toFun f r := F <| f fun x => F.symm <| r <| G x
  invFun f r := F.symm <| f fun x => F <| r <| G.symm x
  left_inv f := by funext r <;> simp
  right_inv f := by funext r <;> simp
#align cont_t.equiv ContT.equiv


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.ProjFns
import Lean.Structure
import Lean.Meta.WHNF
import Lean.Meta.InferType
import Lean.Meta.FunInfo
import Lean.Meta.LevelDefEq
import Lean.Meta.Check
import Lean.Meta.Offset
import Lean.Meta.ForEachExpr
import Lean.Meta.UnificationHint

namespace Lean.Meta

/--
  Try to solve `a := (fun x => t) =?= b` by eta-expanding `b`.

  Remark: eta-reduction is not a good alternative even in a system without universe cumulativity like Lean.
  Example:
    ```
    (fun x : A => f ?m) =?= f
    ```
    The left-hand side of the constraint above it not eta-reduced because `?m` is a metavariable. -/
private def isDefEqEta (a b : Expr) : MetaM Bool := do
  if a.isLambda && !b.isLambda then
    let bType ← inferType b
    let bType ← whnfD bType
    match bType with
    | Expr.forallE n d _ c =>
      let b' := mkLambda n c.binderInfo d (mkApp b (mkBVar 0))
      checkpointDefEq <| Meta.isExprDefEqAux a b'
    | _ => pure false
  else
    pure false

/-- Support for `Lean.reduceBool` and `Lean.reduceNat` -/
def isDefEqNative (s t : Expr) : MetaM LBool := do
  let isDefEq (s t) : MetaM LBool := toLBoolM <| Meta.isExprDefEqAux s t
  let s? ← reduceNative? s
  let t? ← reduceNative? t
  match s?, t? with
  | some s, some t => isDefEq s t
  | some s, none   => isDefEq s t
  | none,   some t => isDefEq s t
  | none,   none   => pure LBool.undef

/-- Support for reducing Nat basic operations. -/
def isDefEqNat (s t : Expr) : MetaM LBool := do
  let isDefEq (s t) : MetaM LBool := toLBoolM <| Meta.isExprDefEqAux s t
  if s.hasFVar || s.hasMVar || t.hasFVar || t.hasMVar then
    pure LBool.undef
  else
    let s? ← reduceNat? s
    let t? ← reduceNat? t
    match s?, t? with
    | some s, some t => isDefEq s t
    | some s, none   => isDefEq s t
    | none,   some t => isDefEq s t
    | none,   none   => pure LBool.undef

/-- Support for constraints of the form `("..." =?= String.mk cs)` -/
def isDefEqStringLit (s t : Expr) : MetaM LBool := do
  let isDefEq (s t) : MetaM LBool := toLBoolM <| Meta.isExprDefEqAux s t
  if s.isStringLit && t.isAppOf `String.mk then
    isDefEq (toCtorIfLit s) t
  else if s.isAppOf `String.mk && t.isStringLit then
    isDefEq s (toCtorIfLit t)
  else
    pure LBool.undef

/--
  Return `true` if `e` is of the form `fun (x_1 ... x_n) => ?m x_1 ... x_n)`, and `?m` is unassigned.
  Remark: `n` may be 0. -/
def isEtaUnassignedMVar (e : Expr) : MetaM Bool := do
  match e.etaExpanded? with
  | some (Expr.mvar mvarId _) =>
    if (← isReadOnlyOrSyntheticOpaqueExprMVar mvarId) then
      pure false
    else if (← isExprMVarAssigned mvarId) then
      pure false
    else
      pure true
  | _   => pure false

/-
  First pass for `isDefEqArgs`. We unify explicit arguments, *and* easy cases
  Here, we say a case is easy if it is of the form

       ?m =?= t
       or
       t  =?= ?m

  where `?m` is unassigned.

  These easy cases are not just an optimization. When
  `?m` is a function, by assigning it to t, we make sure
  a unification constraint (in the explicit part)
  ```
  ?m t =?= f s
  ```
  is not higher-order.

  We also handle the eta-expanded cases:
  ```
  fun x₁ ... xₙ => ?m x₁ ... xₙ =?= t
  t =?= fun x₁ ... xₙ => ?m x₁ ... xₙ
  ```
  This is important because type inference often produces
  eta-expanded terms, and without this extra case, we could
  introduce counter intuitive behavior.

  Pre: `paramInfo.size <= args₁.size = args₂.size`
-/
private partial def isDefEqArgsFirstPass
    (paramInfo : Array ParamInfo) (args₁ args₂ : Array Expr) : MetaM (Option (Array Nat)) := do
  let rec loop (i : Nat) (postponed : Array Nat) := do
    if h : i < paramInfo.size then
      let info := paramInfo.get ⟨i, h⟩
      let a₁ := args₁[i]
      let a₂ := args₂[i]
      if info.implicit || info.instImplicit then
        if (← isEtaUnassignedMVar a₁ <||> isEtaUnassignedMVar a₂) then
          if (← Meta.isExprDefEqAux a₁ a₂) then
            loop (i+1) postponed
          else
            pure none
        else
          loop (i+1) (postponed.push i)
      else if (← Meta.isExprDefEqAux a₁ a₂) then
        loop (i+1) postponed
      else
        pure none
    else
      pure (some postponed)
  loop 0 #[]

@[specialize] private def trySynthPending (e : Expr) : MetaM Bool := do
  let mvarId? ← getStuckMVar? e
  match mvarId? with
  | some mvarId => Meta.synthPending mvarId
  | none        => pure false

private partial def isDefEqArgs (f : Expr) (args₁ args₂ : Array Expr) : MetaM Bool :=
  if h : args₁.size = args₂.size then do
    let finfo ← getFunInfoNArgs f args₁.size
    let (some postponed) ← isDefEqArgsFirstPass finfo.paramInfo args₁ args₂ | pure false
    let rec processOtherArgs (i : Nat) : MetaM Bool := do
      if h₁ : i < args₁.size then
        let a₁ := args₁.get ⟨i, h₁⟩
        let a₂ := args₂.get ⟨i, Eq.subst h h₁⟩
        if (← Meta.isExprDefEqAux a₁ a₂) then
          processOtherArgs (i+1)
        else
          pure false
      else
        pure true
    if (← processOtherArgs finfo.paramInfo.size) then
      postponed.allM fun i => do
        /- Second pass: unify implicit arguments.
           In the second pass, we make sure we are unfolding at
           least non reducible definitions (default setting). -/
        let a₁   := args₁[i]
        let a₂   := args₂[i]
        let info := finfo.paramInfo[i]
        if info.instImplicit then
          discard <| trySynthPending a₁
          discard <| trySynthPending a₂
        withAtLeastTransparency TransparencyMode.default <| Meta.isExprDefEqAux a₁ a₂
    else
      pure false
  else
    pure false

/--
  Check whether the types of the free variables at `fvars` are
  definitionally equal to the types at `ds₂`.

  Pre: `fvars.size == ds₂.size`

  This method also updates the set of local instances, and invokes
  the continuation `k` with the updated set.

  We can't use `withNewLocalInstances` because the `isDeq fvarType d₂`
  may use local instances. -/
@[specialize] partial def isDefEqBindingDomain (fvars : Array Expr) (ds₂ : Array Expr) (k : MetaM Bool) : MetaM Bool :=
  let rec loop (i : Nat) := do
    if h : i < fvars.size then do
      let fvar := fvars.get ⟨i, h⟩
      let fvarDecl ← getFVarLocalDecl fvar
      let fvarType := fvarDecl.type
      let d₂       := ds₂[i]
      if (← Meta.isExprDefEqAux fvarType d₂) then
        match (← isClass? fvarType) with
        | some className => withNewLocalInstance className fvar <| loop (i+1)
        | none           => loop (i+1)
      else
        pure false
    else
      k
  loop 0

/- Auxiliary function for `isDefEqBinding` for handling binders `forall/fun`.
   It accumulates the new free variables in `fvars`, and declare them at `lctx`.
   We use the domain types of `e₁` to create the new free variables.
   We store the domain types of `e₂` at `ds₂`. -/
private partial def isDefEqBindingAux (lctx : LocalContext) (fvars : Array Expr) (e₁ e₂ : Expr) (ds₂ : Array Expr) : MetaM Bool :=
  let process (n : Name) (d₁ d₂ b₁ b₂ : Expr) : MetaM Bool := do
    let d₁     := d₁.instantiateRev fvars
    let d₂     := d₂.instantiateRev fvars
    let fvarId ← mkFreshId
    let lctx   := lctx.mkLocalDecl fvarId n d₁
    let fvars  := fvars.push (mkFVar fvarId)
    isDefEqBindingAux lctx fvars b₁ b₂ (ds₂.push d₂)
  match e₁, e₂ with
  | Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
  | Expr.lam     n d₁ b₁ _, Expr.lam     _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
  | _,                      _                      =>
    withReader (fun ctx => { ctx with lctx := lctx }) do
      isDefEqBindingDomain fvars ds₂ do
        Meta.isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars)

@[inline] private def isDefEqBinding (a b : Expr) : MetaM Bool := do
  let lctx ← getLCtx
  isDefEqBindingAux lctx #[] a b #[]

private def checkTypesAndAssign (mvar : Expr) (v : Expr) : MetaM Bool :=
  traceCtx `Meta.isDefEq.assign.checkTypes do
    if !mvar.isMVar then
      trace[Meta.isDefEq.assign.final] "metavariable expected at {mvar} := {v}"
      return false
    else
      -- must check whether types are definitionally equal or not, before assigning and returning true
      let mvarType ← inferType mvar
      let vType ← inferType v
      if (← withTransparency TransparencyMode.default <| Meta.isExprDefEqAux mvarType vType) then
        trace[Meta.isDefEq.assign.final] "{mvar} := {v}"
        assignExprMVar mvar.mvarId! v
        pure true
      else
        trace[Meta.isDefEq.assign.typeMismatch] "{mvar} : {mvarType} := {v} : {vType}"
        pure false

/--
  Auxiliary method for solving constraints of the form `?m xs := v`.
  It creates a lambda using `mkLambdaFVars ys v`, where `ys` is a superset of `xs`.
  `ys` is often equal to `xs`. It is a bigger when there are let-declaration dependencies in `xs`.
  For example, suppose we have `xs` of the form `#[a, c]` where
  ```
  a : Nat
  b : Nat := f a
  c : b = a
  ```
  In this scenario, the type of `?m` is `(x1 : Nat) -> (x2 : f x1 = x1) -> C[x1, x2]`,
  and type of `v` is `C[a, c]`. Note that, `?m a c` is type correct since `f a = a` is definitionally equal
  to the type of `c : b = a`, and the type of `?m a c` is equal to the type of `v`.
  Note that `fun xs => v` is the term `fun (x1 : Nat) (x2 : b = x1) => v` which has type
  `(x1 : Nat) -> (x2 : b = x1) -> C[x1, x2]` which is not definitionally equal to the type of `?m`,
  and may not even be type correct.
  The issue here is that we are not capturing the `let`-declarations.

  This method collects let-declarations `y` occurring between `xs[0]` and `xs.back` s.t.
  some `x` in `xs` depends on `y`.
  `ys` is the `xs` with these extra let-declarations included.

  In the example above, `ys` is `#[a, b, c]`, and `mkLambdaFVars ys v` produces
  `fun a => let b := f a; fun (c : b = a) => v` which has a type definitionally equal to the type of `?m`.

  Recall that the method `checkAssignment` ensures `v` does not contain offending `let`-declarations.

  This method assumes that for any `xs[i]` and `xs[j]` where `i < j`, we have that `index of xs[i]` < `index of xs[j]`.
  where the index is the position in the local context.
-/
private partial def mkLambdaFVarsWithLetDeps (xs : Array Expr) (v : Expr) : MetaM (Option Expr) := do
  if not (← hasLetDeclsInBetween) then
    mkLambdaFVars xs v
  else
    let ys ← addLetDeps
    trace[Meta.debug] "ys: {ys}, v: {v}"
    mkLambdaFVars ys v

where
  /- Return true if there are let-declarions between `xs[0]` and `xs[xs.size-1]`.
     We use it a quick-check to avoid the more expensive collection procedure. -/
  hasLetDeclsInBetween : MetaM Bool := do
    let check (lctx : LocalContext) : Bool := do
      let start := lctx.getFVar! xs[0] |>.index
      let stop  := lctx.getFVar! xs.back |>.index
      for i in [start+1:stop] do
        match lctx.getAt? i with
        | some localDecl =>
          if localDecl.isLet then
            return true
        | _ => pure ()
      return false
    if xs.size <= 1 then
      pure false
    else
      check (← getLCtx)

  /- Traverse `e` and stores in the state `NameHashSet` any let-declaration with index greater than `(← read)`.
     The context `Nat` is the position of `xs[0]` in the local context. -/
  collectLetDeclsFrom (e : Expr) : ReaderT Nat (StateRefT NameHashSet MetaM) Unit := do
    let rec visit (e : Expr) : MonadCacheT Expr Unit (ReaderT Nat (StateRefT NameHashSet MetaM)) Unit :=
      checkCache e fun _ => do
        match e with
        | Expr.forallE _ d b _   => visit d; visit b
        | Expr.lam _ d b _       => visit d; visit b
        | Expr.letE _ t v b _    => visit t; visit v; visit b
        | Expr.app f a _         => visit f; visit a
        | Expr.mdata _ b _       => visit b
        | Expr.proj _ _ b _      => visit b
        | Expr.fvar fvarId _     =>
          let localDecl ← getLocalDecl fvarId
          if localDecl.isLet && localDecl.index > (← read) then
            modify fun s => s.insert localDecl.fvarId
        | _ => pure ()
    visit (← instantiateMVars e) |>.run

  /-
    Auxiliary definition for traversing all declarations between `xs[0]` ... `xs.back` backwards.
    The `Nat` argument is the current position in the local context being visited, and it is less than
    or equal to the position of `xs.back` in the local context.
    The `Nat` context `(← read)` is the position of `xs[0]` in the local context.
  -/
  collectLetDepsAux : Nat → ReaderT Nat (StateRefT NameHashSet MetaM) Unit
    | 0   => return ()
    | i+1 => do
      if i+1 == (← read) then
        return ()
      else
        match (← getLCtx).getAt? (i+1) with
        | none => collectLetDepsAux i
        | some localDecl =>
          if (← get).contains localDecl.fvarId then
            collectLetDeclsFrom localDecl.type
            match localDecl.value? with
            | some val => collectLetDeclsFrom val
            | _ =>  pure ()
          collectLetDepsAux i

  /- Computes the set `ys`. It is a set of `FVarId`s, -/
  collectLetDeps : MetaM NameHashSet := do
    let lctx ← getLCtx
    let start := lctx.getFVar! xs[0] |>.index
    let stop  := lctx.getFVar! xs.back |>.index
    let s := xs.foldl (init := {}) fun s x => s.insert x.fvarId!
    let (_, s) ← collectLetDepsAux stop |>.run start |>.run s
    return s

  /- Computes the array `ys` containing let-decls between `xs[0]` and `xs.back` that
     some `x` in `xs` depends on. -/
  addLetDeps : MetaM (Array Expr) := do
    let lctx ← getLCtx
    let s ← collectLetDeps
    /- Convert `s` into the array `ys` -/
    let start := lctx.getFVar! xs[0] |>.index
    let stop  := lctx.getFVar! xs.back |>.index
    let mut ys := #[]
    for i in [start:stop+1] do
      match lctx.getAt? i with
      | none => pure ()
      | some localDecl =>
        if s.contains localDecl.fvarId then
          ys := ys.push localDecl.toExpr
    return ys

/-
  Each metavariable is declared in a particular local context.
  We use the notation `C |- ?m : t` to denote a metavariable `?m` that
  was declared at the local context `C` with type `t` (see `MetavarDecl`).
  We also use `?m@C` as a shorthand for `C |- ?m : t` where `t` is the type of `?m`.

  The following method process the unification constraint

       ?m@C a₁ ... aₙ =?= t

  We say the unification constraint is a pattern IFF

    1) `a₁ ... aₙ` are pairwise distinct free variables that are *not* let-variables.
    2) `a₁ ... aₙ` are not in `C`
    3) `t` only contains free variables in `C` and/or `{a₁, ..., aₙ}`
    4) For every metavariable `?m'@C'` occurring in `t`, `C'` is a subprefix of `C`
    5) `?m` does not occur in `t`

  Claim: we don't have to check free variable declarations. That is,
  if `t` contains a reference to `x : A := v`, we don't need to check `v`.
  Reason: The reference to `x` is a free variable, and it must be in `C` (by 1 and 3).
  If `x` is in `C`, then any metavariable occurring in `v` must have been defined in a strict subprefix of `C`.
  So, condition 4 and 5 are satisfied.

  If the conditions above have been satisfied, then the
  solution for the unification constrain is

    ?m := fun a₁ ... aₙ => t

  Now, we consider some workarounds/approximations.

 A1) Suppose `t` contains a reference to `x : A := v` and `x` is not in `C` (failed condition 3)
     (precise) solution: unfold `x` in `t`.

 A2) Suppose some `aᵢ` is in `C` (failed condition 2)
     (approximated) solution (when `config.ctxApprox` is set to true) :
     ignore condition and also use

        ?m := fun a₁ ... aₙ => t

   Here is an example where this approximation fails:
   Given `C` containing `a : nat`, consider the following two constraints
         ?m@C a =?= a
         ?m@C b =?= a

   If we use the approximation in the first constraint, we get
         ?m := fun x => x
   when we apply this solution to the second one we get a failure.

   IMPORTANT: When applying this approximation we need to make sure the
   abstracted term `fun a₁ ... aₙ => t` is type correct. The check
   can only be skipped in the pattern case described above. Consider
   the following example. Given the local context

      (α : Type) (a : α)

   we try to solve

     ?m α =?= @id α a

   If we use the approximation above we obtain:

     ?m := (fun α' => @id α' a)

   which is a type incorrect term. `a` has type `α` but it is expected to have
   type `α'`.

   The problem occurs because the right hand side contains a free variable
   `a` that depends on the free variable `α` being abstracted. Note that
   this dependency cannot occur in patterns.

   We can address this by type checking
   the term after abstraction. This is not a significant performance
   bottleneck because this case doesn't happen very often in practice
   (262 times when compiling stdlib on Jan 2018). The second example
   is trickier, but it also occurs less frequently (8 times when compiling
   stdlib on Jan 2018, and all occurrences were at Init/Control when
   we define monads and auxiliary combinators for them).
   We considered three options for the addressing the issue on the second example:

 A3) `a₁ ... aₙ` are not pairwise distinct (failed condition 1).
   In Lean3, we would try to approximate this case using an approach similar to A2.
   However, this approximation complicates the code, and is never used in the
   Lean3 stdlib and mathlib.

 A4) `t` contains a metavariable `?m'@C'` where `C'` is not a subprefix of `C`.
   If `?m'` is assigned, we substitute.
   If not, we create an auxiliary metavariable with a smaller scope.
   Actually, we let `elimMVarDeps` at `MetavarContext.lean` to perform this step.

 A5) If some `aᵢ` is not a free variable,
     then we use first-order unification (if `config.foApprox` is set to true)

       ?m a_1 ... a_i a_{i+1} ... a_{i+k} =?= f b_1 ... b_k

   reduces to

       ?M a_1 ... a_i =?= f
       a_{i+1}        =?= b_1
       ...
       a_{i+k}        =?= b_k

 A6) If (m =?= v) is of the form

        ?m a_1 ... a_n =?= ?m b_1 ... b_k

     then we use first-order unification (if `config.foApprox` is set to true)

 A7) When `foApprox`, we may use another approximation (`constApprox`) for solving constraints of the form
     ```
     ?m s₁ ... sₙ =?= t
     ```
     where `s₁ ... sₙ` are arbitrary terms. We solve them by assigning the constant function to `?m`.
     ```
     ?m := fun _ ... _ => t
     ```

     In general, this approximation may produce bad solutions, and may prevent coercions from being tried.
     For example, consider the term `pure (x > 0)` with inferred type `?m Prop` and expected type `IO Bool`.
     In this situation, the
     elaborator generates the unification constraint
     ```
     ?m Prop =?= IO Bool
     ```
     It is not a higher-order pattern, nor first-order approximation is applicable. However, constant approximation
     produces the bogus solution `?m := fun _ => IO Bool`, and prevents the system from using the coercion from
     the decidable proposition `x > 0` to `Bool`.

     On the other hand, the constant approximation is desirable for elaborating the term
     ```
     let f (x : _) := pure "hello"; f ()
     ```
     with expected type `IO String`.
     In this example, the following unification contraint is generated.
     ```
     ?m () String =?= IO String
     ```
     It is not a higher-order pattern, first-order approximation reduces it to
     ```
     ?m () =?= IO
     ```
     which fails to be solved. However, constant approximation solves it by assigning
     ```
     ?m := fun _ => IO
     ```
     Note that `f`s type is `(x : ?α) -> ?m x String`. The metavariable `?m` may depend on `x`.
     If `constApprox` is set to true, we use constant approximation. Otherwise, we use a heuristic to decide
     whether we should apply it or not. The heuristic is based on observing where the constraints above come from.
     In the first example, the constraint `?m Prop =?= IO Bool` come from polymorphic method where `?m` is expected to
     be a **function** of type `Type -> Type`. In the second example, the first argument of `?m` is used to model
     a **potential** dependency on `x`. By using constant approximation here, we are just saying the type of `f`
     does **not** depend on `x`. We claim this is a reasonable approximation in practice. Moreover, it is expected
     by any functional programmer used to non-dependently type languages (e.g., Haskell).
     We distinguish the two cases above by using the field `numScopeArgs` at `MetavarDecl`. This fiels tracks
     how many metavariable arguments are representing dependencies.
-/

def mkAuxMVar (lctx : LocalContext) (localInsts : LocalInstances) (type : Expr) (numScopeArgs : Nat := 0) : MetaM Expr := do
  mkFreshExprMVarAt lctx localInsts type MetavarKind.natural Name.anonymous numScopeArgs

namespace CheckAssignment

builtin_initialize checkAssignmentExceptionId : InternalExceptionId ← registerInternalExceptionId `checkAssignment
builtin_initialize outOfScopeExceptionId : InternalExceptionId ← registerInternalExceptionId `outOfScope

structure State where
  cache : ExprStructMap Expr := {}

structure Context where
  mvarId        : MVarId
  mvarDecl      : MetavarDecl
  fvars         : Array Expr
  hasCtxLocals  : Bool
  rhs           : Expr

abbrev CheckAssignmentM := ReaderT Context $ StateRefT State MetaM

def throwCheckAssignmentFailure : CheckAssignmentM α :=
  throw <| Exception.internal checkAssignmentExceptionId

def throwOutOfScopeFVar : CheckAssignmentM α :=
  throw <| Exception.internal outOfScopeExceptionId

private def findCached? (e : Expr) : CheckAssignmentM (Option Expr) := do
  return (← get).cache.find? e

private def cache (e r : Expr) : CheckAssignmentM Unit := do
  modify fun s => { s with cache := s.cache.insert e r }

instance : MonadCache Expr Expr CheckAssignmentM where
  findCached? := findCached?
  cache       := cache

@[inline] private def visit (f : Expr → CheckAssignmentM Expr) (e : Expr) : CheckAssignmentM Expr :=
  if !e.hasExprMVar && !e.hasFVar then pure e else checkCache e (fun _ => f e)

private def addAssignmentInfo (msg : MessageData) : CheckAssignmentM MessageData := do
  let ctx ← read
  return m!"{msg} @ {mkMVar ctx.mvarId} {ctx.fvars} := {ctx.rhs}"

@[inline] def run (x : CheckAssignmentM Expr) (mvarId : MVarId) (fvars : Array Expr) (hasCtxLocals : Bool) (v : Expr) : MetaM (Option Expr) := do
  let mvarDecl ← getMVarDecl mvarId
  let ctx := { mvarId := mvarId, mvarDecl := mvarDecl, fvars := fvars, hasCtxLocals := hasCtxLocals, rhs := v : Context }
  let x : CheckAssignmentM (Option Expr) :=
    catchInternalIds [outOfScopeExceptionId, checkAssignmentExceptionId]
      (do let e ← x; return some e)
      (fun _ => pure none)
  x.run ctx |>.run' {}

mutual

  partial def checkFVar (fvar : Expr) : CheckAssignmentM Expr := do
    let ctxMeta ← readThe Meta.Context
    let ctx ← read
    if ctx.mvarDecl.lctx.containsFVar fvar then
      pure fvar
    else
      let lctx := ctxMeta.lctx
      match lctx.findFVar? fvar with
      | some (LocalDecl.ldecl (value := v) ..) => visit check v
      | _ =>
        if ctx.fvars.contains fvar then pure fvar
        else
          traceM `Meta.isDefEq.assign.outOfScopeFVar do addAssignmentInfo fvar
          throwOutOfScopeFVar

  partial def checkMVar (mvar : Expr) : CheckAssignmentM Expr := do
    let mvarId := mvar.mvarId!
    let ctx  ← read
    let mctx ← getMCtx
    if mvarId == ctx.mvarId then
      traceM `Meta.isDefEq.assign.occursCheck <| addAssignmentInfo "occurs check failed"
      throwCheckAssignmentFailure
    else match mctx.getExprAssignment? mvarId with
      | some v => check v
      | none   =>
        match mctx.findDecl? mvarId with
        | none          => throwUnknownMVar mvarId
        | some mvarDecl =>
          if ctx.hasCtxLocals then
            throwCheckAssignmentFailure -- It is not a pattern, then we fail and fall back to FO unification
          else if mvarDecl.lctx.isSubPrefixOf ctx.mvarDecl.lctx ctx.fvars then
            /- The local context of `mvar` - free variables being abstracted is a subprefix of the metavariable being assigned.
               We "substract" variables being abstracted because we use `elimMVarDeps` -/
            pure mvar
          else if mvarDecl.depth != mctx.depth || mvarDecl.kind.isSyntheticOpaque then
            traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
            throwCheckAssignmentFailure
          else
            let ctxMeta ← readThe Meta.Context
            if ctxMeta.config.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx then
              /- Create an auxiliary metavariable with a smaller context and "checked" type.
                 Note that `mvarType` may be different from `mvarDecl.type`. Example: `mvarType` contains
                 a metavariable that we also need to reduce the context.

                 We remove from `ctx.mvarDecl.lctx` any variable that is not in `mvarDecl.lctx`
                 or in `ctx.fvars`. We don't need to remove the ones in `ctx.fvars` because
                 `elimMVarDeps` will take care of them.

                 First, we collect `toErase` the variables that need to be erased.
                 Notat that if a variable is `ctx.fvars`, but it depends on variable at `toErase`,
                 we must also erase it.
              -/
              let toErase := mvarDecl.lctx.foldl (init := #[]) fun toErase localDecl =>
                if ctx.mvarDecl.lctx.contains localDecl.fvarId then
                  toErase
                else if ctx.fvars.any fun fvar => fvar.fvarId! == localDecl.fvarId then
                  if mctx.findLocalDeclDependsOn localDecl fun fvarId => toErase.contains fvarId then
                    -- localDecl depends on a variable that will be erased. So, we must add it to `toErase` too
                    toErase.push localDecl.fvarId
                  else
                    toErase
                else
                  toErase.push localDecl.fvarId
              let lctx := toErase.foldl (init := mvarDecl.lctx) fun lctx toEraseFVar =>
                lctx.erase toEraseFVar
              /- Compute new set of local instances. -/
              let localInsts := mvarDecl.localInstances.filter fun localInst => toErase.contains localInst.fvar.fvarId!
              let mvarType ← check mvarDecl.type
              let newMVar ← mkAuxMVar lctx localInsts mvarType mvarDecl.numScopeArgs
              modifyThe Meta.State fun s => { s with mctx := s.mctx.assignExpr mvarId newMVar }
              pure newMVar
            else
              traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
              throwCheckAssignmentFailure

  /-
    Auxiliary function used to "fix" subterms of the form `?m x_1 ... x_n` where `x_i`s are free variables,
    and one of them is out-of-scope.
    See `Expr.app` case at `check`.
    If `ctxApprox` is true, then we solve this case by creating a fresh metavariable ?n with the correct scope,
    an assigning `?m := fun _ ... _ => ?n` -/
  partial def assignToConstFun (mvar : Expr) (numArgs : Nat) (newMVar : Expr) : MetaM Bool := do
    let mvarType ← inferType mvar
    forallBoundedTelescope mvarType numArgs fun xs _ => do
      if xs.size != numArgs then pure false
      else
        let some v ← mkLambdaFVarsWithLetDeps xs newMVar | return false
        match (← checkAssignmentAux mvar.mvarId! #[] false v) with
        | some v => checkTypesAndAssign mvar v
        | none   => return false

  -- See checkAssignment
  partial def checkAssignmentAux (mvarId : MVarId) (fvars : Array Expr) (hasCtxLocals : Bool) (v : Expr) : MetaM (Option Expr) := do
    run (check v) mvarId fvars hasCtxLocals v

  partial def checkApp (e : Expr) : CheckAssignmentM Expr :=
    e.withApp fun f args => do
      let ctxMeta ← readThe Meta.Context
      if f.isMVar && ctxMeta.config.ctxApprox && args.all Expr.isFVar then
        let f ← visit checkMVar f
        catchInternalId outOfScopeExceptionId
          (do
            let args ← args.mapM (visit check)
            return mkAppN f args)
          (fun ex => do
            if !f.isMVar then
              throw ex
            else if (← isDelayedAssigned f.mvarId!) then
              throw ex
            else
              let eType ← inferType e
              let mvarType ← check eType
              /- Create an auxiliary metavariable with a smaller context and "checked" type, assign `?f := fun _ => ?newMVar`
                    Note that `mvarType` may be different from `eType`. -/
              let ctx ← read
              let newMVar ← mkAuxMVar ctx.mvarDecl.lctx ctx.mvarDecl.localInstances mvarType
              if (← assignToConstFun f args.size newMVar) then
                pure newMVar
              else
                throw ex)
      else
        let f ← visit check f
        let args ← args.mapM (visit check)
        return mkAppN f args

  partial def check (e : Expr) : CheckAssignmentM Expr := do
    match e with
    | Expr.mdata _ b _     => return e.updateMData! (← visit check b)
    | Expr.proj _ _ s _    => return e.updateProj! (← visit check s)
    | Expr.lam _ d b _     => return e.updateLambdaE! (← visit check d) (← visit check b)
    | Expr.forallE _ d b _ => return e.updateForallE! (← visit check d) (← visit check b)
    | Expr.letE _ t v b _  => return e.updateLet! (← visit check t) (← visit check v) (← visit check b)
    | Expr.bvar ..         => return e
    | Expr.sort ..         => return e
    | Expr.const ..        => return e
    | Expr.lit ..          => return e
    | Expr.fvar ..         => visit checkFVar e
    | Expr.mvar ..         => visit checkMVar e
    | Expr.app ..          =>
      checkApp e
      -- TODO: investigate whether the following feature is too expensive or not
      /-
      catchInternalIds [checkAssignmentExceptionId, outOfScopeExceptionId]
        (checkApp e)
        fun ex => do
          let e' ← whnfR e
          if e != e' then
            check e'
          else
            throw ex
      -/
end

end CheckAssignment

namespace CheckAssignmentQuick

partial def check
    (hasCtxLocals ctxApprox : Bool)
    (mctx : MetavarContext) (lctx : LocalContext) (mvarDecl : MetavarDecl) (mvarId : MVarId) (fvars : Array Expr) (e : Expr) : Bool :=
  let rec visit (e : Expr) : Bool :=
    if !e.hasExprMVar && !e.hasFVar then
      true
    else match e with
    | Expr.mdata _ b _     => visit b
    | Expr.proj _ _ s _    => visit s
    | Expr.app f a _       => visit f && visit a
    | Expr.lam _ d b _     => visit d && visit b
    | Expr.forallE _ d b _ => visit d && visit b
    | Expr.letE _ t v b _  => visit t && visit v && visit b
    | Expr.bvar ..         => true
    | Expr.sort ..         => true
    | Expr.const ..        => true
    | Expr.lit ..          => true
    | Expr.fvar fvarId ..  =>
      if mvarDecl.lctx.contains fvarId then true
      else match lctx.find? fvarId with
        | some (LocalDecl.ldecl (value := v) ..) => false -- need expensive CheckAssignment.check
        | _ =>
          if fvars.any fun x => x.fvarId! == fvarId then true
          else false -- We could throw an exception here, but we would have to use ExceptM. So, we let CheckAssignment.check do it
    | Expr.mvar mvarId' _  =>
      match mctx.getExprAssignment? mvarId' with
      | some _ => false -- use CheckAssignment.check to instantiate
      | none   =>
        if mvarId' == mvarId then false -- occurs check failed, use CheckAssignment.check to throw exception
        else match mctx.findDecl? mvarId' with
          | none           => false
          | some mvarDecl' =>
            if hasCtxLocals then false -- use CheckAssignment.check
            else if mvarDecl'.lctx.isSubPrefixOf mvarDecl.lctx fvars then true
            else false -- use CheckAssignment.check
  visit e

end CheckAssignmentQuick

/--
  Auxiliary function for handling constraints of the form `?m a₁ ... aₙ =?= v`.
  It will check whether we can perform the assignment
  ```
  ?m := fun fvars => v
  ```
  The result is `none` if the assignment can't be performed.
  The result is `some newV` where `newV` is a possibly updated `v`. This method may need
  to unfold let-declarations. -/
def checkAssignment (mvarId : MVarId) (fvars : Array Expr) (v : Expr) : MetaM (Option Expr) := do
  /- Check whether `mvarId` occurs in the type of `fvars` or not. If it does, return `none`
     to prevent us from creating the cyclic assignment `?m := fun fvars => v` -/
  for fvar in fvars do
    unless (← occursCheck mvarId (← inferType fvar)) do
      return none
  if !v.hasExprMVar && !v.hasFVar then
    pure (some v)
  else
    let mvarDecl ← getMVarDecl mvarId
    let hasCtxLocals := fvars.any fun fvar => mvarDecl.lctx.containsFVar fvar
    let ctx ← read
    let mctx ← getMCtx
    if CheckAssignmentQuick.check hasCtxLocals ctx.config.ctxApprox mctx ctx.lctx mvarDecl mvarId fvars v then
      pure (some v)
    else
      let v ← instantiateMVars v
      CheckAssignment.checkAssignmentAux mvarId fvars hasCtxLocals v

private def processAssignmentFOApproxAux (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool :=
  match v with
  | Expr.app f a _ =>
    if args.isEmpty then
      pure false
    else
      Meta.isExprDefEqAux args.back a <&&> Meta.isExprDefEqAux (mkAppRange mvar 0 (args.size - 1) args) f
  | _              => pure false

/-
  Auxiliary method for applying first-order unification. It is an approximation.
  Remark: this method is trying to solve the unification constraint:

      ?m a₁ ... aₙ =?= v

   It is uses processAssignmentFOApproxAux, if it fails, it tries to unfold `v`.

   We have added support for unfolding here because we want to be able to solve unification problems such as

      ?m Unit =?= ITactic

   where `ITactic` is defined as

   def ITactic := Tactic Unit
-/
private partial def processAssignmentFOApprox (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool :=
  let rec loop (v : Expr) := do
    let cfg ← getConfig
    if !cfg.foApprox then
      pure false
    else
      trace[Meta.isDefEq.foApprox] "{mvar} {args} := {v}"
      let v := v.headBeta
      if (← checkpointDefEq <| processAssignmentFOApproxAux mvar args v) then
        pure true
      else
        match (← unfoldDefinition? v) with
        | none   => pure false
        | some v => loop v
  loop v

private partial def simpAssignmentArgAux : Expr → MetaM Expr
  | Expr.mdata _ e _       => simpAssignmentArgAux e
  | e@(Expr.fvar fvarId _) => do
    let decl ← getLocalDecl fvarId
    match decl.value? with
    | some value => simpAssignmentArgAux value
    | _          => pure e
  | e => pure e

/- Auxiliary procedure for processing `?m a₁ ... aₙ =?= v`.
   We apply it to each `aᵢ`. It instantiates assigned metavariables if `aᵢ` is of the form `f[?n] b₁ ... bₘ`,
   and then removes metadata, and zeta-expand let-decls. -/
private def simpAssignmentArg (arg : Expr) : MetaM Expr := do
  let arg ← if arg.getAppFn.hasExprMVar then instantiateMVars arg else pure arg
  simpAssignmentArgAux arg

/- Assign `mvar := fun a_1 ... a_{numArgs} => v`.
   We use it at `processConstApprox` and `isDefEqMVarSelf` -/
private def assignConst (mvar : Expr) (numArgs : Nat) (v : Expr) : MetaM Bool := do
  let mvarDecl ← getMVarDecl mvar.mvarId!
  forallBoundedTelescope mvarDecl.type numArgs fun xs _ => do
    if xs.size != numArgs then
      pure false
    else
      let some v ← mkLambdaFVarsWithLetDeps xs v | pure false
      match (← checkAssignment mvar.mvarId! #[] v) with
      | none   => pure false
      | some v =>
        trace[Meta.isDefEq.constApprox] "{mvar} := {v}"
        checkTypesAndAssign mvar v

private def processConstApprox (mvar : Expr) (numArgs : Nat) (v : Expr) : MetaM Bool := do
  let cfg ← getConfig
  let mvarId := mvar.mvarId!
  let mvarDecl ← getMVarDecl mvarId
  if mvarDecl.numScopeArgs == numArgs || cfg.constApprox then
    assignConst mvar numArgs v
  else
    pure false

/-- Tries to solve `?m a₁ ... aₙ =?= v` by assigning `?m`.
    It assumes `?m` is unassigned. -/
private partial def processAssignment (mvarApp : Expr) (v : Expr) : MetaM Bool :=
  traceCtx `Meta.isDefEq.assign do
    trace[Meta.isDefEq.assign] "{mvarApp} := {v}"
    let mvar := mvarApp.getAppFn
    let mvarDecl ← getMVarDecl mvar.mvarId!
    let rec process (i : Nat) (args : Array Expr) (v : Expr) := do
      let cfg ← getConfig
      let useFOApprox (args : Array Expr) : MetaM Bool :=
        processAssignmentFOApprox mvar args v <||> processConstApprox mvar args.size v
      if h : i < args.size then
        let arg := args.get ⟨i, h⟩
        let arg ← simpAssignmentArg arg
        let args := args.set ⟨i, h⟩ arg
        match arg with
        | Expr.fvar fvarId _ =>
          if args[0:i].any fun prevArg => prevArg == arg then
            useFOApprox args
          else if mvarDecl.lctx.contains fvarId && !cfg.quasiPatternApprox then
            useFOApprox args
          else
            process (i+1) args v
        | _ =>
          useFOApprox args
      else
        let v ← instantiateMVars v -- enforce A4
        if v.getAppFn == mvar then
          -- using A6
          useFOApprox args
        else
          let mvarId := mvar.mvarId!
          match (← checkAssignment mvarId args v) with
          | none   => useFOApprox args
          | some v => do
            trace[Meta.isDefEq.assign.beforeMkLambda] "{mvar} {args} := {v}"
            let some v ← mkLambdaFVarsWithLetDeps args v | return false
            if args.any (fun arg => mvarDecl.lctx.containsFVar arg) then
              /- We need to type check `v` because abstraction using `mkLambdaFVars` may have produced
                 a type incorrect term. See discussion at A2 -/
              if (← isTypeCorrect v) then
                checkTypesAndAssign mvar v
              else
                trace[Meta.isDefEq.assign.typeError] "{mvar} := {v}"
                useFOApprox args
            else
              checkTypesAndAssign mvar v
    process 0 mvarApp.getAppArgs v

/--
  Similar to processAssignment, but if it fails, compute v's whnf and try again.
  This helps to solve constraints such as `?m =?= { α := ?m, ... }.α`
  Note this is not perfect solution since we still fail occurs check for constraints such as
  ```lean
    ?m =?= List { α := ?m, β := Nat }.β
  ```
-/
private def processAssignment' (mvarApp : Expr) (v : Expr) : MetaM Bool := do
  if (← processAssignment mvarApp v) then
    return true
  else
    let vNew ← whnf v
    if vNew != v then
      if mvarApp == vNew then
        return true
      else
        processAssignment mvarApp vNew
    else
      return false

private def isDeltaCandidate? (t : Expr) : MetaM (Option ConstantInfo) := do
  match t.getAppFn with
  | Expr.const c _ _ =>
    match (← getConst? c) with
    | r@(some info) => if info.hasValue then return r else return none
    | _             => return none
  | _ => pure none

/-- Auxiliary method for isDefEqDelta -/
private def isListLevelDefEq (us vs : List Level) : MetaM LBool :=
  toLBoolM <| isListLevelDefEqAux us vs

/-- Auxiliary method for isDefEqDelta -/
private def isDefEqLeft (fn : Name) (t s : Expr) : MetaM LBool := do
  trace[Meta.isDefEq.delta.unfoldLeft] fn
  toLBoolM <| Meta.isExprDefEqAux t s

/-- Auxiliary method for isDefEqDelta -/
private def isDefEqRight (fn : Name) (t s : Expr) : MetaM LBool := do
  trace[Meta.isDefEq.delta.unfoldRight] fn
  toLBoolM <| Meta.isExprDefEqAux t s

/-- Auxiliary method for isDefEqDelta -/
private def isDefEqLeftRight (fn : Name) (t s : Expr) : MetaM LBool := do
  trace[Meta.isDefEq.delta.unfoldLeftRight] fn
  toLBoolM <| Meta.isExprDefEqAux t s

/-- Try to solve `f a₁ ... aₙ =?= f b₁ ... bₙ` by solving `a₁ =?= b₁, ..., aₙ =?= bₙ`.

    Auxiliary method for isDefEqDelta -/
private def tryHeuristic (t s : Expr) : MetaM Bool :=
  let tFn := t.getAppFn
  let sFn := s.getAppFn
  traceCtx `Meta.isDefEq.delta do
    /-
      We process arguments before universe levels to reduce a source of brittleness in the TC procedure.

      In the TC procedure, we can solve problems containing metavariables.
      If the TC procedure tries to assign one of these metavariables, it interrupts the search
      using a "stuck" exception. The elaborator catches it, and "interprets" it as "we should try again later".
      Now suppose we have a TC problem, and there are two "local" candidate instances we can try: "bad" and "good".
      The "bad" candidate is stuck because of a universe metavariable in the TC problem.
      If we try "bad" first, the TC procedure is interrupted. Moreover, if we have ignored the exception,
      "bad" would fail anyway trying to assign two different free variables `α =?= β`.
      Example: `Preorder.{?u} α =?= Preorder.{?v} β`, where `?u` and `?v` are universe metavariables that were
      not created by the TC procedure.
      The key issue here is that we have an `isDefEq t s` invocation that is interrupted by the "stuck" exception,
      but it would have failed anyway if we had continued processing it.
      By solving the arguments first, we make the example above fail without throwing the "stuck" exception.

      TODO: instead of throwing an exception as soon as we get stuck, we should just set a flag.
      Then the entry-point for `isDefEq` checks the flag before returning `true`.
    -/
    checkpointDefEq do
      let b ← isDefEqArgs tFn t.getAppArgs s.getAppArgs
              <&&>
              isListLevelDefEqAux tFn.constLevels! sFn.constLevels!
      unless b do
        trace[Meta.isDefEq.delta] "heuristic failed {t} =?= {s}"
      pure b

/-- Auxiliary method for isDefEqDelta -/
private abbrev unfold (e : Expr) (failK : MetaM α) (successK : Expr → MetaM α) : MetaM α := do
  match (← unfoldDefinition? e) with
  | some e => successK e
  | none   => failK

/-- Auxiliary method for isDefEqDelta -/
private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := do
  match t, s with
  | Expr.const _ ls₁ _, Expr.const _ ls₂ _ => isListLevelDefEq ls₁ ls₂
  | Expr.app _ _ _,     Expr.app _ _ _     =>
    if (← tryHeuristic t s) then
      pure LBool.true
    else
      unfold t
       (unfold s (pure LBool.false) (fun s => isDefEqRight fn t s))
       (fun t => unfold s (isDefEqLeft fn t s) (fun s => isDefEqLeftRight fn t s))
  | _, _ => pure LBool.false

private def sameHeadSymbol (t s : Expr) : Bool :=
  match t.getAppFn, s.getAppFn with
  | Expr.const c₁ _ _, Expr.const c₂ _ _ => true
  | _,                 _                 => false

/--
  - If headSymbol (unfold t) == headSymbol s, then unfold t
  - If headSymbol (unfold s) == headSymbol t, then unfold s
  - Otherwise unfold t and s if possible.

  Auxiliary method for isDefEqDelta -/
private def unfoldComparingHeadsDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool :=
  unfold t
    (unfold s
      (pure LBool.undef) -- `t` and `s` failed to be unfolded
      (fun s => isDefEqRight sInfo.name t s))
    (fun tNew =>
      if sameHeadSymbol tNew s then
        isDefEqLeft tInfo.name tNew s
      else
        unfold s
          (isDefEqLeft tInfo.name tNew s)
          (fun sNew =>
            if sameHeadSymbol t sNew then
              isDefEqRight sInfo.name t sNew
            else
              isDefEqLeftRight tInfo.name tNew sNew))

/-- If `t` and `s` do not contain metavariables, then use
    kernel definitional equality heuristics.
    Otherwise, use `unfoldComparingHeadsDefEq`.

    Auxiliary method for isDefEqDelta -/
private def unfoldDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool :=
  if !t.hasExprMVar && !s.hasExprMVar then
    /- If `t` and `s` do not contain metavariables,
       we simulate strategy used in the kernel. -/
    if tInfo.hints.lt sInfo.hints then
      unfold t (unfoldComparingHeadsDefEq tInfo sInfo t s) fun t => isDefEqLeft tInfo.name t s
    else if sInfo.hints.lt tInfo.hints then
      unfold s (unfoldComparingHeadsDefEq tInfo sInfo t s) fun s => isDefEqRight sInfo.name t s
    else
      unfoldComparingHeadsDefEq tInfo sInfo t s
  else
    unfoldComparingHeadsDefEq tInfo sInfo t s

/--
  When `TransparencyMode` is set to `default` or `all`.
  If `t` is reducible and `s` is not ==> `isDefEqLeft  (unfold t) s`
  If `s` is reducible and `t` is not ==> `isDefEqRight t (unfold s)`

  Otherwise, use `unfoldDefEq`

  Auxiliary method for isDefEqDelta -/
private def unfoldReducibeDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := do
  if (← shouldReduceReducibleOnly) then
    unfoldDefEq tInfo sInfo t s
  else
    let tReducible ← isReducible tInfo.name
    let sReducible ← isReducible sInfo.name
    if tReducible && !sReducible then
      unfold t (unfoldDefEq tInfo sInfo t s) fun t => isDefEqLeft tInfo.name t s
    else if !tReducible && sReducible then
      unfold s (unfoldDefEq tInfo sInfo t s) fun s => isDefEqRight sInfo.name t s
    else
      unfoldDefEq tInfo sInfo t s

/--
  If `t` is a projection function application and `s` is not ==> `isDefEqRight t (unfold s)`
  If `s` is a projection function application and `t` is not ==> `isDefEqRight (unfold t) s`

  Otherwise, use `unfoldReducibeDefEq`

  Auxiliary method for isDefEqDelta -/
private def unfoldNonProjFnDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := do
  let tProj? ← isProjectionFn tInfo.name
  let sProj? ← isProjectionFn sInfo.name
  if tProj? && !sProj? then
    unfold s (unfoldDefEq tInfo sInfo t s) fun s => isDefEqRight sInfo.name t s
  else if !tProj? && sProj? then
    unfold t (unfoldDefEq tInfo sInfo t s) fun t => isDefEqLeft tInfo.name t s
  else
    unfoldReducibeDefEq tInfo sInfo t s

/--
  isDefEq by lazy delta reduction.
  This method implements many different heuristics:
  1- If only `t` can be unfolded => then unfold `t` and continue
  2- If only `s` can be unfolded => then unfold `s` and continue
  3- If `t` and `s` can be unfolded and they have the same head symbol, then
     a) First try to solve unification by unifying arguments.
     b) If it fails, unfold both and continue.
     Implemented by `unfoldBothDefEq`
  4- If `t` is a projection function application and `s` is not => then unfold `s` and continue.
  5- If `s` is a projection function application and `t` is not => then unfold `t` and continue.
  Remark: 4&5 are implemented by `unfoldNonProjFnDefEq`
  6- If `t` is reducible and `s` is not => then unfold `t` and continue.
  7- If `s` is reducible and `t` is not => then unfold `s` and continue
  Remark: 6&7 are implemented by `unfoldReducibeDefEq`
  8- If `t` and `s` do not contain metavariables, then use heuristic used in the Kernel.
     Implemented by `unfoldDefEq`
  9- If `headSymbol (unfold t) == headSymbol s`, then unfold t and continue.
  10- If `headSymbol (unfold s) == headSymbol t`, then unfold s
  11- Otherwise, unfold `t` and `s` and continue.
  Remark: 9&10&11 are implemented by `unfoldComparingHeadsDefEq` -/
private def isDefEqDelta (t s : Expr) : MetaM LBool := do
  let tInfo? ← isDeltaCandidate? t.getAppFn
  let sInfo? ← isDeltaCandidate? s.getAppFn
  match tInfo?, sInfo? with
  | none,       none       => pure LBool.undef
  | some tInfo, none       => unfold t (pure LBool.undef) fun t => isDefEqLeft tInfo.name t s
  | none,       some sInfo => unfold s (pure LBool.undef) fun s => isDefEqRight sInfo.name t s
  | some tInfo, some sInfo =>
    if tInfo.name == sInfo.name then
      unfoldBothDefEq tInfo.name t s
    else
      unfoldNonProjFnDefEq tInfo sInfo t s

private def isAssigned : Expr → MetaM Bool
  | Expr.mvar mvarId _ => isExprMVarAssigned mvarId
  | _                  => pure false

private def isDelayedAssignedHead (tFn : Expr) (t : Expr) : MetaM Bool := do
  match tFn with
  | Expr.mvar mvarId _ =>
    if (← isDelayedAssigned mvarId) then
      let tNew ← instantiateMVars t
      return tNew != t
    else
      pure false
  | _ => pure false

private def isSynthetic : Expr → MetaM Bool
  | Expr.mvar mvarId _ => do
    let mvarDecl ← getMVarDecl mvarId
    match mvarDecl.kind with
    | MetavarKind.synthetic       => pure true
    | MetavarKind.syntheticOpaque => pure true
    | MetavarKind.natural         => pure false
  | _                  => pure false

private def isAssignable : Expr → MetaM Bool
  | Expr.mvar mvarId _ => do let b ← isReadOnlyOrSyntheticOpaqueExprMVar mvarId; pure (!b)
  | _                  => pure false

private def etaEq (t s : Expr) : Bool :=
  match t.etaExpanded? with
  | some t => t == s
  | none   => false

private def isLetFVar (fvarId : FVarId) : MetaM Bool := do
  let decl ← getLocalDecl fvarId
  pure decl.isLet

private def isDefEqProofIrrel (t s : Expr) : MetaM LBool := do
  if (← getConfig).proofIrrelevance then
    let status ← isProofQuick t
    match status with
    | LBool.false =>
      pure LBool.undef
    | LBool.true  =>
      let tType ← inferType t
      let sType ← inferType s
      toLBoolM <| Meta.isExprDefEqAux tType sType
    | LBool.undef =>
      let tType ← inferType t
      if (← isProp tType) then
        let sType ← inferType s
        toLBoolM <| Meta.isExprDefEqAux tType sType
      else
        pure LBool.undef
  else
    pure LBool.undef

/- Try to solve constraint of the form `?m args₁ =?= ?m args₂`.
   - First try to unify `args₁` and `args₂`, and return true if successful
   - Otherwise, try to assign `?m` to a constant function of the form `fun x_1 ... x_n => ?n`
     where `?n` is a fresh metavariable. See `processConstApprox`. -/
private def isDefEqMVarSelf (mvar : Expr) (args₁ args₂ : Array Expr) : MetaM Bool := do
  if args₁.size != args₂.size then
    pure false
  else if (← isDefEqArgs mvar args₁ args₂) then
    pure true
  else if !(← isAssignable mvar) then
    pure false
  else
    let cfg ← getConfig
    let mvarId := mvar.mvarId!
    let mvarDecl ← getMVarDecl mvarId
    if mvarDecl.numScopeArgs == args₁.size || cfg.constApprox then
      let type ← inferType (mkAppN mvar args₁)
      let auxMVar ← mkAuxMVar mvarDecl.lctx mvarDecl.localInstances type
      assignConst mvar args₁.size auxMVar
    else
      pure false

/- Remove unnecessary let-decls -/
private def consumeLet : Expr → Expr
  | e@(Expr.letE _ _ _ b _) => if b.hasLooseBVars then e else consumeLet b
  | e                       => e

mutual

private partial def isDefEqQuick (t s : Expr) : MetaM LBool :=
  let t := consumeLet t
  let s := consumeLet s
  match t, s with
  | Expr.lit  l₁ _,      Expr.lit l₂ _       => return (l₁ == l₂).toLBool
  | Expr.sort u _,       Expr.sort v _       => toLBoolM <| isLevelDefEqAux u v
  | Expr.lam ..,         Expr.lam ..         => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
  | Expr.forallE ..,     Expr.forallE ..     => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
  | Expr.mdata _ t _,    s                   => isDefEqQuick t s
  | t,                   Expr.mdata _ s _    => isDefEqQuick t s
  | Expr.fvar fvarId₁ _, Expr.fvar fvarId₂ _ => do
    if (← isLetFVar fvarId₁ <||> isLetFVar fvarId₂) then
      pure LBool.undef
    else if fvarId₁ == fvarId₂ then
      pure LBool.true
    else
      isDefEqProofIrrel t s
  | t, s =>
    isDefEqQuickOther t s

private partial def isDefEqQuickOther (t s : Expr) : MetaM LBool := do
  if t == s then
    pure LBool.true
  else if etaEq t s || etaEq s t then
    pure LBool.true  -- t =?= (fun xs => t xs)
  else
    let tFn := t.getAppFn
    let sFn := s.getAppFn
    if !tFn.isMVar && !sFn.isMVar then
      pure LBool.undef
    else if (← isAssigned tFn) then
      let t ← instantiateMVars t
      isDefEqQuick t s
    else if (← isAssigned sFn) then
      let s ← instantiateMVars s
      isDefEqQuick t s
    else if (← isDelayedAssignedHead tFn t) then
      let t ← instantiateMVars t
      isDefEqQuick t s
    else if (← isDelayedAssignedHead sFn s) then
      let s ← instantiateMVars s
      isDefEqQuick t s
    else if (← isSynthetic tFn <&&> trySynthPending tFn) then
      let t ← instantiateMVars t
      isDefEqQuick t s
    else if (← isSynthetic sFn <&&> trySynthPending sFn) then
      let s ← instantiateMVars s
      isDefEqQuick t s
    else if tFn.isMVar && sFn.isMVar && tFn == sFn then
      Bool.toLBool <$> isDefEqMVarSelf tFn t.getAppArgs s.getAppArgs
    else
      let tAssign? ← isAssignable tFn
      let sAssign? ← isAssignable sFn
      let assignableMsg (b : Bool) := if b then "[assignable]" else "[nonassignable]"
      trace[Meta.isDefEq] "{t} {assignableMsg tAssign?} =?= {s} {assignableMsg sAssign?}"
      if tAssign? && !sAssign? then
        toLBoolM <| processAssignment' t s
      else if !tAssign? && sAssign? then
        toLBoolM <| processAssignment' s t
      else if !tAssign? && !sAssign? then
        if tFn.isMVar || sFn.isMVar then
          let ctx ← read
          if ctx.config.isDefEqStuckEx then do
            trace[Meta.isDefEq.stuck] "{t} =?= {s}"
            Meta.throwIsDefEqStuck
          else
            pure LBool.false
        else
          pure LBool.undef
      else
        isDefEqQuickMVarMVar t s

-- Both `t` and `s` are terms of the form `?m ...`
private partial def isDefEqQuickMVarMVar (t s : Expr) : MetaM LBool := do
  let tFn := t.getAppFn
  let sFn := s.getAppFn
  let tMVarDecl ← getMVarDecl tFn.mvarId!
  let sMVarDecl ← getMVarDecl sFn.mvarId!
  if s.isMVar && !t.isMVar then
     /- Solve `?m t =?= ?n` by trying first `?n := ?m t`.
        Reason: this assignment is precise. -/
     if (← checkpointDefEq (processAssignment s t)) then
       pure LBool.true
     else
       toLBoolM <| processAssignment t s
  else
     if (← checkpointDefEq (processAssignment t s)) then
       pure LBool.true
     else
       toLBoolM <| processAssignment s t

end

@[inline] def whenUndefDo (x : MetaM LBool) (k : MetaM Bool) : MetaM Bool := do
  let status ← x
  match status with
  | LBool.true  => pure true
  | LBool.false => pure false
  | LBool.undef => k

@[specialize] private def unstuckMVar (e : Expr) (successK : Expr → MetaM Bool) (failK : MetaM Bool): MetaM Bool := do
  match (← getStuckMVar? e) with
  | some mvarId =>
    trace[Meta.isDefEq.stuckMVar] "found stuck MVar {mkMVar mvarId} : {← inferType (mkMVar mvarId)}"
    if (← Meta.synthPending mvarId) then
      let e ← instantiateMVars e
      successK e
    else
      failK
  | none   => failK

private def isDefEqOnFailure (t s : Expr) : MetaM Bool :=
  unstuckMVar t (fun t => Meta.isExprDefEqAux t s) <|
  unstuckMVar s (fun s => Meta.isExprDefEqAux t s) <|
  tryUnificationHints t s <||> tryUnificationHints s t

private def isDefEqProj : Expr → Expr → MetaM Bool
  | Expr.proj _ i t _, Expr.proj _ j s _ => pure (i == j) <&&> Meta.isExprDefEqAux t s
  | Expr.proj structName 0 s _, v => isDefEqSingleton structName s v
  | v, Expr.proj structName 0 s _ => isDefEqSingleton structName s v
  | _, _ => pure false
where
  /- If `structName` is a structure with a single field, then reduce `s.1 =?= v` to `s =?= ⟨v⟩` -/
  isDefEqSingleton (structName : Name) (s : Expr) (v : Expr) : MetaM Bool := do
    let ctorVal := getStructureCtor (← getEnv) structName
    if ctorVal.numFields != 1 then
      return false -- It is not a structure with a single field.
    let sType ← whnf (← inferType s)
    let sTypeFn := sType.getAppFn
    if !sTypeFn.isConstOf structName then
      return false
    let ctorApp := mkApp (mkAppN (mkConst ctorVal.name sTypeFn.constLevels!) sType.getAppArgs) v
    Meta.isExprDefEqAux s ctorApp

/-
  Given applications `t` and `s` that are in WHNF (modulo the current transparency setting),
  check whether they are definitionally equal or not.
-/
private def isDefEqApp (t s : Expr) : MetaM Bool := do
  let tFn := t.getAppFn
  let sFn := s.getAppFn
  if tFn.isConst && sFn.isConst && tFn.constName! == sFn.constName! then
    /- See comment at `tryHeuristic` explaining why we processe arguments before universe levels. -/
    if (← checkpointDefEq (isDefEqArgs tFn t.getAppArgs s.getAppArgs <&&> isListLevelDefEqAux tFn.constLevels! sFn.constLevels!)) then
      return true
    else
      isDefEqOnFailure t s
  else if (← checkpointDefEq (Meta.isExprDefEqAux tFn s.getAppFn <&&> isDefEqArgs tFn t.getAppArgs s.getAppArgs)) then
    return true
  else
    isDefEqOnFailure t s

partial def isExprDefEqAuxImpl (t : Expr) (s : Expr) : MetaM Bool := do
  trace[Meta.isDefEq.step] "{t} =?= {s}"
  checkMaxHeartbeats "isDefEq"
  withNestedTraces do
  whenUndefDo (isDefEqQuick t s) do
  whenUndefDo (isDefEqProofIrrel t s) do
  let t' ← whnfCore t
  let s' ← whnfCore s
  if t != t' || s != s' then
    isExprDefEqAuxImpl t' s'
  else do
    if (← (isDefEqEta t s <||> isDefEqEta s t)) then pure true else
    if (← isDefEqProj t s) then pure true else
    whenUndefDo (isDefEqNative t s) do
    whenUndefDo (isDefEqNat t s) do
    whenUndefDo (isDefEqOffset t s) do
    whenUndefDo (isDefEqDelta t s) do
    if t.isConst && s.isConst then
      if t.constName! == s.constName! then isListLevelDefEqAux t.constLevels! s.constLevels! else pure false
    else if t.isApp && s.isApp then
      isDefEqApp t s
    else
      whenUndefDo (isDefEqStringLit t s) do
      isDefEqOnFailure t s

builtin_initialize
  isExprDefEqAuxRef.set isExprDefEqAuxImpl

builtin_initialize
  registerTraceClass `Meta.isDefEq
  registerTraceClass `Meta.isDefEq.foApprox
  registerTraceClass `Meta.isDefEq.constApprox
  registerTraceClass `Meta.isDefEq.delta
  registerTraceClass `Meta.isDefEq.step
  registerTraceClass `Meta.isDefEq.assign

end Lean.Meta


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module category_theory.sites.subsheaf
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Elementwise
import Mathbin.CategoryTheory.Adjunction.Evaluation
import Mathbin.CategoryTheory.Sites.Sheafification

/-!

# Subsheaf of types

We define the sub(pre)sheaf of a type valued presheaf.

## Main results

- `category_theory.grothendieck_topology.subpresheaf` :
  A subpresheaf of a presheaf of types.
- `category_theory.grothendieck_topology.subpresheaf.sheafify` :
  The sheafification of a subpresheaf as a subpresheaf. Note that this is a sheaf only when the
  whole sheaf is.
- `category_theory.grothendieck_topology.subpresheaf.sheafify_is_sheaf` :
  The sheafification is a sheaf
- `category_theory.grothendieck_topology.subpresheaf.sheafify_lift` :
  The descent of a map into a sheaf to the sheafification.
- `category_theory.grothendieck_topology.image_sheaf` : The image sheaf of a morphism.
- `category_theory.grothendieck_topology.image_factorization` : The image sheaf as a
  `limits.image_factorization`.
-/

universe w v u

open Opposite CategoryTheory

namespace CategoryTheory.GrothendieckTopology

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

/-- A subpresheaf of a presheaf consists of a subset of `F.obj U` for every `U`,
compatible with the restriction maps `F.map i`. -/
@[ext]
structure Subpresheaf (F : Cᵒᵖ ⥤ Type w) where
  obj : ∀ U, Set (F.obj U)
  map : ∀ {U V : Cᵒᵖ} (i : U ⟶ V), obj U ⊆ F.map i ⁻¹' obj V
#align category_theory.grothendieck_topology.subpresheaf CategoryTheory.GrothendieckTopology.Subpresheaf

variable {F F' F'' : Cᵒᵖ ⥤ Type w} (G G' : Subpresheaf F)

instance : PartialOrder (Subpresheaf F) :=
  PartialOrder.lift Subpresheaf.obj Subpresheaf.ext

instance : Top (Subpresheaf F) :=
  ⟨⟨fun U => ⊤, fun U V i x h => trivial⟩⟩

instance : Nonempty (Subpresheaf F) :=
  inferInstance

/-- The subpresheaf as a presheaf. -/
@[simps]
def Subpresheaf.toPresheaf : Cᵒᵖ ⥤ Type w
    where
  obj U := G.obj U
  map U V i x := ⟨F.map i x, G.map i x.Prop⟩
  map_id' X := by
    ext ⟨x, _⟩
    dsimp
    rw [F.map_id]
    rfl
  map_comp' X Y Z i j := by
    ext ⟨x, _⟩
    dsimp
    rw [F.map_comp]
    rfl
#align category_theory.grothendieck_topology.subpresheaf.to_presheaf CategoryTheory.GrothendieckTopology.Subpresheaf.toPresheaf

instance {U} : Coe (G.toPresheaf.obj U) (F.obj U) :=
  coeSubtype

/-- The inclusion of a subpresheaf to the original presheaf. -/
@[simps]
def Subpresheaf.ι : G.toPresheaf ⟶ F where app U x := x
#align category_theory.grothendieck_topology.subpresheaf.ι CategoryTheory.GrothendieckTopology.Subpresheaf.ι

instance : Mono G.ι :=
  ⟨fun H f₁ f₂ e =>
    NatTrans.ext f₁ f₂ <|
      funext fun U => funext fun x => Subtype.ext <| congr_fun (congr_app e U) x⟩

/-- The inclusion of a subpresheaf to a larger subpresheaf -/
@[simps]
def Subpresheaf.homOfLe {G G' : Subpresheaf F} (h : G ≤ G') : G.toPresheaf ⟶ G'.toPresheaf
    where app U x := ⟨x, h U x.Prop⟩
#align category_theory.grothendieck_topology.subpresheaf.hom_of_le CategoryTheory.GrothendieckTopology.Subpresheaf.homOfLe

instance {G G' : Subpresheaf F} (h : G ≤ G') : Mono (Subpresheaf.homOfLe h) :=
  ⟨fun H f₁ f₂ e =>
    NatTrans.ext f₁ f₂ <|
      funext fun U =>
        funext fun x =>
          Subtype.ext <| (congr_arg Subtype.val <| (congr_fun (congr_app e U) x : _) : _)⟩

@[simp, reassoc.1]
theorem Subpresheaf.homOfLe_ι {G G' : Subpresheaf F} (h : G ≤ G') :
    Subpresheaf.homOfLe h ≫ G'.ι = G.ι := by
  ext
  rfl
#align category_theory.grothendieck_topology.subpresheaf.hom_of_le_ι CategoryTheory.GrothendieckTopology.Subpresheaf.homOfLe_ι

instance : IsIso (Subpresheaf.ι (⊤ : Subpresheaf F)) :=
  by
  apply (config := { instances := false }) nat_iso.is_iso_of_is_iso_app
  · intro X
    rw [is_iso_iff_bijective]
    exact ⟨Subtype.coe_injective, fun x => ⟨⟨x, _root_.trivial⟩, rfl⟩⟩

theorem Subpresheaf.eq_top_iff_isIso : G = ⊤ ↔ IsIso G.ι :=
  by
  constructor
  · rintro rfl
    infer_instance
  · intro H
    ext (U x)
    apply (iff_true_iff _).mpr
    rw [← is_iso.inv_hom_id_apply (G.ι.app U) x]
    exact ((inv (G.ι.app U)) x).2
#align category_theory.grothendieck_topology.subpresheaf.eq_top_iff_is_iso CategoryTheory.GrothendieckTopology.Subpresheaf.eq_top_iff_isIso

/-- If the image of a morphism falls in a subpresheaf, then the morphism factors through it. -/
@[simps]
def Subpresheaf.lift (f : F' ⟶ F) (hf : ∀ U x, f.app U x ∈ G.obj U) : F' ⟶ G.toPresheaf
    where
  app U x := ⟨f.app U x, hf U x⟩
  naturality' := by
    have := elementwise_of f.naturality
    intros
    ext
    simp [this]
#align category_theory.grothendieck_topology.subpresheaf.lift CategoryTheory.GrothendieckTopology.Subpresheaf.lift

@[simp, reassoc.1]
theorem Subpresheaf.lift_ι (f : F' ⟶ F) (hf : ∀ U x, f.app U x ∈ G.obj U) : G.lift f hf ≫ G.ι = f :=
  by
  ext
  rfl
#align category_theory.grothendieck_topology.subpresheaf.lift_ι CategoryTheory.GrothendieckTopology.Subpresheaf.lift_ι

/-- Given a subpresheaf `G` of `F`, an `F`-section `s` on `U`, we may define a sieve of `U`
consisting of all `f : V ⟶ U` such that the restriction of `s` along `f` is in `G`. -/
@[simps]
def Subpresheaf.sieveOfSection {U : Cᵒᵖ} (s : F.obj U) : Sieve (unop U)
    where
  arrows V f := F.map f.op s ∈ G.obj (op V)
  downward_closed' V W i hi j :=
    by
    rw [op_comp, functor_to_types.map_comp_apply]
    exact G.map _ hi
#align category_theory.grothendieck_topology.subpresheaf.sieve_of_section CategoryTheory.GrothendieckTopology.Subpresheaf.sieveOfSection

/-- Given a `F`-section `s` on `U` and a subpresheaf `G`, we may define a family of elements in
`G` consisting of the restrictions of `s` -/
def Subpresheaf.familyOfElementsOfSection {U : Cᵒᵖ} (s : F.obj U) :
    (G.sieveOfSection s).1.FamilyOfElements G.toPresheaf := fun V i hi => ⟨F.map i.op s, hi⟩
#align category_theory.grothendieck_topology.subpresheaf.family_of_elements_of_section CategoryTheory.GrothendieckTopology.Subpresheaf.familyOfElementsOfSection

theorem Subpresheaf.family_of_elements_compatible {U : Cᵒᵖ} (s : F.obj U) :
    (G.familyOfElementsOfSection s).Compatible :=
  by
  intro Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ e
  ext1
  change F.map g₁.op (F.map f₁.op s) = F.map g₂.op (F.map f₂.op s)
  rw [← functor_to_types.map_comp_apply, ← functor_to_types.map_comp_apply, ← op_comp, ← op_comp, e]
#align category_theory.grothendieck_topology.subpresheaf.family_of_elements_compatible CategoryTheory.GrothendieckTopology.Subpresheaf.family_of_elements_compatible

theorem Subpresheaf.nat_trans_naturality (f : F' ⟶ G.toPresheaf) {U V : Cᵒᵖ} (i : U ⟶ V)
    (x : F'.obj U) : (f.app V (F'.map i x)).1 = F.map i (f.app U x).1 :=
  congr_arg Subtype.val (FunctorToTypes.naturality _ _ f i x)
#align category_theory.grothendieck_topology.subpresheaf.nat_trans_naturality CategoryTheory.GrothendieckTopology.Subpresheaf.nat_trans_naturality

include J

/-- The sheafification of a subpresheaf as a subpresheaf.
Note that this is a sheaf only when the whole presheaf is a sheaf. -/
def Subpresheaf.sheafify : Subpresheaf F
    where
  obj U := { s | G.sieveOfSection s ∈ J (unop U) }
  map := by
    rintro U V i s hs
    refine' J.superset_covering _ (J.pullback_stable i.unop hs)
    intro _ _ h
    dsimp at h⊢
    rwa [← functor_to_types.map_comp_apply]
#align category_theory.grothendieck_topology.subpresheaf.sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify

theorem Subpresheaf.le_sheafify : G ≤ G.sheafify J :=
  by
  intro U s hs
  change _ ∈ J _
  convert J.top_mem _
  rw [eq_top_iff]
  rintro V i -
  exact G.map i.op hs
#align category_theory.grothendieck_topology.subpresheaf.le_sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.le_sheafify

variable {J}

theorem Subpresheaf.eq_sheafify (h : Presieve.IsSheaf J F) (hG : Presieve.IsSheaf J G.toPresheaf) :
    G = G.sheafify J := by
  apply (G.le_sheafify J).antisymm
  intro U s hs
  suffices ((hG _ hs).amalgamate _ (G.family_of_elements_compatible s)).1 = s
    by
    rw [← this]
    exact ((hG _ hs).amalgamate _ (G.family_of_elements_compatible s)).2
  apply (h _ hs).IsSeparatedFor.ext
  intro V i hi
  exact (congr_arg Subtype.val ((hG _ hs).valid_glue (G.family_of_elements_compatible s) _ hi) : _)
#align category_theory.grothendieck_topology.subpresheaf.eq_sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.eq_sheafify

theorem Subpresheaf.sheafify_isSheaf (hF : Presieve.IsSheaf J F) :
    Presieve.IsSheaf J (G.sheafify J).toPresheaf :=
  by
  intro U S hS x hx
  let S' := sieve.bind S fun Y f hf => G.sieve_of_section (x f hf).1
  have := fun {V} {i : V ⟶ U} (hi : S' i) => hi
  choose W i₁ i₂ hi₂ h₁ h₂
  dsimp [-sieve.bind_apply] at *
  let x'' : presieve.family_of_elements F S' := fun V i hi => F.map (i₁ hi).op (x _ (hi₂ hi))
  have H : ∀ s, x.is_amalgamation s ↔ x''.is_amalgamation s.1 :=
    by
    intro s
    constructor
    · intro H V i hi
      dsimp only [x'']
      conv_lhs => rw [← h₂ hi]
      rw [← H _ (hi₂ hi)]
      exact functor_to_types.map_comp_apply F (i₂ hi).op (i₁ hi).op _
    · intro H V i hi
      ext1
      apply (hF _ (x i hi).2).IsSeparatedFor.ext
      intro V' i' hi'
      have hi'' : S' (i' ≫ i) := ⟨_, _, _, hi, hi', rfl⟩
      have := H _ hi''
      rw [op_comp, F.map_comp] at this
      refine' this.trans (congr_arg Subtype.val (hx _ _ (hi₂ hi'') hi (h₂ hi'')))
  have : x''.compatible := by
    intro V₁ V₂ V₃ g₁ g₂ g₃ g₄ S₁ S₂ e
    rw [← functor_to_types.map_comp_apply, ← functor_to_types.map_comp_apply]
    exact
      congr_arg Subtype.val
        (hx (g₁ ≫ i₁ S₁) (g₂ ≫ i₁ S₂) (hi₂ S₁) (hi₂ S₂) (by simp only [category.assoc, h₂, e]))
  obtain ⟨t, ht, ht'⟩ := hF _ (J.bind_covering hS fun V i hi => (x i hi).2) _ this
  refine' ⟨⟨t, _⟩, (H ⟨t, _⟩).mpr ht, fun y hy => Subtype.ext (ht' _ ((H _).mp hy))⟩
  show G.sieve_of_section t ∈ J _
  refine' J.superset_covering _ (J.bind_covering hS fun V i hi => (x i hi).2)
  intro V i hi
  dsimp
  rw [ht _ hi]
  exact h₁ hi
#align category_theory.grothendieck_topology.subpresheaf.sheafify_is_sheaf CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify_isSheaf

theorem Subpresheaf.eq_sheafify_iff (h : Presieve.IsSheaf J F) :
    G = G.sheafify J ↔ Presieve.IsSheaf J G.toPresheaf :=
  ⟨fun e => e.symm ▸ G.sheafify_isSheaf h, G.eq_sheafify h⟩
#align category_theory.grothendieck_topology.subpresheaf.eq_sheafify_iff CategoryTheory.GrothendieckTopology.Subpresheaf.eq_sheafify_iff

theorem Subpresheaf.isSheaf_iff (h : Presieve.IsSheaf J F) :
    Presieve.IsSheaf J G.toPresheaf ↔
      ∀ (U) (s : F.obj U), G.sieveOfSection s ∈ J (unop U) → s ∈ G.obj U :=
  by
  rw [← G.eq_sheafify_iff h]
  change _ ↔ G.sheafify J ≤ G
  exact ⟨Eq.ge, (G.le_sheafify J).antisymm⟩
#align category_theory.grothendieck_topology.subpresheaf.is_sheaf_iff CategoryTheory.GrothendieckTopology.Subpresheaf.isSheaf_iff

theorem Subpresheaf.sheafify_sheafify (h : Presieve.IsSheaf J F) :
    (G.sheafify J).sheafify J = G.sheafify J :=
  ((Subpresheaf.eq_sheafify_iff _ h).mpr <| G.sheafify_isSheaf h).symm
#align category_theory.grothendieck_topology.subpresheaf.sheafify_sheafify CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify_sheafify

/-- The lift of a presheaf morphism onto the sheafification subpresheaf.  -/
noncomputable def Subpresheaf.sheafifyLift (f : G.toPresheaf ⟶ F') (h : Presieve.IsSheaf J F') :
    (G.sheafify J).toPresheaf ⟶ F'
    where
  app U s := (h _ s.Prop).amalgamate _ ((G.family_of_elements_compatible ↑s).compPresheafMap f)
  naturality' := by
    intro U V i
    ext s
    apply (h _ ((subpresheaf.sheafify J G).toPresheaf.map i s).Prop).IsSeparatedFor.ext
    intro W j hj
    refine' (presieve.is_sheaf_for.valid_glue _ _ _ hj).trans _
    dsimp
    conv_rhs => rw [← functor_to_types.map_comp_apply]
    change _ = F'.map (j ≫ i.unop).op _
    refine' Eq.trans _ (presieve.is_sheaf_for.valid_glue _ _ _ _).symm
    · dsimp at hj⊢
      rwa [functor_to_types.map_comp_apply]
    · dsimp [presieve.family_of_elements.comp_presheaf_map]
      congr 1
      ext1
      exact (functor_to_types.map_comp_apply _ _ _ _).symm
#align category_theory.grothendieck_topology.subpresheaf.sheafify_lift CategoryTheory.GrothendieckTopology.Subpresheaf.sheafifyLift

theorem Subpresheaf.to_sheafifyLift (f : G.toPresheaf ⟶ F') (h : Presieve.IsSheaf J F') :
    Subpresheaf.homOfLe (G.le_sheafify J) ≫ G.sheafifyLift f h = f :=
  by
  ext (U s)
  apply (h _ ((subpresheaf.hom_of_le (G.le_sheafify J)).app U s).Prop).IsSeparatedFor.ext
  intro V i hi
  have := elementwise_of f.naturality
  exact (presieve.is_sheaf_for.valid_glue _ _ _ hi).trans (this _ _)
#align category_theory.grothendieck_topology.subpresheaf.to_sheafify_lift CategoryTheory.GrothendieckTopology.Subpresheaf.to_sheafifyLift

theorem Subpresheaf.to_sheafify_lift_unique (h : Presieve.IsSheaf J F')
    (l₁ l₂ : (G.sheafify J).toPresheaf ⟶ F')
    (e : Subpresheaf.homOfLe (G.le_sheafify J) ≫ l₁ = Subpresheaf.homOfLe (G.le_sheafify J) ≫ l₂) :
    l₁ = l₂ := by
  ext (U⟨s, hs⟩)
  apply (h _ hs).IsSeparatedFor.ext
  rintro V i hi
  dsimp at hi
  erw [← functor_to_types.naturality, ← functor_to_types.naturality]
  exact (congr_fun (congr_app e <| op V) ⟨_, hi⟩ : _)
#align category_theory.grothendieck_topology.subpresheaf.to_sheafify_lift_unique CategoryTheory.GrothendieckTopology.Subpresheaf.to_sheafify_lift_unique

theorem Subpresheaf.sheafify_le (h : G ≤ G') (hF : Presieve.IsSheaf J F)
    (hG' : Presieve.IsSheaf J G'.toPresheaf) : G.sheafify J ≤ G' :=
  by
  intro U x hx
  convert((G.sheafify_lift (subpresheaf.hom_of_le h) hG').app U ⟨x, hx⟩).2
  apply (hF _ hx).IsSeparatedFor.ext
  intro V i hi
  have :=
    congr_arg (fun f : G.to_presheaf ⟶ G'.to_presheaf => (nat_trans.app f (op V) ⟨_, hi⟩).1)
      (G.to_sheafify_lift (subpresheaf.hom_of_le h) hG')
  convert this.symm
  erw [← subpresheaf.nat_trans_naturality]
  rfl
#align category_theory.grothendieck_topology.subpresheaf.sheafify_le CategoryTheory.GrothendieckTopology.Subpresheaf.sheafify_le

omit J

section Image

/-- The image presheaf of a morphism, whose components are the set-theoretic images. -/
@[simps]
def imagePresheaf (f : F' ⟶ F) : Subpresheaf F
    where
  obj U := Set.range (f.app U)
  map U V i := by
    rintro _ ⟨x, rfl⟩
    have := elementwise_of f.naturality
    exact ⟨_, this i x⟩
#align category_theory.grothendieck_topology.image_presheaf CategoryTheory.GrothendieckTopology.imagePresheaf

@[simp]
theorem top_subpresheaf_obj (U) : (⊤ : Subpresheaf F).obj U = ⊤ :=
  rfl
#align category_theory.grothendieck_topology.top_subpresheaf_obj CategoryTheory.GrothendieckTopology.top_subpresheaf_obj

@[simp]
theorem imagePresheaf_id : imagePresheaf (𝟙 F) = ⊤ :=
  by
  ext
  simp
#align category_theory.grothendieck_topology.image_presheaf_id CategoryTheory.GrothendieckTopology.imagePresheaf_id

/-- A morphism factors through the image presheaf. -/
@[simps]
def toImagePresheaf (f : F' ⟶ F) : F' ⟶ (imagePresheaf f).toPresheaf :=
  (imagePresheaf f).lift f fun U x => Set.mem_range_self _
#align category_theory.grothendieck_topology.to_image_presheaf CategoryTheory.GrothendieckTopology.toImagePresheaf

variable (J)

/-- A morphism factors through the sheafification of the image presheaf. -/
@[simps]
def toImagePresheafSheafify (f : F' ⟶ F) : F' ⟶ ((imagePresheaf f).sheafify J).toPresheaf :=
  toImagePresheaf f ≫ Subpresheaf.homOfLe ((imagePresheaf f).le_sheafify J)
#align category_theory.grothendieck_topology.to_image_presheaf_sheafify CategoryTheory.GrothendieckTopology.toImagePresheafSheafify

variable {J}

@[simp, reassoc.1]
theorem toImagePresheaf_ι (f : F' ⟶ F) : toImagePresheaf f ≫ (imagePresheaf f).ι = f :=
  (imagePresheaf f).lift_ι _ _
#align category_theory.grothendieck_topology.to_image_presheaf_ι CategoryTheory.GrothendieckTopology.toImagePresheaf_ι

theorem imagePresheaf_comp_le (f₁ : F ⟶ F') (f₂ : F' ⟶ F'') :
    imagePresheaf (f₁ ≫ f₂) ≤ imagePresheaf f₂ := fun U x hx => ⟨f₁.app U hx.some, hx.choose_spec⟩
#align category_theory.grothendieck_topology.image_presheaf_comp_le CategoryTheory.GrothendieckTopology.imagePresheaf_comp_le

instance {F F' : Cᵒᵖ ⥤ Type max v w} (f : F ⟶ F') [hf : Mono f] : IsIso (toImagePresheaf f) :=
  by
  apply (config := { instances := false }) nat_iso.is_iso_of_is_iso_app
  intro X
  rw [is_iso_iff_bijective]
  constructor
  · intro x y e
    have := (nat_trans.mono_iff_mono_app _ _).mp hf X
    rw [mono_iff_injective] at this
    exact this (congr_arg Subtype.val e : _)
  · rintro ⟨_, ⟨x, rfl⟩⟩
    exact ⟨x, rfl⟩

/-- The image sheaf of a morphism between sheaves, defined to be the sheafification of
`image_presheaf`. -/
@[simps]
def imageSheaf {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Sheaf J (Type w) :=
  ⟨((imagePresheaf f.1).sheafify J).toPresheaf,
    by
    rw [is_sheaf_iff_is_sheaf_of_type]
    apply subpresheaf.sheafify_is_sheaf
    rw [← is_sheaf_iff_is_sheaf_of_type]
    exact F'.2⟩
#align category_theory.grothendieck_topology.image_sheaf CategoryTheory.GrothendieckTopology.imageSheaf

/-- A morphism factors through the image sheaf. -/
@[simps]
def toImageSheaf {F F' : Sheaf J (Type w)} (f : F ⟶ F') : F ⟶ imageSheaf f :=
  ⟨toImagePresheafSheafify J f.1⟩
#align category_theory.grothendieck_topology.to_image_sheaf CategoryTheory.GrothendieckTopology.toImageSheaf

/-- The inclusion of the image sheaf to the target. -/
@[simps]
def imageSheafι {F F' : Sheaf J (Type w)} (f : F ⟶ F') : imageSheaf f ⟶ F' :=
  ⟨Subpresheaf.ι _⟩
#align category_theory.grothendieck_topology.image_sheaf_ι CategoryTheory.GrothendieckTopology.imageSheafι

@[simp, reassoc.1]
theorem toImageSheaf_ι {F F' : Sheaf J (Type w)} (f : F ⟶ F') :
    toImageSheaf f ≫ imageSheafι f = f := by
  ext1
  simp [to_image_presheaf_sheafify]
#align category_theory.grothendieck_topology.to_image_sheaf_ι CategoryTheory.GrothendieckTopology.toImageSheaf_ι

instance {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Mono (imageSheafι f) :=
  (sheafToPresheaf J _).mono_of_mono_map
    (by
      dsimp
      infer_instance)

instance {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Epi (toImageSheaf f) :=
  by
  refine' ⟨fun G' g₁ g₂ e => _⟩
  ext (U⟨s, hx⟩)
  apply ((is_sheaf_iff_is_sheaf_of_type J _).mp G'.2 _ hx).IsSeparatedFor.ext
  rintro V i ⟨y, e'⟩
  change (g₁.val.app _ ≫ G'.val.map _) _ = (g₂.val.app _ ≫ G'.val.map _) _
  rw [← nat_trans.naturality, ← nat_trans.naturality]
  have E : (to_image_sheaf f).val.app (op V) y = (image_sheaf f).val.map i.op ⟨s, hx⟩ :=
    Subtype.ext e'
  have := congr_arg (fun f : F ⟶ G' => (Sheaf.hom.val f).app _ y) e
  dsimp at this⊢
  convert this <;> exact E.symm

/-- The mono factorization given by `image_sheaf` for a morphism. -/
def imageMonoFactorization {F F' : Sheaf J (Type w)} (f : F ⟶ F') : Limits.MonoFactorisation f
    where
  i := imageSheaf f
  m := imageSheafι f
  e := toImageSheaf f
#align category_theory.grothendieck_topology.image_mono_factorization CategoryTheory.GrothendieckTopology.imageMonoFactorization

/-- The mono factorization given by `image_sheaf` for a morphism is an image. -/
noncomputable def imageFactorization {F F' : Sheaf J (Type max v u)} (f : F ⟶ F') :
    Limits.ImageFactorisation f where
  f := imageMonoFactorization f
  IsImage :=
    { lift := fun I =>
        by
        haveI := (Sheaf.hom.mono_iff_presheaf_mono J _ _).mp I.m_mono
        refine' ⟨subpresheaf.hom_of_le _ ≫ inv (to_image_presheaf I.m.1)⟩
        apply subpresheaf.sheafify_le
        · conv_lhs => rw [← I.fac]
          apply image_presheaf_comp_le
        · rw [← is_sheaf_iff_is_sheaf_of_type]
          exact F'.2
        · apply presieve.is_sheaf_iso J (as_iso <| to_image_presheaf I.m.1)
          rw [← is_sheaf_iff_is_sheaf_of_type]
          exact I.I.2
      lift_fac := fun I => by
        ext1
        dsimp [image_mono_factorization]
        generalize_proofs h
        rw [← subpresheaf.hom_of_le_ι h, category.assoc]
        congr 1
        rw [is_iso.inv_comp_eq, to_image_presheaf_ι] }
#align category_theory.grothendieck_topology.image_factorization CategoryTheory.GrothendieckTopology.imageFactorization

instance : Limits.HasImages (Sheaf J (Type max v u)) :=
  ⟨fun _ _ f => ⟨⟨imageFactorization f⟩⟩⟩

end Image

end CategoryTheory.GrothendieckTopology