{-# OPTIONS --without-K --safe #-}

module Definition.Conversion.Transitivity where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.Conversion
open import Definition.Conversion.Soundness
open import Definition.Conversion.Stability
open import Definition.Conversion.Whnf
open import Definition.Conversion.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Lift
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Injectivity
import Definition.Typed.Consequences.Inequality as WF
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.NeTypeEq
open import Definition.Typed.Consequences.SucCong
open import Definition.Typed.Consequences.Inversion
open import Definition.Typed.Consequences.Reduction

open import Tools.Nat
open import Tools.Product
open import Tools.Empty
import Tools.PropositionalEquality as PE

mutual
  -- Transitivity of algorithmic equality of neutrals.
  trans~↑ : ∀ {t u v A B Γ}
         → Γ ⊢ t ~ u ↑ A
         → Γ ⊢ u ~ v ↑ B
         → Γ ⊢ t ~ v ↑ A
         × Γ ⊢ A ≡ B
  trans~↑ (var-refl x₁ x≡y) (var-refl x₂ x≡y₁) =
    var-refl x₁ (PE.trans x≡y x≡y₁)
    , neTypeEq (var _) x₁
               (PE.subst (λ x → _ ⊢ var x ∷ _) (PE.sym x≡y)
                         x₂)
  trans~↑ (app-cong t~u a<>b) (app-cong u~v b<>c) =
    let t~v , ΠFG≡ΠF′G′ = trans~↓ t~u u~v
        F≡F₁ , G≡G₁ = injectivity ΠFG≡ΠF′G′
        a<>c = transConv↑Term F≡F₁ a<>b b<>c
    in  app-cong t~v a<>c , substTypeEq G≡G₁ (soundnessConv↑Term a<>b)
  trans~↑ (fst-cong t~u) (fst-cong u~v) =
    let t~v , ΣFG≡ΣF′G′ = trans~↓ t~u u~v
        F≡F′ , _ = Σ-injectivity ΣFG≡ΣF′G′
    in  fst-cong t~v , F≡F′
  trans~↑ (snd-cong t~u) (snd-cong u~v) =
    let t~v , ΣFG≡ΣF′G′ = trans~↓ t~u u~v
        F≡F′ , G≡G′ = Σ-injectivity ΣFG≡ΣF′G′
    in  snd-cong t~v , substTypeEq G≡G′ (soundness~↑ (fst-cong t~u))
  trans~↑ (natrec-cong A<>B a₀<>b₀ aₛ<>bₛ t~u) (natrec-cong B<>C b₀<>c₀ bₛ<>cₛ u~v) =
    let ⊢Γ = wf (proj₁ (syntacticEqTerm (soundness~↓ t~u)))
        A≡B = soundnessConv↑ A<>B
        F[0]≡F₁[0] = substTypeEq A≡B (refl (zeroⱼ ⊢Γ))
        ΠℕFs≡ΠℕF₁s = sucCong A≡B
        A<>C = transConv↑ A<>B B<>C
        a₀<>c₀ = transConv↑Term F[0]≡F₁[0] a₀<>b₀ b₀<>c₀
        aₛ<>cₛ = transConv↑Term ΠℕFs≡ΠℕF₁s aₛ<>bₛ bₛ<>cₛ
        t~v , _ = trans~↓ t~u u~v
    in  natrec-cong A<>C a₀<>c₀ aₛ<>cₛ t~v
    ,   substTypeEq A≡B (soundness~↓ t~u)
  trans~↑ (Emptyrec-cong A<>B t~u) (Emptyrec-cong B<>C u~v) =
    let A≡B = soundnessConv↑ A<>B
        A<>C = transConv↑ A<>B B<>C
        t~v , _ = trans~↓  t~u u~v
    in  Emptyrec-cong A<>C t~v , A≡B

  -- Transitivity of algorithmic equality of neutrals with types in WHNF.
  trans~↓ : ∀ {t u v A B Γ}
          → Γ ⊢ t ~ u ↓ A
          → Γ ⊢ u ~ v ↓ B
          → Γ ⊢ t ~ v ↓ A
          × Γ ⊢ A ≡ B
  trans~↓ ([~] A₁ D whnfA k~l) ([~] A₂ D₁ whnfA₁ k~l₁) =
    let t~v , A≡B = trans~↑ k~l k~l₁
    in  [~] A₁ D whnfA t~v
    ,   trans (sym (subset* D))
              (trans A≡B
                     (subset* D₁))

  -- Transitivity of algorithmic equality of types.
  transConv↑ : ∀ {A B C Γ}
            → Γ ⊢ A [conv↑] B
            → Γ ⊢ B [conv↑] C
            → Γ ⊢ A [conv↑] C
  transConv↑ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′)
             ([↑] A″ B″ D₁ D″ whnfA″ whnfB″ A′<>B″) =
    [↑] A′ B″ D D″ whnfA′ whnfB″
        (transConv↓ A′<>B′
                    (PE.subst (λ x → _ ⊢ x [conv↓] B″)
                              (whrDet* (D₁ , whnfA″)
                                        (D′ , whnfB′))
                              A′<>B″))
  transConv↑′ : ∀ {A B C Γ Δ}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ A [conv↑] B
              → Δ ⊢ B [conv↑] C
              → Γ ⊢ A [conv↑] C
  transConv↑′ Γ≡Δ aConvB bConvC =
    transConv↑ aConvB (stabilityConv↑ (symConEq Γ≡Δ) bConvC)

  -- Transitivity of algorithmic equality of types in WHNF.
  transConv↓ : ∀ {A B C Γ}
            → Γ ⊢ A [conv↓] B
            → Γ ⊢ B [conv↓] C
            → Γ ⊢ A [conv↓] C
  transConv↓ (U-refl x) (U-refl x₁) = U-refl x
  transConv↓ (ℕ-refl x) (ℕ-refl x₁) = ℕ-refl x
  transConv↓ (Empty-refl x) (Empty-refl x₁) = Empty-refl x
  transConv↓ (Unit-refl x) (Unit-refl x₁) = Unit-refl x
  transConv↓ (ne x) (ne x₁) =
    let A~C , U≡U = trans~↓ x x₁
    in  ne A~C
  transConv↓ (Π-cong x x₁ x₂) (Π-cong x₃ x₄ x₅) =
    Π-cong x (transConv↑ x₁ x₄) (transConv↑′ (reflConEq (wf x) ∙ soundnessConv↑ x₁) x₂ x₅)
  transConv↓ (Σ-cong x x₁ x₂) (Σ-cong x₃ x₄ x₅) =
    Σ-cong x (transConv↑ x₁ x₄) (transConv↑′ (reflConEq (wf x) ∙ soundnessConv↑ x₁) x₂ x₅)
  -- Refutable cases
  transConv↓ (U-refl x) (ne ([~] A D whnfB ()))
  transConv↓ (ℕ-refl x) (ne ([~] A D whnfB ()))
  transConv↓ (Empty-refl x) (ne ([~] A D whnfB ()))
  transConv↓ (Π-cong x x₁ x₂) (ne ([~] A D whnfB ()))
  transConv↓ (Σ-cong x x₁ x₂) (ne ([~] A D whnfB ()))
  transConv↓ (ne ([~] A₁ D whnfB ())) (U-refl x₁)
  transConv↓ (ne ([~] A₁ D whnfB ())) (ℕ-refl x₁)
  transConv↓ (ne ([~] A₁ D whnfB ())) (Empty-refl x₁)
  transConv↓ (ne ([~] A₁ D whnfB ())) (Π-cong x₁ x₂ x₃)
  transConv↓ (ne ([~] A₁ D whnfB ())) (Σ-cong x₁ x₂ x₃)

  -- Transitivity of algorithmic equality of terms.
  transConv↑Term : ∀ {t u v A B Γ}
                → Γ ⊢ A ≡ B
                → Γ ⊢ t [conv↑] u ∷ A
                → Γ ⊢ u [conv↑] v ∷ B
                → Γ ⊢ t [conv↑] v ∷ A
  transConv↑Term A≡B ([↑]ₜ B₁ t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u)
                 ([↑]ₜ B₂ t″ u″ D₁ d₁ d″ whnfB₁ whnft″ whnfu″ t<>u₁) =
    let B₁≡B₂ = trans (sym (subset* D))
                      (trans A≡B
                             (subset* D₁))
        d₁″ = conv* d″ (sym B₁≡B₂)
        d₁′  = conv* d′ B₁≡B₂
    in  [↑]ₜ B₁ t′ u″ D d d₁″ whnfB whnft′ whnfu″
             (transConv↓Term B₁≡B₂ t<>u
                             (PE.subst (λ x → _ ⊢ x [conv↓] u″ ∷ B₂)
                                       (whrDet*Term (d₁ , whnft″)
                                                    (d₁′ , whnfu′))
                                       t<>u₁))

  transConv↑Term′ : ∀ {t u v A B Γ Δ}
                  → ⊢ Γ ≡ Δ
                  → Γ ⊢ A ≡ B
                  → Γ ⊢ t [conv↑] u ∷ A
                  → Δ ⊢ u [conv↑] v ∷ B
                  → Γ ⊢ t [conv↑] v ∷ A
  transConv↑Term′ Γ≡Δ A≡B tConvU uConvV =
    transConv↑Term A≡B tConvU (stabilityConv↑Term (symConEq Γ≡Δ) uConvV)

  -- Transitivity of algorithmic equality of terms in WHNF.
  transConv↓Term : ∀ {t u v A B Γ}
                → Γ ⊢ A ≡ B
                → Γ ⊢ t [conv↓] u ∷ A
                → Γ ⊢ u [conv↓] v ∷ B
                → Γ ⊢ t [conv↓] v ∷ A
  transConv↓Term A≡B (ℕ-ins x) (ℕ-ins x₁) =
    ℕ-ins (proj₁ (trans~↓ x x₁))
  transConv↓Term A≡B (Empty-ins x) (Empty-ins x₁) =
    Empty-ins (proj₁ (trans~↓ x x₁))
  transConv↓Term A≡B (Unit-ins t~u) uConvV =
    let _ , [t] , _ = syntacticEqTerm (soundness~↓ t~u)
        _ , tNe , _ = ne~↓ t~u
        _ , _ , [v] = syntacticEqTerm (soundnessConv↓Term uConvV)
        [v] = conv [v] (sym A≡B)
        _ , _ , vWhnf = whnfConv↓Term uConvV
    in  η-unit [t] [v] (ne tNe) vWhnf
  transConv↓Term A≡B (ne-ins t u x x₁) (ne-ins t′ u′ x₂ x₃) =
    ne-ins t (conv u′ (sym A≡B)) x
           (proj₁ (trans~↓ x₁ x₃))
  transConv↓Term A≡B (univ x x₁ x₂) (univ x₃ x₄ x₅) =
    univ x x₄ (transConv↓ x₂ x₅)
  transConv↓Term A≡B (zero-refl x) conv↓ =
    convConv↓Term (reflConEq x) (sym A≡B) ℕₙ conv↓
  transConv↓Term A≡B conv↓ (zero-refl _) = conv↓
  transConv↓Term A≡B (suc-cong x) (suc-cong x₁) =
    suc-cong (transConv↑Term A≡B x x₁)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (η-eq x₅ x₆ y₂ y₃ x₇) =
    let F₁≡F , G₁≡G = injectivity A≡B
    in  η-eq x₁ (conv x₆ (sym A≡B))
             y y₃ (transConv↑Term′ (reflConEq (wfEq F₁≡F) ∙ F₁≡F) G₁≡G x₃ x₇)
  transConv↓Term A≡B (Σ-η ⊢p ⊢r pProd rProd fstConv sndConv)
                     (Σ-η ⊢r′ ⊢q _ qProd fstConv′ sndConv′) =
    let F≡ , G≡ = Σ-injectivity A≡B
        Gfst≡ = substTypeEq G≡ (soundnessConv↑Term fstConv)
    in  Σ-η ⊢p (conv ⊢q (sym A≡B)) pProd qProd
            (transConv↑Term F≡ fstConv fstConv′)
            (transConv↑Term Gfst≡ sndConv sndConv′)
  transConv↓Term A≡B (η-unit [t] [u] tUnit uUnit) uConvV =
    let _ , _ , [v] = syntacticEqTerm (soundnessConv↓Term uConvV)
        [v] = conv [v] (sym A≡B)
        _ , _ , vWhnf = whnfConv↓Term uConvV
    in  η-unit [t] [v] tUnit vWhnf

  -- Refutable cases
  transConv↓Term A≡B (ℕ-ins x) (ne-ins t u x₂ x₃) = ⊥-elim (WF.ℕ≢ne x₂ A≡B)
  transConv↓Term A≡B (ℕ-ins x) (univ x₂ x₃ x₄) = ⊥-elim (WF.U≢ℕ (sym A≡B))
  transConv↓Term A≡B (ℕ-ins x) (Empty-ins x₁) = ⊥-elim (WF.ℕ≢Emptyⱼ A≡B)
  transConv↓Term A≡B (ℕ-ins x) (Unit-ins x₁) = ⊥-elim (WF.ℕ≢Unitⱼ A≡B)
  transConv↓Term A≡B (ℕ-ins ([~] A D whnfB ())) (suc-cong x₂)
  transConv↓Term A≡B (ℕ-ins x) (η-eq x₃ x₄ y y₁ x₅) = ⊥-elim (WF.ℕ≢Π A≡B)
  transConv↓Term A≡B (ℕ-ins x₁) (Σ-η x₂ x₃ x₄ x₅ x₆ x₇) = ⊥-elim (WF.ℕ≢Σ A≡B)
  transConv↓Term A≡B (ℕ-ins x) (η-unit _ _ _ _) = ⊥-elim (WF.ℕ≢Unitⱼ A≡B)
  transConv↓Term A≡B (Empty-ins x) (ne-ins t u x₂ x₃) = ⊥-elim (WF.Empty≢neⱼ x₂ A≡B)
  transConv↓Term A≡B (Empty-ins x) (univ x₂ x₃ x₄) = ⊥-elim (WF.U≢Emptyⱼ (sym A≡B))
  transConv↓Term A≡B (Empty-ins x₁) (ℕ-ins x) = ⊥-elim (WF.ℕ≢Emptyⱼ (sym A≡B))
  transConv↓Term A≡B (Empty-ins x₁) (Unit-ins x) = ⊥-elim (WF.Empty≢Unitⱼ A≡B)
  transConv↓Term A≡B (Empty-ins ([~] A D whnfB ())) (suc-cong x₂)
  transConv↓Term A≡B (Empty-ins x) (η-eq x₃ x₄ y y₁ x₅) = ⊥-elim (WF.Empty≢Πⱼ A≡B)
  transConv↓Term A≡B (Empty-ins x₁) (Σ-η x₂ x₃ x₄ x₅ x₆ x₇) = ⊥-elim (WF.Empty≢Σⱼ A≡B)
  transConv↓Term A≡B (Empty-ins x₁) (η-unit _ _ _ _) = ⊥-elim (WF.Empty≢Unitⱼ A≡B)
  transConv↓Term A≡B (ne-ins t u x x₁) (ℕ-ins x₂) = ⊥-elim (WF.ℕ≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (Empty-ins x₂) = ⊥-elim (WF.Empty≢neⱼ x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (Unit-ins x₂) = ⊥-elim (WF.Unit≢neⱼ x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (univ x₃ x₄ x₅) = ⊥-elim (WF.U≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x ([~] A D whnfB ())) (suc-cong x₃)
  transConv↓Term A≡B (ne-ins t u x x₁) (η-eq x₄ x₅ y y₁ x₆) = ⊥-elim (WF.Π≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (Σ-η x₅ x₆ x₇ x₈ x₉ x₁₀) = ⊥-elim (WF.Σ≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (η-unit _ _ _ _) = ⊥-elim (WF.Unit≢neⱼ x (sym A≡B))
  transConv↓Term A≡B (univ x x₁ x₂) (ℕ-ins x₃) = ⊥-elim (WF.U≢ℕ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (Empty-ins x₃) = ⊥-elim (WF.U≢Emptyⱼ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (Unit-ins x₃) = ⊥-elim (WF.U≢Unitⱼ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (ne-ins t u x₃ x₄) = ⊥-elim (WF.U≢ne x₃ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (suc-cong x₃) = ⊥-elim (WF.U≢ℕ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (η-eq x₄ x₅ y y₁ x₆) = ⊥-elim (WF.U≢Π A≡B)
  transConv↓Term A≡B (univ x₁ x₂ x₃) (Σ-η x₄ x₅ x₆ x₇ x₈ x₉) = ⊥-elim (WF.U≢Σ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (η-unit _ _ _ _) = ⊥-elim (WF.U≢Unitⱼ A≡B)
  transConv↓Term A≡B (suc-cong x) (ℕ-ins ([~] A D whnfB ()))
  transConv↓Term A≡B (suc-cong x) (Empty-ins ([~] A D whnfB ()))
  transConv↓Term A≡B (suc-cong x) (ne-ins t u x₁ ([~] A D whnfB ()))
  transConv↓Term A≡B (suc-cong x) (univ x₁ x₂ x₃) = ⊥-elim (WF.U≢ℕ (sym A≡B))
  transConv↓Term A≡B (suc-cong x) (η-eq x₂ x₃ y y₁ x₄) = ⊥-elim (WF.ℕ≢Π A≡B)
  transConv↓Term A≡B (suc-cong x₁) (Σ-η x₂ x₃ x₄ x₅ x₆ x₇) = ⊥-elim (WF.ℕ≢Σ A≡B)
  transConv↓Term A≡B (suc-cong x) (η-unit _ _ _ _) = ⊥-elim (WF.ℕ≢Unitⱼ A≡B)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (ℕ-ins x₄) = ⊥-elim (WF.ℕ≢Π (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (Empty-ins x₄) = ⊥-elim (WF.Empty≢Πⱼ (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (Unit-ins _) = ⊥-elim (WF.Unit≢Πⱼ (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (ne-ins t u x₄ x₅) = ⊥-elim (WF.Π≢ne x₄ A≡B)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (univ x₄ x₅ x₆) = ⊥-elim (WF.U≢Π (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (suc-cong x₄) = ⊥-elim (WF.ℕ≢Π (sym A≡B))
  transConv↓Term A≡B (η-eq x₂ x₃ x₄ x₅ x₆) (Σ-η x₇ x₈ x₉ x₁₀ x₁₁ x₁₂) = ⊥-elim (WF.Π≢Σ A≡B)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (η-unit _ _ _ _) = ⊥-elim (WF.Unit≢Πⱼ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (ℕ-ins x₇) = ⊥-elim (WF.ℕ≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (Empty-ins x₇) = ⊥-elim (WF.Empty≢Σⱼ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (Unit-ins x₇) = ⊥-elim (WF.Unit≢Σⱼ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (ne-ins x₇ x₈ x₉ x₁₀) = ⊥-elim (WF.Σ≢ne x₉ A≡B)
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (univ x₇ x₈ x₉) = ⊥-elim (WF.U≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (suc-cong x₇) = ⊥-elim (WF.ℕ≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (η-eq x₈ x₉ x₁₀ x₁₁ x₁₂) = ⊥-elim (WF.Π≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (η-unit x₇ x₈ x₉ x₁₀) = ⊥-elim (WF.Unit≢Σⱼ (sym A≡B))

-- Transitivity of algorithmic equality of types of the same context.
transConv : ∀ {A B C Γ}
          → Γ ⊢ A [conv↑] B
          → Γ ⊢ B [conv↑] C
          → Γ ⊢ A [conv↑] C
transConv A<>B B<>C = transConv↑ A<>B B<>C

-- Transitivity of algorithmic equality of terms of the same context.
transConvTerm : ∀ {t u v A Γ}
              → Γ ⊢ t [conv↑] u ∷ A
              → Γ ⊢ u [conv↑] v ∷ A
              → Γ ⊢ t [conv↑] v ∷ A
transConvTerm t<>u u<>v =
  let t≡u = soundnessConv↑Term t<>u
      ⊢A , _ , _ = syntacticEqTerm t≡u
  in  transConv↑Term (refl ⊢A) t<>u u<>v


open import cedille-types
import spans
open import ctxt
import cedille-options
open import general-util

module type-inf
  (options : cedille-options.options)
  {mF : Set → Set}
  ⦃ _ : monad mF ⦄
  (check-term : ctxt → ex-tm → (T? : maybe type) →
                spans.spanM options {mF} (spans.check-ret options {mF} T? term))
  (check-type : ctxt → ex-tp → (k? : maybe kind) →
                spans.spanM options {mF} (spans.check-ret options {mF} k? type))
  where

open import spans options {mF}
open import rename
open import syntax-util
open import type-util
open import meta-vars options {mF}
open import resugar
open import subst
open import conversion
open import free-vars
open import constants

record spine-data : Set where
  constructor mk-spine-data
  field
    spine-mvars : meta-vars
    spine-type : decortype
    spine-locale : ℕ
    spine-elab : meta-vars → term

check-term-spine-elim : ctxt → spine-data → term × type
check-term-spine-elim Γ (mk-spine-data Xs dt locl f~) =
  f~ Xs , meta-vars-subst-type' ff Γ Xs (decortype-to-type dt)
--  elim-pair (maybe-else' (meta-vars-to-args Xs) ([] , Hole pi-gen) f~) recompose-apps ,
--  meta-vars-subst-type' ff Γ Xs (decortype-to-type dt)

check-term-spine : ctxt → ex-tm → (m : prototype) → 𝔹 → spanM (maybe spine-data)

check-term-spine-return : meta-vars → decortype → ℕ → (meta-vars → term) → spanM (maybe spine-data)
check-term-spine-return Xs dt locl f~ = return (just (mk-spine-data Xs dt locl f~))

-- a flag indicating how aggresively we should be unfolding during matching.
-- "both" is the backtracking flag. We will attempt "both" matches, which means
-- first matching without unfolding, then if that fails unfolding the type once
-- and continue matching the subexpresions with "both"
data match-unfolding-state : Set where
  match-unfolding-both match-unfolding-approx match-unfolding-hnf : match-unfolding-state

-- main matching definitions
-- --------------------------------------------------

-- NOTE: these functions don't actually ever emit spans
match-types : ctxt → meta-vars → local-vars → match-unfolding-state → (tpₓ tp : type) → spanM $ match-error-t meta-vars
match-kinds : ctxt → meta-vars → local-vars → match-unfolding-state → (kₓ k : kind) → spanM $ match-error-t meta-vars
match-tpkds : ctxt → meta-vars → local-vars → match-unfolding-state → (tkₓ tk : tpkd) → spanM $ match-error-t meta-vars

record match-prototype-data : Set where
  constructor mk-match-prototype-data
  field
    match-proto-mvars : meta-vars
    match-proto-dectp : decortype
    match-proto-error : 𝔹
open match-prototype-data
match-prototype : ctxt → (Xs : meta-vars) (is-hnf : 𝔹) (tp : type) (pt : prototype) → spanM match-prototype-data

-- substitutions used during matching
-- --------------------------------------------------

-- These have to be in the spanM monad because substitution can unlock a `stuck`
-- decoration, causing another round of prototype matching (which invokes type matching)

substh-decortype : ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → decortype → spanM decortype
substh-decortype Γ ρ σ (decor-type tp) = return $ decor-type (substh Γ ρ σ tp)
substh-decortype Γ ρ σ (decor-arrow e? dom cod) =
  substh-decortype Γ ρ σ cod
  >>= λ cod → return $ decor-arrow e? (substh Γ ρ σ dom) cod
substh-decortype Γ ρ σ (decor-decor e? x tk sol dt) =
  let x' = subst-rename-var-if Γ ρ x σ (decortype-to-type dt)
      Γ' = ctxt-var-decl x' Γ
      ρ' = renamectxt-insert ρ x x'
  in substh-decortype Γ' ρ' σ dt
  >>= λ dt' → return $ decor-decor e? x' (substh Γ ρ σ -tk tk) (substh-meta-var-sort Γ ρ σ sol) dt'
substh-decortype Γ ρ σ (decor-stuck tp pt) =
  match-prototype Γ meta-vars-empty ff (substh Γ ρ σ tp) pt
  -- NOTE: its an invariant that if you start with no meta-variables,
  -- prototype matching produces no meta-variables as output
  >>= λ ret → return (match-proto-dectp ret)

substh-decortype Γ ρ σ (decor-error tp pt) =
  return $ decor-error (substh Γ ρ σ tp) pt

subst-decortype : {ed : exprd} → ctxt → ⟦ ed ⟧ → var → decortype → spanM decortype
subst-decortype Γ s x dt = substh-decortype Γ empty-renamectxt (trie-single x (, s)) dt

meta-vars-subst-decortype' : (unfold : 𝔹) → ctxt → meta-vars → decortype → spanM decortype
meta-vars-subst-decortype' uf Γ Xs dt =
  substh-decortype Γ empty-renamectxt (meta-vars-get-sub Xs) dt
  >>= λ dt' → return $
    if uf then hnf-decortype Γ unfold-head-elab dt' tt else dt'

meta-vars-subst-decortype : ctxt → meta-vars → decortype → spanM decortype
meta-vars-subst-decortype = meta-vars-subst-decortype' tt

-- unfolding a decorated type to reveal a term / type abstraction
-- --------------------------------------------------

{-# TERMINATING #-}
meta-vars-peel' : ctxt → span-location → meta-vars → decortype → spanM (𝕃 meta-var × decortype)
meta-vars-peel' Γ sl Xs (decor-decor e? x _ (meta-var-tp k mtp) dt) =
  let Y   = meta-var-fresh-tp Xs x sl (k , mtp)
      Xs' = meta-vars-add Xs Y
  in subst-decortype Γ (meta-var-to-type-unsafe Y) x dt
  >>= λ dt' → meta-vars-peel' Γ sl Xs' dt'
  >>= λ ret → let Ys = fst ret ; rdt = snd ret
  in return $ Y :: Ys , rdt
meta-vars-peel' Γ sl Xs dt@(decor-decor e? x _ (meta-var-tm _ _) _) = return $ [] , dt
meta-vars-peel' Γ sl Xs dt@(decor-arrow _ _ _) = return $ [] , dt
-- NOTE: vv The clause below will later generate a type error vv
meta-vars-peel' Γ sl Xs dt@(decor-stuck _ _) = return $ [] , dt
-- NOTE: vv The clause below is an internal error, if reached vv
meta-vars-peel' Γ sl Xs dt@(decor-type _) = return $ [] , dt
meta-vars-peel' Γ sl Xs dt@(decor-error _ _) = return $ [] , dt

meta-vars-unfold-tmapp' : ctxt → span-location → meta-vars → decortype → spanM (𝕃 meta-var × is-tmabsd?)
meta-vars-unfold-tmapp' Γ sl Xs dt =
  meta-vars-subst-decortype Γ Xs dt
  >>= λ dt' → meta-vars-peel' Γ sl Xs dt'
  >>= λ where
    (Ys , dt'@(decor-arrow e? dom cod)) →
      return $ Ys , yes-tmabsd dt' e? ignored-var dom ff cod
    (Ys , dt'@(decor-decor e? x _ (meta-var-tm dom _) cod)) →
      return $ Ys , yes-tmabsd dt' e? x dom (is-free-in x (decortype-to-type cod)) cod
    (Ys , dt@(decor-decor _ _ _ (meta-var-tp _ _) _)) →
      return $ Ys , not-tmabsd dt
-- NOTE: vv this is a type error vv
    (Ys , dt@(decor-stuck _ _)) →
      return $ Ys , not-tmabsd dt
-- NOTE: vv this is an internal error, if reached vv
    (Ys , dt@(decor-type _)) →
      return $ Ys , not-tmabsd dt
    (Ys , dt@(decor-error _ _)) →
      return $ Ys , not-tmabsd dt

meta-vars-unfold-tpapp' : ctxt → meta-vars → decortype → spanM is-tpabsd?
meta-vars-unfold-tpapp' Γ Xs dt =
  meta-vars-subst-decortype Γ Xs dt
  >>= λ where
   (dt″@(decor-decor e? x _ (meta-var-tp k mtp) dt')) →
    return $ yes-tpabsd dt″ e? x k (flip maybe-map mtp meta-var-sol.sol) dt'
   (dt″@(decor-decor _ _ _ (meta-var-tm _ _) _)) →
    return $ not-tpabsd dt″
   (dt″@(decor-arrow _ _ _)) → return $ not-tpabsd dt″
   (dt″@(decor-stuck _ _)) → return $ not-tpabsd dt″
   (dt″@(decor-type _)) → return $ not-tpabsd dt″
   (dt″@(decor-error _ _)) → return $ not-tpabsd dt″

-- errors
-- --------------------------------------------------

-- general type errors for applications
module check-term-app-tm-errors
  {A : Set} (t₁ t₂ : ex-tm) (htp : type) (Xs : meta-vars) (is-locale : 𝔹) (m : checking-mode) (Γ : ctxt)
  where

  inapplicable : erased? → decortype → prototype → spanM (maybe A)
  inapplicable e? dt pt =
    spanM-add
      (App-span is-locale (term-start-pos t₁) (term-end-pos t₂) m
        (head-type Γ (meta-vars-subst-type Γ Xs htp)
          -- :: decortype-data Γ dt
          -- :: prototype-data Γ pt
          :: meta-vars-data-all Γ Xs)
        (just $ "The type of the head does not allow the head to be applied to "
         ^ h e? ^ " argument"))
    >> return nothing
    where h : erased? → string
          h Erased = "an erased term"
          h NotErased = "a term"

  bad-erasure : erased? → spanM (maybe A)
  bad-erasure e? =
    spanM-add
      (App-span is-locale (term-start-pos t₁) (term-end-pos t₂) m
        (head-type Γ (meta-vars-subst-type Γ Xs htp) :: meta-vars-data-all Γ Xs)
        (just (msg e?)))
    >> return nothing
    where
    msg : erased? → string
    msg Erased =
      "The type computed for the head requires an explicit (non-erased) argument,"
      ^ " but the application is marked as erased"
    msg NotErased =
      "The type computed for the head requires an implicit (erased) argument,"
      ^ " but the application is marked as not erased"

  unmatchable : (tpₓ tp : type) (msg : string) → 𝕃 tagged-val → spanM (maybe A)
  unmatchable tpₓ tp msg tvs =
    spanM-add
      (App-span is-locale (term-start-pos t₁) (term-end-pos t₂) m
        (arg-exp-type Γ tpₓ :: arg-type Γ tp :: tvs ++ meta-vars-data-all Γ Xs)
        (just msg))
    >> return nothing

  unsolved-meta-vars : type → 𝕃 tagged-val → spanM (maybe A)
  unsolved-meta-vars tp tvs =
    spanM-add
      (App-span tt (term-start-pos t₁) (term-end-pos t₂) m
        (type-data Γ tp :: meta-vars-data-all Γ Xs ++ tvs)
        (just "There are unsolved meta-variables in this maximal application"))
    >> return nothing

module check-term-app-tp-errors
  {A : Set} (t : ex-tm) (tp : ex-tp) (htp : type) (Xs : meta-vars) (m : checking-mode) (Γ : ctxt)
  where

  inapplicable : decortype → spanM (maybe A)
  inapplicable dt =
    spanM-add
      (AppTp-span tt (term-start-pos t) (type-end-pos tp) synthesizing
        (head-type Γ (meta-vars-subst-type Γ Xs htp)
          -- :: decortype-data Γ dt
          :: meta-vars-data-all Γ Xs)
        (just "The type of the head does not allow the head to be applied to a type argument"))
    >> return nothing

  ctai-disagree : (ctai-sol : type) → spanM (maybe A)
  ctai-disagree ctai-sol =
    spanM-add (AppTp-span tt (term-start-pos t) (type-end-pos tp) m
      (head-type Γ (meta-vars-subst-type Γ Xs htp)
        :: contextual-type-argument Γ ctai-sol
        :: meta-vars-data-all Γ Xs)
      (just "The given and contextually inferred type argument differ"))
    >> return nothing

-- meta-variable locality
-- --------------------------------------------------

-- for debugging -- prepend to the tvs returned by check-spine-locality if you're having trouble
private
  locale-tag : ℕ → tagged-val
  locale-tag n = "locale n" , [[ ℕ-to-string n ]] , []

private
  is-locale : (max : 𝔹) → (locl : maybe ℕ) → 𝔹
  is-locale max locl = max || maybe-else' locl ff iszero

check-spine-locality : ctxt → meta-vars → type → (max : 𝔹) → (locl : ℕ)
                       → spanM (maybe (meta-vars × ℕ × 𝔹))
check-spine-locality Γ Xs tp max locl =
  let new-locl  = if iszero locl then num-arrows-in-type Γ tp else locl
      new-Xs    = if iszero locl then meta-vars-empty else Xs
      left-locl = is-locale max (just locl)
  in if left-locl && (~ meta-vars-solved? Xs)
        then return nothing
     else return (just (new-Xs , new-locl , left-locl))

-- main definition
--------------------------------------------------

data check-term-app-ret : Set where
  check-term-app-return : (t~ : term) (Xs : meta-vars) (cod : decortype) (arg-mode : checking-mode) → (tvs : 𝕃 tagged-val) → check-term-app-ret

check-term-app : ctxt → (Xs : meta-vars) (Ys : 𝕃 meta-var) → (t₁ t₂ : ex-tm) → is-tmabsd → 𝔹 → spanM (maybe check-term-app-ret)

check-term-spine Γ t'@(ExApp t₁ e? t₂) pt max =
  -- 1) type the applicand, extending the prototype
    let pt' = proto-arrow e? pt in
    check-term-spine Γ t₁ pt' ff
      on-fail handleApplicandTypeError
  -- 2) make sure the applicand type reveals an arrow (term abstraction)
  >>=m λ ret → let mk-spine-data Xs dt locl fₕ~ = ret in
    -- the meta-vars need to know the span they were introduced in
    let sloc = span-loc $ ctxt.fn Γ in
    -- see if the decorated type of the head `dt` reveals an arrow
    meta-vars-unfold-tmapp' Γ sloc Xs dt
  >>=c λ Ys tm-arrow? →
    return tm-arrow? on-fail (λ _ → genInapplicableError Xs dt pt' locl)
    -- if so, get the (plain, undecorated) type of the head `htp`
  >>=s λ arr → let htp = decortype-to-type ∘ is-tmabsd-dt $ arr in
  -- 3) make sure erasures of the applicand type + syntax of application match
    checkErasuresMatch e? (is-tmabsd-e? arr) htp Xs locl
  -- 4) type the application, filling in missing type arguments with meta-variables
  >>=m λ _ → check-term-app Γ Xs Ys t₁ t₂ arr (islocl locl)
  -- 5) check no unsolved mvars, if the application is maximal (or a locality)
  >>=m λ {(check-term-app-return t₂~ Xs' rtp' arg-mode tvs) →
    let rtp = decortype-to-type rtp' in
    checkLocality Γ Xs' htp rtp max (pred locl) tvs
  >>=m uncurry₂ λ Xs'' locl' is-loc →
  -- 6) generate span
    genAppSpan Γ Xs Xs' Ys pt rtp is-loc tvs
  >> check-term-spine-return Xs'' rtp' locl'
  -- 7) fill in solutions to meta-vars introduced here and return the rest
    λ sols →
      let sols = if max then Xs' else sols
--          num-sols-here = length Ys
--          sols-here = take num-sols-here sols
--          sols-rest = drop num-sols-here sols
--          as = maybe-else' (meta-vars-to-args (meta-vars-from-list sols-here)) [] id
--          tₕ~ = recompose-apps as tₕₓ~
          tₕ~ = foldl (λ X t → maybe-else' (meta-vars-lookup sols (meta-var.name X)) t
                         λ {(meta-var-mk X' (meta-var-tp k T?) _) →
                              maybe-else' T? t (AppTp t ∘ meta-var-sol.sol);
                            (meta-var-mk X' (meta-var-tm T t?) _) →
                              maybe-else' t? t (AppEr t ∘ meta-var-sol.sol)})
                      (fₕ~ sols) Ys
          app = if e? then AppEr else App in
      app tₕ~ t₂~
  }

  where
  mode = prototype-to-checking pt

  expected-type-if-pt : ctxt → prototype → 𝕃 tagged-val
  expected-type-if-pt Γ pt = case pt of λ where
    (proto-maybe mt) → maybe-else [] (λ tp → [ expected-type Γ tp ]) mt
    (proto-arrow _ _) → []

  span-loc : (fn : string) → span-location
  span-loc fn = fn , term-start-pos t₁ , term-end-pos t₂

  islocl : ℕ → 𝔹
  islocl locl = is-locale max (just $ pred locl)

  handleApplicandTypeError : spanM (maybe _)
  handleApplicandTypeError =
      spanM-add (App-span max (term-start-pos t₁) (term-end-pos t₂) mode (expected-type-if-pt Γ pt) nothing)
    >> check-term Γ t₂ nothing
    >>= (const $ return nothing)

  genInapplicableError : meta-vars → decortype → prototype → (locl : ℕ) → spanM (maybe _)
  genInapplicableError Xs dt pt locl =
    check-term-app-tm-errors.inapplicable
      t₁ t₂ (decortype-to-type dt) Xs (islocl locl) mode Γ e? dt (proto-arrow e? pt)

  checkErasuresMatch : (e?₁ e?₂ : erased?) → type → meta-vars → (locl : ℕ) → spanM (maybe ⊤)
  checkErasuresMatch e?₁ e?₂ htp Xs locl =
    if e?₁ xor e?₂
      then check-term-app-tm-errors.bad-erasure t₁ t₂ htp Xs (islocl locl) mode Γ e?₁
    else (return ∘ just $ triv)

  checkLocality : ctxt → meta-vars → (htp rtp : type) → (max : 𝔹) (locl : ℕ) → 𝕃 tagged-val → spanM ∘ maybe $ _
  checkLocality Γ Xs htp rtp max locl tvs =
    check-spine-locality Γ Xs rtp max locl
      on-fail check-term-app-tm-errors.unsolved-meta-vars
        t₁ t₂ htp Xs (islocl locl) mode Γ rtp tvs
    >>=m (return ∘ just)

  genAppSpan : ctxt → (Xs Xs' : meta-vars) → (Ys : 𝕃 meta-var) → prototype → type → (is-locl : 𝔹) → 𝕃 tagged-val → spanM ⊤
  genAppSpan Γ Xs Xs' Ys pt rtp is-loc tvs =
    spanM-add $ elim-pair
      (meta-vars-check-type-mismatch-if (prototype-to-maybe pt) Γ "synthesized" meta-vars-empty rtp)
      λ tvs' → App-span is-loc (term-start-pos t₁) (term-end-pos t₂) mode
        (tvs' ++ meta-vars-intro-data Γ (meta-vars-from-list Ys)
          ++ meta-vars-sol-data Γ Xs Xs' ++ tvs)

check-term-spine Γ t'@(ExAppTp t tp) pt max =
  -- 1) type the applicand `t`
    check-term-spine Γ t pt max
      on-fail handleApplicandTypeError
  -- 1a) Xs: spine meta-variables; dt: decorated type of t ; htp: plain type of `t`
  >>=m λ ret → let mk-spine-data Xs dt locl fₕ~ = ret ; htp = decortype-to-type dt in
  -- 2) make sure it reveals a type abstraction
    meta-vars-unfold-tpapp' Γ Xs dt
     on-fail (λ _ → genInapplicableError Xs htp dt)
  -- 3) ensure the type argument has the expected kind,
  --    but don't compare with the contextually infered type argument (for now)
  >>=s λ ret → let mk-tpabsd dt' e? x k sol rdt = ret in
    check-type Γ tp (just (meta-vars-subst-kind Γ Xs k))
  -- 4) produce the result type of the application
  >>= λ tp~ → subst-decortype-if Γ tp~ Xs x k sol rdt
  >>= λ ret → let Xs = fst ret ; rdt = snd ret ; rtp = decortype-to-type rdt in
  -- 5) generate span data
    genAppTpSpan Γ Xs pt rtp htp
  >> check-term-spine-return Xs rdt locl
  -- 7) fill in solutions to meta-vars introduced here and return the rest
    λ sols → AppTp (fₕ~ sols) tp~
    --(map-snd (λ tₕ~ → AppE tₕ~ (Ttp tp~)) ∘ fₕ~)

  where
  mode = prototype-to-checking pt

  span-loc : ctxt → span-location
  span-loc Γ = (ctxt.fn Γ) , term-start-pos t , type-end-pos tp

  handleApplicandTypeError : spanM ∘ maybe $ spine-data
  handleApplicandTypeError =
      [- AppTp-span tt (term-start-pos t) (type-end-pos tp) synthesizing [] nothing -]
    check-type Γ tp nothing >>= λ _ → return nothing

  genInapplicableError : meta-vars → type → decortype → spanM ∘ maybe $ spine-data
  genInapplicableError Xs htp dt =
    check-term-app-tp-errors.inapplicable t tp htp Xs mode Γ dt

  subst-decortype-if : ctxt → type → meta-vars → var → kind → maybe type → decortype → spanM (meta-vars × decortype)
  subst-decortype-if Γ tp Xs x k sol rdt =
    if ~ is-hole tp
      then subst-decortype Γ tp x rdt >>= (λ res → return (Xs , res))
      else let sol = maybe-map (λ t → mk-meta-var-sol t checking) sol
               Y   = meta-var-fresh-tp Xs x (span-loc Γ) (k , sol)
               Xs' = meta-vars-add Xs Y
           in subst-decortype Γ (meta-var-to-type-unsafe Y) x rdt >>= λ rdt' → return (Xs' , rdt')

  genAppTpSpan : ctxt → meta-vars → prototype → (ret-tp head-tp : type) → spanM ⊤
  genAppTpSpan Γ Xs pt ret-tp head-tp = spanM-add ∘ elim-pair
    -- check for a type mismatch, if there even is an expected type
    (meta-vars-check-type-mismatch-if (prototype-to-maybe pt) Γ "synthesizing" Xs ret-tp) $
    -- then take the generated 𝕃 tagged-val and add to the span
    λ tvs → AppTp-span ff (term-start-pos t) (type-end-pos tp) mode $
              tvs {- ++ [ head-type Γ head-tp ] -}
              ++ meta-vars-data-all Γ Xs
              {- ++ (prototype-data Γ tp :: [ decortype-data Γ dt ]) -}

check-term-spine Γ (ExParens _ t _) pt max =
  check-term-spine Γ t pt max

check-term-spine Γ t pt max =
  check-term Γ t nothing >>=c λ t~ htp →
  let locl = num-arrows-in-type Γ htp
  in match-prototype Γ meta-vars-empty ff htp pt
  -- NOTE: it is an invariant that the variables solved in the
  -- solution set of the fst of this are a subset of the variables given
  -- to match-* -- that is, for (σ , W) = match-prototype ...
  -- we have dom(σ) = ∅
  >>= λ ret → let dt = match-proto-dectp ret in
  check-term-spine-return meta-vars-empty dt locl λ _ → t~

-- check-term-app
-- --------------------------------------------------
--
-- If `dom` has unsolved meta-vars in it, synthesize argument t₂ and try to solve for them.
-- Otherwise, check t₂ against a fully known expected type
check-term-app Γ Xs Zs t₁ t₂ (mk-tmabsd dt e? x dom occurs cod) is-locl =
   let Xs' = meta-vars-add* Xs Zs ; tp = decortype-to-type dt in
  -- 1) either synth or check arg type, depending on available info
  --    checking "exits early", as well as failure
  checkArgWithMetas Xs' tp (genAppRetType Γ)
    on-fail return
  -- 2) match *synthesized* type with expected (partial) type
  >>=s uncurry₂ λ rdt t₂~ atp → match-types Γ Xs' empty-trie match-unfolding-both dom atp
  >>= (handleMatchResult Xs' t₂~ atp tp rdt)

  where
  mode = synthesizing

  genAppRetType : ctxt → term → spanM decortype
  genAppRetType Γ t₂~ = if occurs then subst-decortype Γ t₂~ x cod else return cod

  genAppRetTypeHole : ctxt → spanM decortype
  genAppRetTypeHole Γ = if occurs then subst-decortype Γ (Hole posinfo-gen) x cod else return cod

  checkArgWithMetas : meta-vars → type → (term → spanM decortype) → spanM (maybe check-term-app-ret ∨ (decortype × term × type))
  checkArgWithMetas Xs' tp rdt-f =
    -- check arg against fully known type
    if ~ meta-vars-are-free-in-type Xs' dom
      then (check-term Γ t₂ (just dom) >>= λ t₂~ →
            rdt-f t₂~ >>= λ rdt →
            return (inj₁ (just $ check-term-app-return t₂~ Xs' rdt mode [])))
    -- synthesize type for the argument
      else (check-term Γ t₂ nothing >>=c λ t tp →
            rdt-f t >>= λ rdt →
            return (inj₂ $ rdt , t , tp))

  handleMatchResult : meta-vars → (t₂~ : term) → (atp tp : type) → decortype → match-error-t meta-vars → spanM ∘ maybe $ check-term-app-ret
  handleMatchResult Xs' t₂~ atp tp rdt (match-error (msg , tvs)) =
    check-term-app-tm-errors.unmatchable
      t₁ t₂ tp Xs' is-locl mode Γ dom atp msg tvs
  handleMatchResult Xs' t₂~ atp tp rdt (match-ok Xs) =
      meta-vars-subst-decortype' ff Γ Xs rdt
    >>= λ rdt → return ∘ just $ check-term-app-return t₂~ Xs rdt mode []

match-unfolding-next : match-unfolding-state → match-unfolding-state
match-unfolding-next match-unfolding-both = match-unfolding-both
match-unfolding-next match-unfolding-approx = match-unfolding-approx
match-unfolding-next match-unfolding-hnf = match-unfolding-both

module m-err = meta-vars-match-errors

check-type-for-match : ctxt → type → spanM $ match-error-t kind
check-type-for-match Γ tp =
  (with-clear-error $
      check-type (qualified-ctxt Γ) (resugar tp) nothing >>=c λ _ k → return (match-ok $ k)) >>=spand return

-- match-types
-- --------------------------------------------------

match-types-ok : meta-vars → spanM $ match-error-t meta-vars
match-types-ok = return ∘ match-ok

match-types-error : match-error-data → spanM $ match-error-t meta-vars
match-types-error = return ∘ match-error

match-types Γ Xs Ls match-unfolding-both tpₓ tp =
    match-types Γ Xs Ls match-unfolding-approx tpₓ tp
  >>= λ where
    (match-ok Xs) → match-types-ok Xs
    (match-error msg) →
      match-types Γ Xs Ls match-unfolding-hnf
        (hnf Γ unfold-head-elab tpₓ)
        (hnf Γ unfold-head-elab tp)

match-types Γ Xs Ls unf tpₓ@(TpVar x) tp =
  -- check that x is a meta-var
  maybe-else' (meta-vars-lookup-with-kind Xs x)
    -- if not, make sure the two variables are the same
    -- TODO: above assumes no term meta-variables
    (return (err⊎-guard (~ conv-type Γ tpₓ tp) m-err.e-match-failure
            >> match-ok Xs))
  -- scope check the solution
  λ ret → let X = fst ret ; kₓ = snd ret in
  if are-free-in Ls tp then
    match-types-error $ m-err.e-meta-scope Γ tpₓ tp
  else (check-type-for-match Γ tp
  >>=s λ k → match-kinds Γ Xs empty-trie match-unfolding-both kₓ k
    on-fail (λ _ → return ∘ match-error $ m-err.e-bad-sol-kind Γ x tp)
  >>=s λ Xs → return (meta-vars-solve-tp Γ Xs x tp synthesizing)
  >>=s λ Xs → match-types-ok $ meta-vars-update-kinds Γ Xs Xs)

match-types Γ Xs Ls unf (TpApp tpₓ₁ (Ttp tpₓ₂)) (TpApp tp₁ (Ttp tp₂)) =
    match-types Γ Xs Ls unf tpₓ₁ tp₁
  >>=s λ Xs' → match-types Γ Xs' Ls (match-unfolding-next unf) tpₓ₂ tp₂

match-types Γ Xs Ls unf (TpApp tpₓ (Ttm tmₓ)) (TpApp tp (Ttm tm)) =
    match-types Γ Xs Ls unf tpₓ tp
  >>=s λ Xs' →
    return $ if ~ conv-term Γ tmₓ tm
      then (match-error m-err.e-match-failure) else
    match-ok Xs'

match-types Γ Xs Ls unf tpₓ'@(TpAbs bₓ xₓ tkₓ tpₓ) tp'@(TpAbs b x tk tp) =
  if bₓ xor b
    then (match-types-error m-err.e-match-failure)
    else (match-tpkds Γ Xs Ls (match-unfolding-next unf) tkₓ tk >>=s λ Xs' →
          match-types (Γ→Γ' Γ) Xs' Ls' (match-unfolding-next unf) tpₓ tp)
  where
  Γ→Γ' : ctxt → ctxt
  Γ→Γ' Γ = ctxt-rename xₓ x (ctxt-var-decl-if x Γ)
  Ls' = stringset-insert Ls x

match-types Γ Xs Ls unf (TpIota xₓ mₓ tpₓ) (TpIota x m tp) =
  match-types Γ Xs Ls (match-unfolding-next unf) mₓ m
  >>=s λ Xs →
    match-types (Γ→Γ' Γ) Xs Ls' (match-unfolding-next unf) tpₓ tp
  where
  Γ→Γ' : ctxt → ctxt
  Γ→Γ' Γ = ctxt-rename xₓ x (ctxt-var-decl-if x Γ)
  Ls' = stringset-insert Ls x

match-types Γ Xs Ls unf (TpEq t₁ₓ t₂ₓ) (TpEq t₁ t₂) =
  if ~ conv-term Γ t₁ₓ t₁
    then match-types-error $ m-err.e-match-failure else
  if ~ conv-term Γ t₂ₓ t₂
    then match-types-error $ m-err.e-match-failure else
  match-types-ok Xs

match-types Γ Xs Ls unf (TpLam xₓ atkₓ tpₓ) (TpLam x atk tp) =
  match-tpkds Γ Xs Ls (match-unfolding-next unf) atkₓ atk >>=s λ Xs →
  match-types (Γ→Γ' Γ) Xs Ls' (match-unfolding-next unf) tpₓ tp
  where
  Γ→Γ' : ctxt → ctxt
  Γ→Γ' Γ = ctxt-rename xₓ x (ctxt-var-decl-if x Γ)
  Ls' = stringset-insert Ls x

match-types Γ Xs Ls unf tpₓ tp =
  match-types-error m-err.e-match-failure

-- match-kinds
-- --------------------------------------------------

-- match-kinds-norm: match already normalized kinds
match-kinds-norm : ctxt → meta-vars → local-vars → match-unfolding-state → (kₓ k : kind) → spanM $ match-error-t meta-vars

-- kind pi
match-kinds-norm Γ Xs Ls uf (KdAbs xₓ tkₓ kₓ) (KdAbs x tk k) =
  match-tpkds Γ Xs Ls uf tkₓ tk >>=s λ Xs →
  match-kinds (Γ→Γ' Γ) Xs Ls' uf kₓ k
  where
  Γ→Γ' = ctxt-rename xₓ x ∘ ctxt-var-decl-if x
  Ls' = stringset-insert Ls x

match-kinds-norm Γ Xs Ls uf KdStar KdStar =
  match-types-ok $ Xs
match-kinds-norm Γ Xs Ls uf kₓ k =
  match-types-error $ m-err.e-matchk-failure -- m-err.e-kind-ineq Γ kₓ k

match-kinds Γ Xs Ls uf kₓ k =
  match-kinds-norm Γ Xs Ls uf
    (hnf Γ unfold-head-elab kₓ)
    (hnf Γ unfold-head-elab k)

-- match-tk
-- --------------------------------------------------
match-tpkds Γ Xs Ls uf (Tkk kₓ) (Tkk k) = match-kinds Γ Xs Ls uf kₓ k
match-tpkds Γ Xs Ls uf (Tkt tpₓ) (Tkt tp) = match-types Γ Xs Ls uf tpₓ tp
match-tpkds Γ Xs Ls uf tkₓ tk =
  match-types-error m-err.e-matchk-failure -- m-err.e-tk-ineq Γ tkₓ tk

-- match-prototype
-- --------------------------------------------------

match-prototype-err : type → prototype → spanM match-prototype-data
match-prototype-err tp pt = return $ mk-match-prototype-data meta-vars-empty (decor-error tp pt) tt

{-
  --------------------
  Xs ⊢? T ≔ ⁇ ⇒ (∅ , T)
-}
match-prototype Γ Xs uf tp (proto-maybe nothing) =
  return $ mk-match-prototype-data Xs (decor-type tp) ff

{-
  Xs ⊢= T ≔ S ⇒ σ
  --------------------
  Xs ⊢? T ≔ S ⇒ (σ , T)
-}
match-prototype Γ Xs uf tp pt@(proto-maybe (just tp')) =
  match-types Γ Xs empty-trie match-unfolding-both tp tp'
    on-fail (λ _ → return $ mk-match-prototype-data Xs (decor-error tp pt) tt)
  >>=s λ Xs' → return $ mk-match-prototype-data Xs' (decor-type tp) ff

{-
  Xs,X ⊢? T ≔ ⁇ → P ⇒ (σ , W)
  -----------------------------------------------
  Xs ⊢? ∀ X . T ≔ ⁇ → P ⇒ (σ - X , ∀ X = σ(X) . W)
-}
match-prototype Γ Xs uf (TpAbs bₓ x (Tkk k) tp) pt'@(proto-arrow e? pt) =
  -- 1) generate a fresh meta-var Y, add it to the meta-vars, and rename
  --    occurences of x in tp to Y
  let ret = meta-vars-add-from-tpabs Γ missing-span-location Xs Erased x k tp
      Y = fst ret ; Xs' = snd ret ; tp' = subst Γ (meta-var-to-type-unsafe Y) x tp
  -- 2) match the body against the original prototype to generate a decorated type
  --    and find some solutions
  in match-prototype Γ Xs' ff tp' pt'
  >>= λ ret →
  let mk-match-prototype-data Xs' dt err = ret
      Y' = maybe-else' (meta-vars-lookup Xs' (meta-var-name Y)) Y λ Y → Y
      x' = subst-rename-var-if{TYPE} Γ empty-renamectxt x empty-trie tp'
  -- 3) replace the meta-vars with the bound type variable
  in subst-decortype (ctxt-var-decl x' Γ) (TpVar x') (meta-var-name Y) dt
  -- 4) leave behind the solution for Y as a decoration and drop Y from Xs
  >>= λ dt' →
  let sort' = meta-var.sort (meta-var-set-src Y' checking)
      dt″ = decor-decor Erased x (Tkk k) sort' dt' in
  return $ mk-match-prototype-data (meta-vars-remove Xs' Y) dt″ err

{-
  Xs ⊢? T ≔ P ⇒ (σ , P)
  -----------------------------
  Xs ⊢? S → T ≔ ⁇ → P ⇒ (σ , P)
-}
match-prototype Γ Xs uf (TpAbs b x (Tkt dom) cod) (proto-arrow e? pt) =
  match-prototype Γ Xs ff cod pt
  >>= λ ret →
  let mk-match-prototype-data Xs dt err = ret
      dt' = decor-decor b x (Tkt dom) (meta-var-tm dom nothing) dt
  in return $ if b xor e?
    then mk-match-prototype-data meta-vars-empty dt' tt
  else mk-match-prototype-data Xs dt' err

{-
  X ∈ Xs
  -----------------------------------
  Xs ⊢? X ≔ ⁇ → P ⇒ (σ , (X , ⁇ → P))
-}
match-prototype Γ Xs tt tp@(TpVar x) pt@(proto-arrow _ _) =
  return $ mk-match-prototype-data Xs (decor-stuck tp pt) ff

-- everything else...
-- Types for which we should keep digging
match-prototype Γ Xs ff tp@(TpVar x) pt@(proto-arrow _ _) =
  match-prototype Γ Xs tt (hnf Γ unfold-head-elab tp) pt
match-prototype Γ Xs ff tp@(TpApp _ _) pt@(proto-arrow _ _) =
  match-prototype Γ Xs tt (hnf Γ unfold-head-elab tp) pt
-- types for which we should suspend disbelief
match-prototype Γ Xs tt tp@(TpApp _ _) pt@(proto-arrow _ _) =
  return $ mk-match-prototype-data Xs (decor-stuck tp pt) ff
-- types which clearly do not match the prototype
match-prototype Γ Xs uf tp@(TpEq _ _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt
match-prototype Γ Xs uf tp@(TpHole _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt
match-prototype Γ Xs uf tp@(TpLam _ _ _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt
match-prototype Γ Xs uf tp@(TpIota _ _ _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt


-- {-# OPTIONS -v reify:100 -v syntax.reify:100  #-}
module Issue857b where

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

_∋_ : (A : Set) → A → A
_ ∋ x = x

foo : {A B : Set} {x : ⊥} {y : B} →
      ((⊥ → A) ∋ λ()) x ≡ ((⊥ → B → A) ∋ λ()) x y
foo = refl

-- WAS: An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:514

bar : {A B C : Set} {x : ⊥} {y : B} {z : C} →
      ((⊥ → B → A) ∋ λ()) x y ≡ ((⊥ → C → A) ∋ λ()) x z
bar = refl

-- WAS:
-- .y != .z of type .B
-- when checking that the expression refl has type
-- ((⊥ → .B → .A) ∋ .Test.absurdLambda) .x .y ≡
-- ((⊥ → .C → .A) ∋ .Test.absurdLambda) .x .z

-- Note that z has type C, not B.

baz : {A : Set} → _≡_ {A = ⊥ → A} ⊥-elim (λ())
baz = refl

-- WAS: An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:51

-- ERROR: ⊥-elim x != (λ ()) x of type .A
-- when checking that the expression refl has type ⊥-elim ≡ (λ ())