{-# OPTIONS --safe #-}

module Definition.Conversion.EqRelInstance where

open import Definition.Untyped
open import Definition.Untyped.Properties using (wkSingleSubstId)
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening using (_∷_⊆_; wkEq; step; id)
open import Definition.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Universe
open import Definition.Conversion.Stability
open import Definition.Conversion.Soundness
open import Definition.Conversion.Lift
open import Definition.Conversion.Conversion
open import Definition.Conversion.Transitivity
open import Definition.Conversion.Weakening
open import Definition.Conversion.Whnf
open import Definition.Typed.EqualityRelation
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Reduction
open import Definition.Conversion.Symmetry

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

-- Algorithmic equality of neutrals with injected conversion.
data _⊢_~_∷_^_ (Γ : Con Term) (k l A : Term) (r : TypeInfo) : Set where
  ↑ : ∀ {B} → Γ ⊢ A ≡ B ^ r → Γ ⊢ k ~ l ↑ B ^ r → Γ ⊢ k ~ l ∷ A ^ r

-- Properties of algorithmic equality of neutrals with injected conversion.

~-var : ∀ {x A r Γ} → Γ ⊢ var x ∷ A ^ r → Γ ⊢ var x ~ var x ∷ A ^ r
~-var x =
  let ⊢A = syntacticTerm x
  in  ↑ (refl ⊢A) (var-refl′ x)

~-app : ∀ {f g a b F G Γ rF lF lG lΠ}
      → Γ ⊢ f ~ g ∷ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ ! , ι lΠ ]
      → Γ ⊢ a [genconv↑] b ∷ F ^ [ rF , ι lF ]
      → Γ ⊢ f ∘ a ^ lΠ ~ g ∘ b ^ lΠ ∷ G [ a ] ^ [ ! , ι lG ]
~-app {rF = !} (↑ A≡B (~↑! x)) x₁ =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΠFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΠHE = Π≡A ΠFG≡B′ whnfB′
      F≡H , _ , _ , _ , G≡E = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) B≡ΠHE ΠFG≡B′)
      _ , ⊢f , _ = syntacticEqTerm (soundnessConv↑Term x₁)
  in  ↑ (substTypeEq G≡E (refl ⊢f))
        (app-cong′  (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _)
                       B≡ΠHE ([~] _ (red D) whnfB′ x))
             (convConvTerm x₁ F≡H))
~-app {rF = %} (↑ A≡B (~↑! x)) x₁ =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΠFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΠHE = Π≡A ΠFG≡B′ whnfB′
      F≡H , _ , _ , _ , G≡E = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) B≡ΠHE ΠFG≡B′)
      _ , ⊢f , _ = syntacticEqTerm (proj₂ (proj₂ (soundness~↑% x₁)))
  in  ↑ (substTypeEq G≡E (genRefl ⊢f))
        (app-cong′ (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _)
                       B≡ΠHE ([~] _ (red D) whnfB′ x))
                   (conv~↑% x₁ F≡H))
~-natrec : ∀ {z z′ s s′ n n′ F F′ Γ lF}
         → (Γ ∙ ℕ ^ [ ! , ι ⁰ ]) ⊢ F [conv↑] F′ ^ [ ! , ι lF ]  →
      Γ ⊢ z [conv↑] z′ ∷ (F [ zero ]) ^ ι lF →
      Γ ⊢ s [conv↑] s′ ∷ (Π ℕ ^ ! ° ⁰ ▹ (F ^ ! ° lF ▹▹ F [ suc (var 0) ]↑ ° lF ° lF) ° lF ° lF) ^ ι lF →
      Γ ⊢ n ~ n′ ∷ ℕ ^ [ ! , ι ⁰ ] →
      Γ ⊢ natrec lF F z s n ~ natrec lF F′ z′ s′ n′ ∷ (F [ n ]) ^ [ ! , ι lF ]
~-natrec {n = n} {n′ = n′} x x₁ x₂ (↑ A≡B (~↑! x₄)) =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ℕ≡B′ = trans A≡B (subset* (red D))
      B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
      k~l′ = PE.subst (λ x → _ ⊢ n ~ n′ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x₄)
      ⊢F , _ = syntacticEq (soundnessConv↑ x)
      _ , ⊢n , _ = syntacticEqTerm (soundness~↓! k~l′)
  in  ↑ (refl (substType ⊢F ⊢n)) (natrec-cong′ x x₁ x₂ k~l′)

~-Emptyrec : ∀ {e e' F F′ Γ l lEmpty}
         → Γ ⊢ F [conv↑] F′ ^ [ ! , ι l ] →
         Γ ⊢ e ∷ Empty lEmpty ^ [ % , ι lEmpty ] →
         Γ ⊢ e' ∷ Empty lEmpty ^ [ % , ι lEmpty ] →
         Γ ⊢ Emptyrec l lEmpty F e ~ Emptyrec l lEmpty F′ e' ∷ F ^ [ ! , ι l ]
~-Emptyrec {e = e} {e' = e'} x ⊢e ⊢e' =
  let k~l′ = %~↑ ⊢e ⊢e'
      ⊢F , _ = syntacticEq (soundnessConv↑ x)
  in  ↑ (refl ⊢F) (Emptyrec-cong′ x k~l′)

~-IdCong : ∀ {A A' : Term} {l : Level} {t t' u u' : Term} {Γ : Con Term} →
      Γ ⊢ A ~ A' ∷ Univ ! l ^ [ ! , next l ] →
      Γ ⊢ t [conv↑] t' ∷ A ^ ι l →
      Γ ⊢ u [conv↑] u' ∷ A ^ ι l →
      Γ ⊢ Id A t u ~ Id A' t' u' ∷ SProp l ^ [ ! , next l ]
~-IdCong (↑ A≡B (~↑! x)) t~t' u~u' =
     let ⊢Γ = wfEqTerm (soundnessConv↑Term t~t')
         _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         A~A′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-cong A~A′ t~t' u~u'))

~-Idℕ : ∀ {t t' u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t ~ t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ u [genconv↑] u' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ Id ℕ t u ~ Id ℕ t' u' ∷ SProp ⁰ ^ [ ! , next ⁰ ]
~-Idℕ ⊢Γ (↑ A≡B (~↑! x)) u~u' =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-ℕ t~t′ u~u'))

~-Idℕ0 : ∀ {u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ u ~ u' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ Id ℕ zero u ~ Id ℕ zero u' ∷ SProp ⁰ ^ [ ! , next ⁰ ]
~-Idℕ0 ⊢Γ (↑ A≡B (~↑! x)) =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-ℕ0 t~t′))

~-IdℕS : ∀ {t t' u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t [genconv↑] t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ u ~ u' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ Id ℕ (suc t) u ~ Id ℕ (suc t') u' ∷ SProp ⁰ ^ [ ! , next ⁰ ]
~-IdℕS ⊢Γ X (↑ A≡B (~↑! x)) =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-ℕS X t~t′))

~-IdU : ∀ {t t' u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t ~ t' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ u [genconv↑] u' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Id (U ⁰) t u ~ Id (U ⁰) t' u' ∷ SProp ¹ ^ [ ! , next ¹ ]
~-IdU ⊢Γ (↑ A≡B (~↑! x)) X =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-U t~t′ X))

~-IdUℕ : ∀ {u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ u ~ u' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Id (U ⁰) ℕ u ~ Id (U ⁰) ℕ u' ∷ SProp ¹ ^ [ ! , next ¹ ]
~-IdUℕ ⊢Γ (↑ A≡B (~↑! x)) =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-Uℕ t~t′))

~-IdUΠ : ∀ {A : Term} {rA : Relevance} {B A' B' u u' : Term}
    {Γ : Con Term} →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ u ~ u' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) u ~
    Id (U ⁰) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰) u' ∷ SProp ¹ ^ [ ! , next ¹ ]
~-IdUΠ X (↑ A≡B (~↑! x)) =
     let ⊢Γ =  wfEqTerm (soundnessConv↑Term X)
         _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-UΠ X t~t′))

~-castcong : ∀ {A A' B B' e e' t t' : Term} {Γ : Con Term} →
    Γ ⊢ A ~ A' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B [genconv↑] B' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ A ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) A B ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) A' B' ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ A B e t ~ cast ⁰ A' B' e' t' ∷ B ^ [ ! , ι ⁰ ]
~-castcong (↑ A≡B (~↑! x)) X Y ⊢e ⊢e' =
     let _ , ⊢B , _ = syntacticEqTerm (soundnessConv↑Term X)
         _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (univ ⊢B)) (~↑! (cast-cong t~t′ X Y ⊢e ⊢e'))

~-castℕ : ∀ {B B' e e' t t' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ B ~ B' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) ℕ B ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) ℕ B' ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ ℕ B e t ~ cast ⁰ ℕ B' e' t' ∷ B ^ [ ! , ι ⁰ ]
~-castℕ ⊢Γ (↑ A≡B (~↑! x)) X ⊢e ⊢e' =
     let _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
         _ , ⊢B , _ = syntacticEqTerm (soundness~↓! t~t′)
     in ↑ (refl (univ ⊢B)) (~↑! (cast-ℕ t~t′ X ⊢e ⊢e'))

~-castℕℕ : ∀ {e e' t t' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t ~ t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ ℕ ℕ e t ~ cast ⁰ ℕ ℕ e' t' ∷ ℕ ^ [ ! , ι ⁰ ]
~-castℕℕ ⊢Γ (↑ A≡B (~↑! x)) ⊢e ⊢e' =
     let _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
         _ , ⊢B , _ = syntacticEqTerm (soundness~↓! t~t′)
     in ↑ (refl (univ (ℕⱼ ⊢Γ))) (~↑! (cast-ℕℕ t~t′ ⊢e ⊢e'))

~-castΠ : ∀ {A A' : Term} {rA : Relevance} {P P' B B' e e' t t' : Term}
    {Γ : Con Term} →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B ~ B' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) B ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) B' ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) B e t ~ cast ⁰ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) B' e' t' ∷ B ^ [ ! , ι ⁰ ]
~-castΠ X (↑ A≡B (~↑! x)) Y ⊢e ⊢e' =
     let _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
         _ , ⊢B , _ = syntacticEqTerm (soundness~↓! t~t′)
     in ↑ (refl (univ ⊢B)) (~↑! (cast-Π X t~t′ Y ⊢e ⊢e'))

~-castℕΠ : ∀ {A A' : Term} {rA : Relevance} {P P' e e' t t' : Term}
    {Γ : Con Term} →
    Γ ⊢ A ∷ Univ rA ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ rA , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) ℕ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) ℕ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ ℕ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) e t ~ cast ⁰ ℕ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) e' t' ∷
    Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]
~-castℕΠ ⊢A ⊢P X Y ⊢e ⊢e' = ↑ (refl (univ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢A ▹ ⊢P))) (~↑! (cast-ℕΠ X Y ⊢e ⊢e'))

~-castΠℕ : ∀ {A A' : Term} {rA : Relevance} {P P' e e' t t' : Term}
    {Γ : Con Term} →
    Γ ⊢ A ∷ Univ rA ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ rA , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰
    ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) ℕ e t ~
    cast ⁰ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) ℕ e' t' ∷ ℕ ^ [ ! , ι ⁰ ]
~-castΠℕ ⊢A ⊢P X Y ⊢e ⊢e' = ↑ (refl (univ (ℕⱼ (wfTerm ⊢A)))) (~↑! (cast-Πℕ X Y ⊢e ⊢e'))

~-castΠΠ%! : ∀ {A A' P P' B B' Q Q' e e' t t' : Term} {Γ : Con Term} →
    Γ ⊢ A ∷ Univ % ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ % , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ % ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B ∷ Univ ! ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ B ^ [ ! , ι ⁰ ]) ⊢ Q ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰ [genconv↑] Π B' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e  ∷ Id (U ⁰) (Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ % ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰) e t ~
        cast ⁰ (Π A' ^ % ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰) e' t' ∷ Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]
~-castΠΠ%! ⊢A ⊢P X ⊢B ⊢Q Y t~t' ⊢e ⊢e' = ↑ (refl (univ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢B ▹ ⊢Q)))
                                           (~↑! (cast-ΠΠ%! X Y t~t' ⊢e ⊢e'))

~-castΠΠ!% : ∀ {A A' P P' B B' Q Q' e e' t t' : Term} {Γ : Con Term} →
    Γ ⊢ A ∷ Univ ! ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ ! , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ ! ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B ∷ Univ % ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ B ^ [ % , ι ⁰ ]) ⊢ Q ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰ [genconv↑] Π B' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e  ∷ Id (U ⁰) (Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ ! ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰) e t ~
        cast ⁰ (Π A' ^ ! ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰) e' t' ∷ Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]
~-castΠΠ!% ⊢A ⊢P X ⊢B ⊢Q Y t~t' ⊢e ⊢e' = ↑ (refl (univ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢B ▹ ⊢Q)))
                                           (~↑! (cast-ΠΠ!% X Y t~t' ⊢e ⊢e'))

~-sym : {k l A : Term} {r : TypeInfo} {Γ : Con Term} → Γ ⊢ k ~ l ∷ A ^ r → Γ ⊢ l ~ k ∷ A ^ r
~-sym (↑ A≡B x) =
  let ⊢Γ = wfEq A≡B
      B , A≡B′ , l~k = sym~↑ (reflConEq ⊢Γ) x
  in  ↑ (trans A≡B A≡B′) l~k

~-trans : {k l m A : Term} {r : TypeInfo} {Γ : Con Term}
        → Γ ⊢ k ~ l ∷ A ^ r → Γ ⊢ l ~ m ∷ A ^ r
        → Γ ⊢ k ~ m ∷ A ^ r
~-trans (↑ x (~↑! x₁)) (↑ x₂ (~↑! x₃)) =
  let ⊢Γ = wfEq x
      k~m , _ = trans~↑! PE.refl (reflConEq ⊢Γ) x₁ x₃
  in  ↑ x (~↑! k~m)
~-trans (↑ x (~↑% x₁)) (↑ x₂ (~↑% x₃)) =
  let ⊢Γ = wfEq x
      k~m = trans~↑% (reflConEq ⊢Γ) x₁ (conv~↑% x₃ (trans (sym x₂) x))
  in  ↑ x (~↑% k~m)

~-wk : {k l A : Term} {r : TypeInfo} {ρ : Wk} {Γ Δ : Con Term} →
      ρ ∷ Δ ⊆ Γ →
      ⊢ Δ → Γ ⊢ k ~ l ∷ A ^ r → Δ ⊢ wk ρ k ~ wk ρ l ∷ wk ρ A ^ r
~-wk x x₁ (↑ x₂ x₃) = ↑ (wkEq x x₁ x₂) (wk~↑ x x₁ x₃)

~-conv : {k l A B : Term} {r : TypeInfo} {Γ : Con Term} →
      Γ ⊢ k ~ l ∷ A ^ r → Γ ⊢ A ≡ B ^ r → Γ ⊢ k ~ l ∷ B ^ r
~-conv (↑ x x₁) x₂ = ↑ (trans (sym x₂) x) x₁

~-to-conv : {k l A : Term} {Γ : Con Term} {r : TypeInfo} →
      Γ ⊢ k ~ l ∷ A ^ r →  Γ ⊢ k [genconv↑] l ∷ A ^ r
~-to-conv {r = [ ! , ll ]} (↑ x x₁) = convConvTerm (lift~toConv↑ x₁) (sym x)
~-to-conv {r = [ % , ll ]} (↑ x (~↑% x₁)) = conv~↑% x₁ (sym x)

un-univConv : ∀ {A B : Term} {r : Relevance} {l : Level} {Γ : Con Term} →
                Γ ⊢ A [conv↑] B ^ [ r , ι l ] →
                Γ ⊢ A [conv↑] B ∷ Univ r l ^ next l
un-univConv {A} {B} {r} {l} ([↑] A′ B′ D D′ whnfA′ whnfB′ (univ x)) =
            let ⊢Γ = wfEqTerm (soundnessConv↓Term x)
            in [↑]ₜ (Univ r l) A′ B′ (id (Ugenⱼ ⊢Γ)) (un-univ⇒* D) (un-univ⇒* D′) Uₙ whnfA′ whnfB′ x

Πₜ-cong : ∀ {F G H E rF rG lF lG lΠ Γ}
        → lF ≤ lΠ
        → lG ≤ lΠ
        → Γ ⊢ F ^ [ rF , ι lF ]
        → Γ ⊢ F [conv↑] H ∷ Univ rF lF ^ next lF
        → Γ ∙ F ^ [ rF , ι lF ] ⊢ G [conv↑] E ∷ Univ rG lG ^ next lG
        → Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ [conv↑] Π H ^ rF ° lF ▹ E ° lG ° lΠ ∷ Univ rG lΠ ^ next lΠ
Πₜ-cong lF< lG< x x₁ x₂ = liftConvTerm (Π-cong PE.refl PE.refl PE.refl PE.refl lF< lG< x x₁ x₂)

~-irrelevance : {k l A : Term} {Γ : Con Term} {ll : TypeLevel}
               → Γ ⊢ k ∷ A ^ [ % , ll ]
               → Γ ⊢ l ∷ A ^ [ % , ll ]
               → Γ ⊢ k ~ l ∷ A ^ [ % , ll ]
~-irrelevance ⊢k ⊢l =
  let X = ~↑% (%~↑ ⊢k ⊢l)
      ⊢A  = syntacticTerm ⊢k
  in ↑ (refl ⊢A) X

soundnessgenConv : ∀ {a b A r Γ} → Γ ⊢ a [genconv↑] b ∷ A ^ r → Γ ⊢ a ≡ b ∷ A ^ r
soundnessgenConv {r = [ ! , l ]} = soundnessConv↑Term
soundnessgenConv {r = [ % , l ]} x = proj₂ (proj₂ (soundness~↑% x))

symgenConv : ∀ {t u A r Γ} → Γ ⊢ t [genconv↑] u ∷ A ^ r → Γ ⊢ u [genconv↑] t ∷ A ^ r
symgenConv {r = [ ! , l ]} = symConvTerm
symgenConv {r = [ % , l ]} t<>u = let ⊢Γ = wfEqTerm (proj₂ (proj₂ (soundness~↑% t<>u)))
                          in  sym~↑% (reflConEq ⊢Γ) t<>u

wkgenConv↑Term : ∀ {ρ t u A Γ r Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
             → Γ ⊢ t [genconv↑] u ∷ A ^ r
             → Δ ⊢ wk ρ t [genconv↑] wk ρ u ∷ wk ρ A ^ r
wkgenConv↑Term {r = [ ! , l ]} = wkConv↑Term
wkgenConv↑Term {r = [ % , l ]} = wk~↑%

convgenconv : ∀ {t u A B : Term} {r : TypeInfo} {Γ : Con Term} →
      Γ ⊢ t [genconv↑] u ∷ A ^ r →
      Γ ⊢ A ≡ B ^ r → Γ ⊢ t [genconv↑] u ∷ B ^ r
convgenconv {r = [ ! , l ]} = convConvTerm
convgenconv {r = [ % , l ]} = conv~↑%

transgenConv : ∀ {t u v A : Term} {r : TypeInfo} {Γ : Con Term} →
      Γ ⊢ t [genconv↑] u ∷ A ^ r →
      Γ ⊢ u [genconv↑] v ∷ A ^ r → Γ ⊢ t [genconv↑] v ∷ A ^ r
transgenConv {r = [ ! , l ]} = transConvTerm
transgenConv {r = [ % , l ]} = trans~↑!Term

-- Algorithmic equality instance of the generic equality relation.
instance eqRelInstance : EqRelSet
eqRelInstance = eqRel _⊢_[conv↑]_^_ _⊢_[genconv↑]_∷_^_ _⊢_~_∷_^_
                      ~-to-conv soundnessConv↑ soundnessgenConv
                      univConv↑ un-univConv
                      symConv symgenConv ~-sym
                      transConv transgenConv ~-trans
                      convgenconv ~-conv
                      wkConv↑ wkgenConv↑Term ~-wk
                      reductionConv↑ reductionConv↑Term
                      (liftConv ∘ᶠ (U-refl PE.refl)) ( liftConvTerm ∘ᶠ  (U-refl PE.refl))
                      (liftConvTerm ∘ᶠ ℕ-refl)
                      (liftConvTerm ∘ᶠ (Empty-refl PE.refl))
                      Πₜ-cong
                      (λ x x₁ x₂ → liftConvTerm (∃-cong PE.refl x x₁ x₂))
                      (liftConvTerm ∘ᶠ zero-refl)
                      (liftConvTerm ∘ᶠ suc-cong)
                      (λ l< l<' x x₁ x₂ x₃ x₄ x₅ → liftConvTerm (η-eq l< l<' x x₁ x₂ x₃ x₄ x₅))
                      ~-var ~-app ~-natrec ~-Emptyrec
                      ~-IdCong ~-Idℕ ~-Idℕ0 ~-IdℕS ~-IdU ~-IdUℕ ~-IdUΠ
                      ~-castcong ~-castℕ ~-castℕℕ ~-castΠ ~-castℕΠ ~-castΠℕ ~-castΠΠ%! ~-castΠΠ!%
                      ~-irrelevance


module subst where

open import lib

open import cedille-types
open import ctxt-types
open import is-free
open import rename
open import general-util
open import syntax-util

substh-ret-t : Set → Set
substh-ret-t T = ∀ {ed} → ctxt → renamectxt → trie ⟦ ed ⟧ → T → T

substh : ∀ {ed} → substh-ret-t ⟦ ed ⟧
substh-term : substh-ret-t term
substh-type : substh-ret-t type
substh-kind : substh-ret-t kind
substh-tk : substh-ret-t tk
substh-optClass : substh-ret-t optClass
substh-optGuide : substh-ret-t optGuide
substh-optTerm : substh-ret-t optTerm
substh-optType : substh-ret-t optType
substh-liftingType : substh-ret-t liftingType
substh-arg : substh-ret-t arg
substh-args : substh-ret-t args
substh-params : substh-ret-t params
substh-cases : substh-ret-t cases
substh-varargs : {ed : exprd} → ctxt → renamectxt → trie ⟦ ed ⟧ → varargs → varargs × renamectxt

substh{TERM} = substh-term
substh{TYPE} = substh-type
substh{KIND} = substh-kind
substh{LIFTINGTYPE} = substh-liftingType
substh{TK} = substh-tk
substh{ARG} = substh-arg
substh{QUALIF} = λ Γ ρ σ q → q

subst-rename-var-if : {ed : exprd} → ctxt → renamectxt → var → trie ⟦ ed ⟧ → var
subst-rename-var-if Γ ρ "_" σ = "_"
subst-rename-var-if Γ ρ x σ =
  {- rename bound variable x iff it is one of the vars being substituted for,
     or if x occurs free in one of the terms we are substituting for vars,
     or if it is the renamed version of any variable -}
  if trie-contains σ x || trie-any (is-free-in check-erased x) σ || renamectxt-in-range ρ x || ctxt-binds-var Γ x then
    rename-away-from x (λ s → ctxt-binds-var Γ s || trie-contains σ s) ρ
  else
    x

substh-term Γ ρ σ (App t m t') = App (substh-term Γ ρ σ t) m (substh-term Γ ρ σ t')
substh-term Γ ρ σ (AppTp t tp) = AppTp (substh-term Γ ρ σ t) (substh-type Γ ρ σ tp)
substh-term Γ ρ σ (Hole x₁) = Hole x₁
substh-term Γ ρ σ (Lam _ b _ x oc t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Lam posinfo-gen b posinfo-gen x' (substh-optClass Γ ρ σ oc)
      (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-term Γ ρ σ (Let _ (DefTerm _ x m t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (Let posinfo-gen (DefTerm posinfo-gen x' (substh-optType Γ ρ σ m) (substh-term Γ ρ σ t))
      (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-term Γ ρ σ (Let _ (DefType _ x k t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (Let posinfo-gen (DefType posinfo-gen x' (substh-kind Γ ρ σ k) (substh-type Γ ρ σ t))
      (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-term Γ ρ σ (Open _ x t) = Open posinfo-gen x (substh-term Γ ρ σ t)
substh-term Γ ρ σ (Parens _ t _) = substh-term Γ ρ σ t
substh-term{TERM} Γ ρ σ (Var _ x) =
 let x' = renamectxt-rep ρ x in
   trie-lookup-else (Var posinfo-gen x') σ x'
substh-term{ARG} Γ ρ σ (Var _ x) =
 let x' = renamectxt-rep ρ x in
   inst-lookup-term σ x'
substh-term{QUALIF} Γ ρ σ (Var _ x) =
 let x' = renamectxt-rep ρ x in
   qualif-lookup-term σ x'
substh-term Γ ρ σ (Var _ x) = Var posinfo-gen (renamectxt-rep ρ x)
substh-term Γ ρ σ (Beta _ ot ot') = Beta posinfo-gen (substh-optTerm Γ ρ σ ot) (substh-optTerm Γ ρ σ ot')
substh-term Γ ρ σ (IotaPair _ t1 t2 og pi') = IotaPair posinfo-gen (substh-term Γ ρ σ t1) (substh-term Γ ρ σ t2) (substh-optGuide Γ ρ σ og) pi'
substh-term Γ ρ σ (IotaProj t n _) = IotaProj (substh-term Γ ρ σ t) n posinfo-gen
substh-term Γ ρ σ (Epsilon _ lr m t) = Epsilon posinfo-gen lr m (substh-term Γ ρ σ t)
substh-term Γ ρ σ (Sigma _ t) = Sigma posinfo-gen (substh-term Γ ρ σ t)
substh-term Γ ρ σ (Phi _ t t₁ t₂ _) = Phi posinfo-gen (substh-term Γ ρ σ t) (substh-term Γ ρ σ t₁) (substh-term Γ ρ σ t₂) posinfo-gen
substh-term Γ ρ σ (Rho _ op on t og t') = Rho posinfo-gen op on (substh-term Γ ρ σ t) (substh-optGuide Γ ρ σ og) (substh-term Γ ρ σ t')
substh-term Γ ρ σ (Chi _ T t') = Chi posinfo-gen (substh-optType Γ ρ σ T) (substh-term Γ ρ σ t')
substh-term Γ ρ σ (Delta _ T t') = Delta posinfo-gen (substh-optType Γ ρ σ T) (substh-term Γ ρ σ t')
substh-term Γ ρ σ (Theta _ θ t ls) = Theta posinfo-gen (substh-theta θ) (substh-term Γ ρ σ t) (substh-lterms ls)
  where substh-lterms : lterms → lterms
        substh-lterms (LtermsNil pi) = LtermsNil pi
        substh-lterms (LtermsCons m t ls) = LtermsCons m (substh-term Γ ρ σ t) (substh-lterms ls)
        substh-vars : vars → vars
        substh-vars (VarsStart x) = VarsStart (renamectxt-rep ρ x)
        substh-vars (VarsNext x xs) = VarsNext (renamectxt-rep ρ x) (substh-vars xs)
        substh-theta : theta → theta
        substh-theta (AbstractVars xs) = AbstractVars (substh-vars xs)
        substh-theta θ = θ
substh-term Γ ρ σ (Mu _ x t ot _ cs _) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
    Mu posinfo-gen x' (substh-term (ctxt-var-decl x' Γ) ρ' σ t) (substh-optType Γ ρ σ ot) posinfo-gen (substh-cases Γ ρ' σ cs) posinfo-gen
substh-term Γ ρ σ (Mu' _ t ot _ cs _) = Mu' posinfo-gen (substh-term Γ ρ σ t) (substh-optType Γ ρ σ ot) posinfo-gen (substh-cases Γ ρ σ cs) posinfo-gen

substh-cases Γ ρ σ NoCase = NoCase
substh-cases Γ ρ σ (SomeCase _ x varargs t cs) =
  let res = substh-varargs Γ ρ σ varargs in
  SomeCase posinfo-gen x (fst res) (substh-term Γ (snd res) σ t) (substh-cases Γ ρ σ cs)

substh-varargs Γ ρ σ NoVarargs                = NoVarargs , ρ
substh-varargs Γ ρ σ (NormalVararg x varargs) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
  let res = substh-varargs Γ ρ' σ varargs in
  NormalVararg x' (fst res) , snd res
substh-varargs Γ ρ σ (ErasedVararg x varargs) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
  let res = substh-varargs Γ ρ' σ varargs in
  ErasedVararg x' (fst res) , snd res
substh-varargs Γ ρ σ (TypeVararg   x varargs) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
  let res = substh-varargs Γ ρ' σ varargs in
  TypeVararg x' (fst res) , snd res

substh-type Γ ρ σ (Abs _ b _ x atk t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Abs posinfo-gen b posinfo-gen x' (substh-tk Γ ρ σ atk)
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-type Γ ρ σ (TpLambda _ _ x atk t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    TpLambda posinfo-gen posinfo-gen x' (substh-tk Γ ρ σ atk)
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-type Γ ρ σ (Iota _ _ x m t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Iota posinfo-gen posinfo-gen x' (substh-type Γ ρ σ m)
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-type Γ ρ σ (Lft _ _ x t l) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Lft posinfo-gen posinfo-gen x' (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
      (substh-liftingType Γ ρ σ l)
substh-type Γ ρ σ (TpApp tp tp₁) = TpApp (substh-type Γ ρ σ tp) (substh-type Γ ρ σ tp₁)
substh-type Γ ρ σ (TpAppt tp t) = TpAppt (substh-type Γ ρ σ tp) (substh-term Γ ρ σ t)
substh-type Γ ρ σ (TpArrow tp arrowtype tp₁) = TpArrow (substh-type Γ ρ σ tp) arrowtype (substh-type Γ ρ σ tp₁)
substh-type Γ ρ σ (TpEq _ x₁ x₂ _) = TpEq posinfo-gen (substh-term Γ ρ σ x₁) (substh-term Γ ρ σ x₂) posinfo-gen
substh-type Γ ρ σ (TpParens _ tp _) = substh-type Γ ρ σ tp
substh-type Γ ρ σ (NoSpans tp _) = substh-type Γ ρ σ tp
substh-type{TYPE} Γ ρ σ (TpVar _ x) =
 let x' = renamectxt-rep ρ x in
   trie-lookup-else (TpVar posinfo-gen x') σ x'
substh-type{ARG} Γ ρ σ (TpVar _ x) =
 let x' = renamectxt-rep ρ x in
   inst-lookup-type σ x'
substh-type{QUALIF} Γ ρ σ (TpVar _ x) =
 let x' = renamectxt-rep ρ x in
   qualif-lookup-type σ x'
substh-type Γ ρ σ (TpVar _ x) = TpVar posinfo-gen (renamectxt-rep ρ x)
substh-type Γ ρ σ (TpHole _) = TpHole posinfo-gen --ACG
substh-type Γ ρ σ (TpLet _ (DefTerm _ x m t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (TpLet posinfo-gen (DefTerm posinfo-gen x' (substh-optType Γ ρ σ m) (substh-term Γ ρ σ t))
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-type Γ ρ σ (TpLet _ (DefType _ x k t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (TpLet posinfo-gen (DefType posinfo-gen x' (substh-kind Γ ρ σ k) (substh-type Γ ρ σ t))
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-kind Γ ρ σ (KndArrow k k₁) = KndArrow (substh-kind Γ ρ σ k) (substh-kind Γ ρ σ k₁)
substh-kind Γ ρ σ (KndParens x₁ k x₂) = substh-kind Γ ρ σ k
substh-kind Γ ρ σ (KndPi _ _ x atk k) =
  let x' = subst-rename-var-if Γ ρ x σ in
    KndPi posinfo-gen posinfo-gen x' (substh-tk Γ ρ σ atk)
      (substh-kind (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ k)
substh-kind Γ ρ σ (KndTpArrow t k) = KndTpArrow (substh-type Γ ρ σ t) (substh-kind Γ ρ σ k)
substh-kind{QUALIF} Γ ρ σ (KndVar _ x xs) =
   qualif-lookup-kind (substh-args Γ ρ σ xs) σ x
substh-kind Γ ρ σ (KndVar _ x xs) = KndVar posinfo-gen x (substh-args Γ ρ σ xs)
substh-kind Γ ρ σ (Star _) = Star posinfo-gen

substh-arg Γ ρ σ (TermArg me t) = TermArg me (substh-term Γ ρ σ t)
substh-arg Γ ρ σ (TypeArg T) = TypeArg (substh-type Γ ρ σ T)

substh-args Γ ρ σ (ArgsCons a as) = ArgsCons (substh-arg Γ ρ σ a) (substh-args Γ ρ σ as)
substh-args Γ ρ σ ArgsNil = ArgsNil

substh-params{QUALIF} Γ ρ σ (ParamsCons (Decl _ pi me x atk _) ps) =
  ParamsCons (Decl posinfo-gen posinfo-gen me (pi % x) (substh-tk Γ ρ σ atk) posinfo-gen)
    (substh-params Γ (renamectxt-insert ρ x (pi % x)) (trie-remove σ (pi % x)) ps)
substh-params Γ ρ σ (ParamsCons (Decl _ _ me x atk _) ps) =
  ParamsCons (Decl posinfo-gen posinfo-gen me x (substh-tk Γ ρ σ atk) posinfo-gen)
    (substh-params Γ (renamectxt-insert ρ x x) (trie-remove σ x) ps)
substh-params Γ ρ σ ParamsNil = ParamsNil

substh-tk Γ ρ σ (Tkk k) = Tkk (substh-kind Γ ρ σ k)
substh-tk Γ ρ σ (Tkt t) = Tkt (substh-type Γ ρ σ t)

substh-optClass Γ ρ σ NoClass = NoClass
substh-optClass Γ ρ σ (SomeClass atk) = SomeClass (substh-tk Γ ρ σ atk)
substh-liftingType Γ ρ σ (LiftArrow l l₁) = LiftArrow (substh-liftingType Γ ρ σ l) (substh-liftingType Γ ρ σ l₁)
substh-liftingType Γ ρ σ (LiftParens _ l _) = substh-liftingType Γ ρ σ l
substh-liftingType Γ ρ σ (LiftPi _ x tp l) =
  let x' = subst-rename-var-if Γ ρ x σ in
    LiftPi posinfo-gen x' (substh-type Γ ρ σ tp)
       (substh-liftingType (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ l)
substh-liftingType Γ ρ σ (LiftStar _) = LiftStar posinfo-gen
substh-liftingType Γ ρ σ (LiftTpArrow tp l) =
  LiftTpArrow (substh-type Γ ρ σ tp) (substh-liftingType Γ ρ σ l)

substh-optType Γ ρ σ NoType = NoType
substh-optType Γ ρ σ (SomeType T) = SomeType (substh-type Γ ρ σ T)

substh-optTerm Γ ρ σ NoTerm = NoTerm
substh-optTerm Γ ρ σ (SomeTerm t _) = (SomeTerm (substh-term Γ ρ σ t) posinfo-gen)

substh-optGuide Γ ρ σ NoGuide = NoGuide
substh-optGuide Γ ρ σ (Guide _ x T) =
  let x' = subst-rename-var-if Γ ρ x σ in
  Guide posinfo-gen x' (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T)

subst-ret-t : Set → Set
subst-ret-t T = {ed : exprd} → ctxt → ⟦ ed ⟧ → var → T → T

subst : ∀ {ed} → subst-ret-t ⟦ ed ⟧
subst Γ t x = substh Γ empty-renamectxt (trie-single x t)

subst-term = subst {TERM}
subst-type = subst {TYPE}
subst-kind = subst {KIND}
subst-liftingType = subst {LIFTINGTYPE}
subst-tk = subst {TK}

subst-renamectxt : ∀ {ed : exprd} → ctxt → renamectxt → ⟦ ed ⟧ → ⟦ ed ⟧
subst-renamectxt {ed} Γ ρ = substh {ed} {ed} Γ ρ empty-trie

rename-var : ∀ {ed} → ctxt → var → var → ⟦ ed ⟧ → ⟦ ed ⟧
rename-var Γ x x' = subst-renamectxt Γ (renamectxt-single x x')

substs-ret-t : Set → Set
substs-ret-t T = ∀ {ed} → ctxt → trie ⟦ ed ⟧ → T → T

substs : ∀ {ed} → substs-ret-t ⟦ ed ⟧
substs Γ = substh Γ empty-renamectxt

substs-term = substs {TERM}
substs-type = substs {TYPE}
substs-kind = substs {KIND}
substs-liftingType = substs {LIFTINGTYPE}
substs-tk = substs {TK}

substs-args : substs-ret-t args
substs-args Γ = substh-args Γ empty-renamectxt

substs-params : substs-ret-t params
substs-params Γ = substh-params Γ empty-renamectxt

subst-params-args : ∀ {ed} → ctxt → params → args → ⟦ ed ⟧ → ⟦ ed ⟧ × params × args
subst-params-args Γ (ParamsCons (Decl _ _ me x atk _) ps) (ArgsCons a as) t =
  subst-params-args Γ (substs-params Γ (trie-single x a) ps) as (subst Γ a x t)
subst-params-args Γ ps as t = t , ps , as


------------------------------------------------------------------------------
-- ABP auxiliary lemma
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Program.ABP.StrongerInductionPrinciple.LemmaI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the auxiliary lemma

module Helper where

  helper : ∀ {b i' is' os₁ os₂ as bs cs ds js} →
           Bit b →
           Fair os₂ →
           S b (i' ∷ is') os₁ os₂ as bs cs ds js →
           ∀ ft₁ os₁' → F*T ft₁ → Fair os₁' → os₁ ≡ ft₁ ++ os₁' →
           ∃[ js' ] js ≡ i' ∷ js'
  helper {b} {i'} {is'} {os₁} {os₂} {as} {bs} {cs} {ds} {js} Bb Fos₂
         (asS , bsS , csS , dsS , jsS)
         .(T ∷ []) os₁' f*tnil Fos₁' os₁-eq = js' , js-eq
    where
    os₁-eq-helper : os₁ ≡ T ∷ os₁'
    os₁-eq-helper = os₁              ≡⟨ os₁-eq ⟩
                    (T ∷ []) ++ os₁' ≡⟨ ++-∷ T [] os₁' ⟩
                    T ∷ ([] ++ os₁') ≡⟨ ∷-rightCong (++-leftIdentity os₁') ⟩
                    T ∷ os₁'         ∎

    as' : D
    as' = await b i' is' ds

    as-eq : as ≡ < i' , b > ∷ as'
    as-eq = trans asS (send-eq b i' is' ds)

    bs' : D
    bs' = corrupt os₁' · as'

    bs-eq : bs ≡ ok < i' , b > ∷ bs'
    bs-eq =
     bs ≡⟨ bsS ⟩
      corrupt os₁ · as
        ≡⟨ ·-rightCong as-eq ⟩
      corrupt os₁ · (< i' , b > ∷ as')
        ≡⟨ ·-leftCong (corruptCong os₁-eq-helper) ⟩
      corrupt (T ∷ os₁') · (< i' , b > ∷ as')
        ≡⟨ corrupt-T os₁' < i' , b > as' ⟩
      ok < i' , b > ∷ corrupt os₁' · as'
        ≡⟨ refl ⟩
      ok < i' , b > ∷ bs' ∎

    cs' : D
    cs' = ack (not b) · bs'

    js' : D
    js' = out (not b) · bs'

    js-eq : js ≡ i' ∷ js'
    js-eq = js                            ≡⟨ jsS ⟩
            out b · bs                    ≡⟨ ·-rightCong bs-eq ⟩
            out b · (ok < i' , b > ∷ bs') ≡⟨ out-ok≡ b b i' bs' refl ⟩
            i' ∷ out (not b) · bs'        ≡⟨ refl ⟩
            i' ∷ js'                      ∎

    ds' : D
    ds' = ds

  helper {b} {i'} {is'} {os₁} {os₂} {as} {bs} {cs} {ds} {js}
         Bb Fos₂ (asS , bsS , csS , dsS , jsS)
         .(F ∷ ft₁^) os₁' (f*tcons {ft₁^} FTft₁^) Fos₁' os₁-eq =
         helper Bb (tail-Fair Fos₂) ihS ft₁^ os₁' FTft₁^ Fos₁' refl

    where
    os₁^ : D
    os₁^ = ft₁^ ++ os₁'

    os₂^ : D
    os₂^ = tail₁ os₂

    os₁-eq-helper : os₁ ≡ F ∷ os₁^
    os₁-eq-helper = os₁                ≡⟨ os₁-eq ⟩
                    (F ∷ ft₁^) ++ os₁' ≡⟨ ++-∷ F ft₁^ os₁' ⟩
                    F ∷ ft₁^ ++ os₁'   ≡⟨ refl ⟩
                    F ∷ os₁^           ∎

    as^ : D
    as^ = await b i' is' ds

    as-eq : as ≡ < i' , b > ∷ as^
    as-eq = trans asS (send-eq b i' is' ds)

    bs^ : D
    bs^ = corrupt os₁^ · as^

    bs-eq : bs ≡ error ∷ bs^
    bs-eq =
      bs
        ≡⟨ bsS ⟩
      corrupt os₁ · as
        ≡⟨ ·-rightCong as-eq ⟩
      corrupt os₁ · (< i' , b > ∷ as^)
        ≡⟨ ·-leftCong (corruptCong os₁-eq-helper) ⟩
      corrupt (F ∷ os₁^) · (< i' , b > ∷ as^)
        ≡⟨ corrupt-F os₁^ < i' , b > as^ ⟩
      error ∷ corrupt os₁^ · as^
        ≡⟨ refl ⟩
      error ∷ bs^ ∎

    cs^ : D
    cs^ = ack b · bs^

    cs-eq : cs ≡ not b ∷ cs^
    cs-eq = cs                    ≡⟨ csS ⟩
            ack b · bs            ≡⟨ ·-rightCong bs-eq ⟩
            ack b · (error ∷ bs^) ≡⟨ ack-error b bs^ ⟩
            not b ∷ ack b · bs^   ≡⟨ refl ⟩
            not b ∷ cs^           ∎

    ds^ : D
    ds^ = corrupt os₂^ · cs^

    ds-eq-helper₁ : os₂ ≡ T ∷ tail₁ os₂ → ds ≡ ok (not b) ∷ ds^
    ds-eq-helper₁ h =
      ds                                 ≡⟨ dsS ⟩
      corrupt os₂ · cs                   ≡⟨ ·-rightCong cs-eq ⟩
      corrupt os₂ · (not b ∷ cs^)        ≡⟨ ·-leftCong (corruptCong h) ⟩
      corrupt (T ∷ os₂^) · (not b ∷ cs^) ≡⟨ corrupt-T os₂^ (not b) cs^ ⟩
      ok (not b) ∷ corrupt os₂^ · cs^    ≡⟨ refl ⟩
      ok (not b) ∷ ds^                   ∎

    ds-eq-helper₂ : os₂ ≡ F ∷ tail₁ os₂ → ds ≡ error ∷ ds^
    ds-eq-helper₂ h =
      ds                                 ≡⟨ dsS ⟩
      corrupt os₂ · cs                   ≡⟨ ·-rightCong cs-eq ⟩
      corrupt os₂ · (not b ∷ cs^)        ≡⟨ ·-leftCong (corruptCong h) ⟩
      corrupt (F ∷ os₂^) · (not b ∷ cs^) ≡⟨ corrupt-F os₂^ (not b) cs^ ⟩
      error ∷ corrupt os₂^ · cs^         ≡⟨ refl ⟩
      error ∷ ds^                        ∎

    ds-eq : ds ≡ ok (not b) ∷ ds^ ∨ ds ≡ error ∷ ds^
    ds-eq = case (λ h → inj₁ (ds-eq-helper₁ h))
                 (λ h → inj₂ (ds-eq-helper₂ h))
                 (head-tail-Fair Fos₂)

    as^-eq-helper₁ : ds ≡ ok (not b) ∷ ds^ → as^ ≡ send b · (i' ∷ is') · ds^
    as^-eq-helper₁ h =
      await b i' is' ds
        ≡⟨ awaitCong₄ h ⟩
      await b i' is' (ok (not b) ∷ ds^)
        ≡⟨ await-ok≢ b (not b) i' is' ds^ (x≢not-x Bb) ⟩
      < i' , b > ∷ await b i' is' ds^
        ≡⟨ sym (send-eq b i' is' ds^) ⟩
      send b · (i' ∷ is') · ds^ ∎

    as^-eq-helper₂ : ds ≡ error ∷ ds^ → as^ ≡ send b · (i' ∷ is') · ds^
    as^-eq-helper₂ h =
      await b i' is' ds               ≡⟨ awaitCong₄ h ⟩
      await b i' is' (error ∷ ds^)    ≡⟨ await-error b i' is' ds^ ⟩
      < i' , b > ∷ await b i' is' ds^ ≡⟨ sym (send-eq b i' is' ds^) ⟩
      send b · (i' ∷ is') · ds^     ∎

    as^-eq : as^ ≡ send b · (i' ∷ is') · ds^
    as^-eq = case as^-eq-helper₁ as^-eq-helper₂ ds-eq

    js-eq : js ≡ out b · bs^
    js-eq = js                    ≡⟨ jsS ⟩
            out b · bs            ≡⟨ ·-rightCong bs-eq ⟩
            out b · (error ∷ bs^) ≡⟨ out-error b bs^ ⟩
            out b · bs^ ∎

    ihS : S b (i' ∷ is') os₁^ os₂^ as^ bs^ cs^ ds^ js
    ihS = as^-eq , refl , refl , refl , js-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈ Fair
-- and hence by unfolding Fair, we conclude that there are ft₁ :  F*T
-- and os₁' : Fair, such that os₁ = ft₁ ++ os₁'.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma : ∀ {b i' is' os₁ os₂ as bs cs ds js} →
         Bit b →
         Fair os₁ →
         Fair os₂ →
         S b (i' ∷ is') os₁ os₂ as bs cs ds js →
         ∃[ js' ] js ≡ i' ∷ js'
lemma Bb Fos₁ Fos₂ s with Fair-out Fos₁
... | ft , os₁' , FTft , prf ,  Fos₁' = helper Bb Fos₂ s ft os₁' FTft Fos₁' prf


module Issue452 where

data Bool : Set where
  true false : Bool

data ⊥ : Set where

record ⊤ : Set where
  constructor tt

abstract

  id : Bool → Bool
  id b = b

If_then_else_ : Bool → Set → Set → Set
If true  then t else f = t
If false then t else f = f

data D : (b : Bool) → If b then ⊤ else ⊥ → Set where
  d : D (id true) _  -- this meta variable (type If (id true) ...) is unsolvable

foo : D true tt → ⊥
foo ()
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Rules/LHS/Unify.hs:402

{- Trying to unify

  D true tt = D (id true) _

true = id true is postponed, but then tt is handled of type

  If (id true)...

which is not a data or record type, causing the panic

Solution: do not postpone but fail, since in D : (b : Bool) -> X

  X depends on b

-}


module Sessions.Semantics.Process where

open import Level
open import Size
open import Data.Nat
open import Data.Sum
open import Data.Product
open import Data.Unit
open import Data.Bool
open import Debug.Trace

open import Function
open import Relation.Unary hiding (Empty)
open import Relation.Unary.PredicateTransformer using (PT)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import Sessions.Syntax.Types
open import Sessions.Syntax.Values
open import Sessions.Syntax.Expr

open import Sessions.Semantics.Commands

open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Allstar
open import Relation.Ternary.Separation.Construct.Market
open import Relation.Ternary.Separation.Construct.Product
open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Bigstar
open import Relation.Ternary.Separation.Monad.Free Cmd δ as Free hiding (step)
open import Relation.Ternary.Separation.Monad.State
open import Relation.Ternary.Separation.Monad.Error

open Monads using (Monad; str; typed-str)
open Monad {{...}}

data Exc : Set where
  outOfFuel : Exc
  delay     : Exc

open import Sessions.Semantics.Runtime delay
open import Sessions.Semantics.Communication delay

data Thread : Pred RCtx 0ℓ where
  forked :         ∀[ Comp unit ⇒ Thread ]
  main   : ∀ {a} → ∀[ Comp a ⇒ Thread ]

Pool : Pred RCtx 0ℓ
Pool = Bigstar Thread

St = Π₂ Pool ✴ Channels

open ExceptMonad {A = RCtx} Exc
open StateWithErr {C = RCtx} Exc

onPool : ∀ {P} → ∀[ (Pool ─✴ Except Exc (P ✴ Pool)) ⇒ State? St P ]
app (onPool f) (lift (snd pool ×⟨ σ , σ₁ ⟩ chs) k) (offerᵣ σ₂) with resplit σ₂ σ₁ k
... | _ , _ , τ₁ , τ₂ , τ₃ =
  case app f pool τ₁ of λ where
    (error e) → partial (inj₁ e)
    (✓ (p ×⟨ σ₃ ⟩ p')) →
      let _ , _ , τ₄ , τ₅ , τ₆ = resplit σ₃ τ₂ τ₃
      in return (inj p ×⟨ offerᵣ τ₄ ⟩ lift (snd p' ×⟨ σ , τ₅ ⟩ chs) τ₆)

onChannels : ∀ {P} → ∀[ State? Channels P ⇒ State? St P ]
app (onChannels f) μ (offerᵣ σ₃) with ○≺●ᵣ μ
... | inj pool ×⟨ offerᵣ σ₄ ⟩ chs with ⊎-assoc σ₃ (⊎-comm σ₄)
... | _ , τ₁ , τ₂ = do
  px ×⟨ σ₄ ⟩ ●chs ×⟨ σ₅ ⟩ inj pool ←
    mapM (app f chs (offerᵣ τ₁) &⟨ J Pool ∥ offerₗ τ₂ ⟩ inj pool) ✴-assocᵣ
  return (px ×⟨ σ₄ ⟩ app (○≺●ₗ pool) ●chs (⊎-comm σ₅))

enqueue : ∀[ Thread ⇒ State? St Emp ]
enqueue thr =
  onPool (wand λ pool σ → return (empty ×⟨ ⊎-idˡ ⟩ (app (append thr) pool σ)))

-- Smart reschedule of a thread:
-- Escalates out-of-fuel erros in threads, and discards terminated workers.
reschedule : ∀[ Thread ⇒ State? St Emp ]

reschedule (forked (partial (pure (inj₁ _))))  = raise outOfFuel
reschedule (forked (partial (pure (inj₂ tt)))) = return empty
reschedule thr@(forked (partial (impure _)))   = enqueue thr

reschedule (main (partial (pure (inj₁ _))))     = raise outOfFuel
reschedule thr@(main (partial (pure (inj₂ _)))) = enqueue thr
reschedule thr@(main (partial (impure _)))      = enqueue thr

{- Select the next thread that is not done -}
dequeue : ε[ State? St (Emp ∪ Thread) ]
dequeue =
  onPool (wandit (λ pool →
    case (find isImpure pool) of λ where
      (error e)              → return (inj₁ empty ×⟨ ⊎-idˡ ⟩ pool)
      (✓ (thr ×⟨ σ ⟩ pool')) → return (inj₂ thr ×⟨ σ ⟩ pool')))
  where
    isImpure : ∀ {Φ} → Thread Φ → Bool
    isImpure (main   (partial (pure _)))   = false
    isImpure (main   (partial (impure _))) = true
    isImpure (forked (partial (pure _)))   = false
    isImpure (forked (partial (impure _))) = true

module _ where

  handle : ∀ {Φ} → (c : Cmd Φ) → State? St (δ c) Φ
  handle (fork thr)           = trace "handle:fork"   $ enqueue (forked thr)
  handle (mkchan α)           = trace "handle:mkchan" $ onChannels newChan
  handle (send (ch ×⟨ σ ⟩ v)) = trace "handle:send"   $ onChannels (app (send! ch) v σ)
  handle (receive ch)         = trace "handle:recv"   $ onChannels (receive? ch)
  handle (close ch)           = trace "handle:close"  $ onChannels (closeChan ch)

  step : ∀[ Thread ⇒ State? St Thread ]
  step thr@(main (partial c))   = do
    c' ← Free.step handle c
    return (main (partial c'))
  step (forked (partial c)) = do
    c' ← Free.step handle c
    return (forked (partial c'))

  -- try the first computation; if it fails with a 'delay' exception,
  -- then queue t
  _orDelay_ : ∀[ State? St Emp ⇒ Thread ⇒ State? St Emp ]
  c orDelay t = do
    c orElse λ where
      delay     → enqueue t
      outOfFuel → raise outOfFuel

  -- Run a pool of threads in round-robing fashion
  -- until all have terminated, or fuel runs out
  run : ℕ → ε[ State? St Emp ]
  run zero    = raise outOfFuel
  run (suc n) = do
    inj₂ thr ← dequeue
      -- if we cannot dequeue a thunked thread, we're done
      where (inj₁ e) → return e

    -- otherwise we take a step
    empty ← trace "run:step" (do thr' ← step thr; enqueue thr') orDelay thr

    -- rinse and repeat
    run n

  start : ℕ → Thread ε → ∃ λ Φ → Except Exc (● St) Φ
  start n thr = -, do
    let μ = lift (snd [ thr ] ×⟨ ⊎-idʳ ⟩ nil) ⊎-idʳ
    inj empty ×⟨ σ ⟩ μ ← app (run n) μ (offerᵣ ⊎-idˡ)
    case ⊎-id⁻ˡ σ of λ where
      refl → return μ

    where open ExceptMonad {A = Market RCtx} Exc


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term

import Parametric.Syntax.MType as MType
import Parametric.Syntax.MTerm as MTerm

import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Denotation.MValue as MValue
import Parametric.Denotation.CachingMValue as CachingMValue
import Parametric.Denotation.MEvaluation as MEvaluation

module Parametric.Denotation.CachingMEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ValConst : MTerm.ValConstStructure Const)
    (CompConst : MTerm.CompConstStructure Const)
    (cbnToCompConst : MTerm.CbnToCompConstStructure Const CompConst)
    (cbvToCompConst : MTerm.CbvToCompConstStructure Const CompConst)
    -- I should really switch to records - can it get sillier than this? More
    -- precisely, this is the kind of thing ML functors are designed to replace.
    -- They have also subtyping --- not sure whether that's good or bad.
    (⟦_⟧ValBase : MEvaluation.ValStructure Const ⟦_⟧Base ValConst CompConst cbnToCompConst cbvToCompConst)
    (⟦_⟧CompBase : MEvaluation.CompStructure Const ⟦_⟧Base ValConst CompConst cbnToCompConst cbvToCompConst)
    (ΔBase : CachingMValue.Structure Base ⟦_⟧Base)
  where

open Type.Structure Base
open Term.Structure Base Const

open MType.Structure Base
open MTerm.Structure Const ValConst CompConst cbnToCompConst cbvToCompConst

open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open MValue.Structure Base ⟦_⟧Base
open CachingMValue.Structure Base ⟦_⟧Base ΔBase
open MEvaluation.Structure Const ⟦_⟧Base ValConst CompConst cbnToCompConst cbvToCompConst ⟦_⟧ValBase ⟦_⟧CompBase

open import Base.Denotation.Notation

-- Extension Point: Evaluation of constants.
ValStructure : Set
ValStructure = ∀ {τ} → ValConst τ → ⟦ τ ⟧ValTypeHidCache

CompStructure : Set
CompStructure = ∀ {τ} → CompConst τ → ⟦ τ ⟧CompTypeHidCache

module Structure
       (⟦_⟧ValBaseTermCache  : ValStructure)
       (⟦_⟧CompBaseTermCache : CompStructure)
    where

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Unit

  -- Defining a caching semantics for Term proves to be hard, requiring to
  -- insert and remove caches where we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use positive/value products (i.e. pattern-match products),
  -- not negative/computation products (i.e. projection products).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache
  ⟦_⟧ValsTermCache : ∀ {Γ Σ} → Vals Γ Σ → ⟦ Γ ⟧ValCtxHidCache → ⟦ Σ ⟧ValCtxHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVarHidCache)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- Copy of ⟦_⟧Vals
  ⟦ ∅ ⟧ValsTermCache ρ = ∅
  ⟦ vt • valtms ⟧ValsTermCache ρ = ⟦ vt ⟧ValTermCache ρ • ⟦ valtms ⟧ValsTermCache ρ

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVarHidCache ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ
  -- No caching, because the arguments are values, so evaluating them does not
  -- produce intermediate results.
  ⟦ vConst c ⟧ValTermCache ρ = ⟦ c ⟧ValBaseTermCache

  -- The only caching is done by the interpretation of the constant (because the
  -- arguments are values so need no caching).
  ⟦_⟧CompTermCache (cConst c) ρ = ⟦ c ⟧CompBaseTermCache

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. In fact, one could use
  -- monads directly, but that does not deal with arity satisfactorily.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- A function can invoke, in tail position, either a `cReturn` directly, or
  -- invoke another function. In the latter case, we need to ensure that the
  -- return value of the other function is not forwarded directly, but that
  -- further intermediate results from the current function are also recorded.
  --
  -- At one time, `f1 into cReturn` did this correctly, but `f1` didn't, while
  -- instead, they should be equivalent. In other words, we want `_into_` to
  -- satisfy the monadic laws for bind.

  {-
  -- Here we'd have a problem with the original `_into_` constructor from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".
  --
  -- If we tried supporting it, we could try to write something like:

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- However, the code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- Instead, we use a restricted CBPV, where these two possibilities are forbidden.
  -- If you want to save something between different lambdas, you need to add an
  -- F U to reflect that. (Double-check the papers which show how to encode
  -- arity using CBPV, it seems that they should find the same problem ---
  -- XXX they don't).
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (τ₁ v× τ₂ v× σ) , (r₂ ,′ (c₁ ,′ c₂  ,′ r₁))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. XXX: We should just reuse
  -- HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ = λ x → ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

  ⟦_⟧TermCacheCBV : ∀ {τ Γ} → Term Γ τ → ⟦ fromCBVCtx Γ ⟧ValCtxHidCache → ⟦ cbvToCompType τ ⟧CompTypeHidCache
  ⟦ t ⟧TermCacheCBV = ⟦ fromCBV t ⟧CompTermCache

  module _ (ι : Base) where
    Γ : ValContext
    Γ = ∅
    σ = B ι
    τ = B ι
    f : Comp Γ (σ ⇛ F τ)
    f = cAbs (cReturn (vVar vThis))

    bar : ⟦ σ ⇛ F τ ⟧CompTypeHidCache
    bar = ⟦ f ⟧CompTermCache ∅

    open import Relation.Binary.PropositionalEquality
    bar≡ : bar ≡ (λ x → vUnit , x , tt)
    bar≡ = refl

    dbar : ⟦ σ ⇛ F τ ⟧ΔCompType
    dbar = λ dx → vUnit , λ c₀ → (dx , c₀)

    barbaz : ⟦ base ι ⟧Type → ⟦ ΔBase ι ⟧Type → ⟦ base ι ⟧Type × ⟦ ΔBase ι ⟧Type
    barbaz x dx =
      let
          (τ₁ , y , c₁) = bar x
          (τ₂ , dbar′) = dbar dx
          (dy , c₂) = dbar′ c₁
      in y , dy
    module _ (f : ⟦ σ ⇛ F τ ⟧CompTypeHidCache) (df : ⟦ σ ⇛ F τ ⟧ΔCompType)
      (proof : ∀ x dx → proj₁ (f x) ≡ proj₁ (df dx)) where

      -- fdf₁ : ⟦ base ι ⟧Type → ⟦ ΔBase ι ⟧Type → ⟦ base ι ⟧Type × ⟦ ΔBase ι ⟧Type
      -- fdf₁ x dx =
      --   let
      --     (τ₁ , y , c₁) = f x
      --     (τ₂ , dbar′) = df dx
      --     --(dy , c₂) = dbar′ c₁ -- fails, as it should be expected!
      --   in y , dy

      fdf : ⟦ base ι ⟧Type → ⟦ ΔBase ι ⟧Type → ⟦ base ι ⟧Type × ⟦ ΔBase ι ⟧Type
      fdf x dx with proof x dx
      ... | p =
        let
          (τ₁ , y , c₁) = f x
          (τ₂ , dbar′) = df dx
          (dy , c₂) = dbar′ (subst ⟦_⟧ValTypeHidCache p c₁) --
        in y , dy


module Tactic.Reflection.Equality where

open import Prelude
open import Builtin.Reflection
open import Builtin.Float

instance
  EqVisibility : Eq Visibility
  _==_ {{EqVisibility}} visible  visible  = yes refl
  _==_ {{EqVisibility}} visible  hidden   = no (λ ())
  _==_ {{EqVisibility}} visible  instance′ = no (λ ())
  _==_ {{EqVisibility}} hidden   visible  = no (λ ())
  _==_ {{EqVisibility}} hidden   hidden   = yes refl
  _==_ {{EqVisibility}} hidden   instance′ = no (λ ())
  _==_ {{EqVisibility}} instance′ visible  = no (λ ())
  _==_ {{EqVisibility}} instance′ hidden   = no (λ ())
  _==_ {{EqVisibility}} instance′ instance′ = yes refl

  EqRelevance : Eq Relevance
  _==_ {{EqRelevance}} relevant   relevant   = yes refl
  _==_ {{EqRelevance}} relevant   irrelevant = no (λ ())
  _==_ {{EqRelevance}} irrelevant relevant   = no (λ ())
  _==_ {{EqRelevance}} irrelevant irrelevant = yes refl

  EqArgInfo : Eq ArgInfo
  _==_ {{EqArgInfo}} (arg-info v r) (arg-info v₁ r₁) =
    decEq₂ arg-info-inj₁ arg-info-inj₂ (v == v₁) (r == r₁)

  EqArg : ∀ {A} {{EqA : Eq A}} → Eq (Arg A)
  _==_ {{EqArg}} (arg i x) (arg i₁ x₁) = decEq₂ arg-inj₁ arg-inj₂ (i == i₁) (x == x₁)

  EqLiteral : Eq Literal
  _==_ {{EqLiteral}} = eqLit
    where
      eqLit : (x y : Literal) → Dec (x ≡ y)
      eqLit (nat    x) (nat    y) = decEq₁ nat-inj    (x == y)
      eqLit (word64 x) (word64 y) = decEq₁ word64-inj (x == y)
      eqLit (float  x) (float  y) = decEq₁ float-inj  (x == y)
      eqLit (char   x) (char   y) = decEq₁ char-inj   (x == y)
      eqLit (string x) (string y) = decEq₁ string-inj (x == y)
      eqLit (name   x) (name   y) = decEq₁ name-inj   (x == y)
      eqLit (meta   x) (meta   y) = decEq₁ meta-inj   (x == y)

      eqLit (nat    _) (float  _) = no λ()
      eqLit (nat    _) (word64 _) = no λ()
      eqLit (nat    _) (char   _) = no λ()
      eqLit (nat    _) (string _) = no λ()
      eqLit (nat    _) (name   _) = no λ()
      eqLit (nat    _) (meta   _) = no λ()
      eqLit (word64 _) (nat    _) = no λ()
      eqLit (word64 _) (float  _) = no λ()
      eqLit (word64 _) (char   _) = no λ()
      eqLit (word64 _) (string _) = no λ()
      eqLit (word64 _) (name   _) = no λ()
      eqLit (word64 _) (meta   _) = no λ()
      eqLit (float  _) (nat    _) = no λ()
      eqLit (float  _) (word64 _) = no λ()
      eqLit (float  _) (char   _) = no λ()
      eqLit (float  _) (string _) = no λ()
      eqLit (float  _) (name   _) = no λ()
      eqLit (float  _) (meta   _) = no λ()
      eqLit (char   _) (nat    _) = no λ()
      eqLit (char   _) (word64 _) = no λ()
      eqLit (char   _) (float  _) = no λ()
      eqLit (char   _) (string _) = no λ()
      eqLit (char   _) (name   _) = no λ()
      eqLit (char   _) (meta   _) = no λ()
      eqLit (string _) (nat    _) = no λ()
      eqLit (string _) (word64 _) = no λ()
      eqLit (string _) (float  _) = no λ()
      eqLit (string _) (char   _) = no λ()
      eqLit (string _) (name   _) = no λ()
      eqLit (string _) (meta   _) = no λ()
      eqLit (name   _) (nat    _) = no λ()
      eqLit (name   _) (word64 _) = no λ()
      eqLit (name   _) (float  _) = no λ()
      eqLit (name   _) (char   _) = no λ()
      eqLit (name   _) (string _) = no λ()
      eqLit (name   _) (meta   _) = no λ()
      eqLit (meta   _) (nat    _) = no λ()
      eqLit (meta   _) (word64 _) = no λ()
      eqLit (meta   _) (float  _) = no λ()
      eqLit (meta   _) (char   _) = no λ()
      eqLit (meta   _) (string _) = no λ()
      eqLit (meta   _) (name   _) = no λ()

private
  eqSort   : (x y : Sort)    → Dec (x ≡ y)
  eqTerm   : (x y : Term)    → Dec (x ≡ y)
  eqPat    : (x y : Pattern) → Dec (x ≡ y)
  eqClause : (x y : Clause)  → Dec (x ≡ y)

  eqArgTerm : (x y : Arg Term) → Dec (x ≡ y)
  eqArgTerm (arg i x) (arg i₁ x₁) = decEq₂ arg-inj₁ arg-inj₂ (i == i₁) (eqTerm x x₁)

  eqArgPat : (x y : Arg Pattern) → Dec (x ≡ y)
  eqArgPat (arg i x) (arg i₁ x₁) = decEq₂ arg-inj₁ arg-inj₂ (i == i₁) (eqPat x x₁)

  eqAbsTerm : (x y : Abs Term) → Dec (x ≡ y)
  eqAbsTerm (abs s x) (abs s₁ x₁) = decEq₂ abs-inj₁ abs-inj₂ (s == s₁) (eqTerm x x₁)

  eqPats : (x y : List (Arg Pattern)) → Dec (x ≡ y)
  eqPats [] [] = yes refl
  eqPats [] (x ∷ xs) = no λ ()
  eqPats (x ∷ xs) [] = no λ ()
  eqPats (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eqArgPat x y) (eqPats xs ys)

  eqArgs : (x y : List (Arg Term)) → Dec (x ≡ y)
  eqArgs [] [] = yes refl
  eqArgs [] (x ∷ xs) = no λ ()
  eqArgs (x ∷ xs) [] = no λ ()
  eqArgs (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eqArgTerm x y) (eqArgs xs ys)

  eqClauses : (x y : List Clause) → Dec (x ≡ y)
  eqClauses [] [] = yes refl
  eqClauses [] (x ∷ xs) = no λ ()
  eqClauses (x ∷ xs) [] = no λ ()
  eqClauses (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eqClause x y) (eqClauses xs ys)

  eqTerm (var x args) (var x₁ args₁) = decEq₂ var-inj₁ var-inj₂ (x == x₁) (eqArgs args args₁)
  eqTerm (con c args) (con c₁ args₁) = decEq₂ con-inj₁ con-inj₂ (c == c₁) (eqArgs args args₁)
  eqTerm (def f args) (def f₁ args₁) = decEq₂ def-inj₁ def-inj₂ (f == f₁) (eqArgs args args₁)
  eqTerm (meta x args) (meta x₁ args₁) = decEq₂ meta-inj₁ meta-inj₂ (x == x₁) (eqArgs args args₁)
  eqTerm (lam v x) (lam v₁ y) = decEq₂ lam-inj₁ lam-inj₂ (v == v₁) (eqAbsTerm x y)
  eqTerm (pi t₁ t₂) (pi t₃ t₄) = decEq₂ pi-inj₁ pi-inj₂ (eqArgTerm t₁ t₃) (eqAbsTerm t₂ t₄)
  eqTerm (agda-sort x) (agda-sort x₁) = decEq₁ sort-inj (eqSort x x₁)
  eqTerm (lit l) (lit l₁)   = decEq₁ lit-inj (l == l₁)
  eqTerm (pat-lam c args) (pat-lam c₁ args₁) = decEq₂ pat-lam-inj₁ pat-lam-inj₂ (eqClauses c c₁) (eqArgs args args₁)
  eqTerm unknown unknown = yes refl

  eqTerm (var x args) (con c args₁) = no λ ()
  eqTerm (var x args) (def f args₁) = no λ ()
  eqTerm (var x args) (lam v y) = no λ ()
  eqTerm (var x args) (pi t₁ t₂) = no λ ()
  eqTerm (var x args) (agda-sort x₁) = no λ ()
  eqTerm (var x args) (lit x₁) = no λ ()
  eqTerm (var x args) unknown = no λ ()
  eqTerm (con c args) (var x args₁) = no λ ()
  eqTerm (con c args) (def f args₁) = no λ ()
  eqTerm (con c args) (lam v y) = no λ ()
  eqTerm (con c args) (pi t₁ t₂) = no λ ()
  eqTerm (con c args) (agda-sort x) = no λ ()
  eqTerm (con c args) (lit x) = no λ ()
  eqTerm (con c args) unknown = no λ ()
  eqTerm (def f args) (var x args₁) = no λ ()
  eqTerm (def f args) (con c args₁) = no λ ()
  eqTerm (def f args) (lam v y) = no λ ()
  eqTerm (def f args) (pi t₁ t₂) = no λ ()
  eqTerm (def f args) (agda-sort x) = no λ ()
  eqTerm (def f args) (lit x) = no λ ()
  eqTerm (def f args) unknown = no λ ()
  eqTerm (lam v x) (var x₁ args) = no λ ()
  eqTerm (lam v x) (con c args) = no λ ()
  eqTerm (lam v x) (def f args) = no λ ()
  eqTerm (lam v x) (pi t₁ t₂) = no λ ()
  eqTerm (lam v x) (agda-sort x₁) = no λ ()
  eqTerm (lam v x) (lit x₁) = no λ ()
  eqTerm (lam v x) unknown = no λ ()
  eqTerm (pi t₁ t₂) (var x args) = no λ ()
  eqTerm (pi t₁ t₂) (con c args) = no λ ()
  eqTerm (pi t₁ t₂) (def f args) = no λ ()
  eqTerm (pi t₁ t₂) (lam v y) = no λ ()
  eqTerm (pi t₁ t₂) (agda-sort x) = no λ ()
  eqTerm (pi t₁ t₂) (lit x) = no λ ()
  eqTerm (pi t₁ t₂) unknown = no λ ()
  eqTerm (agda-sort x) (var x₁ args) = no λ ()
  eqTerm (agda-sort x) (con c args) = no λ ()
  eqTerm (agda-sort x) (def f args) = no λ ()
  eqTerm (agda-sort x) (lam v y) = no λ ()
  eqTerm (agda-sort x) (pi t₁ t₂) = no λ ()
  eqTerm (agda-sort x) (lit x₁) = no λ ()
  eqTerm (agda-sort x) unknown = no λ ()
  eqTerm (lit x) (var x₁ args) = no λ ()
  eqTerm (lit x) (con c args) = no λ ()
  eqTerm (lit x) (def f args) = no λ ()
  eqTerm (lit x) (lam v y) = no λ ()
  eqTerm (lit x) (pi t₁ t₂) = no λ ()
  eqTerm (lit x) (agda-sort x₁) = no λ ()
  eqTerm (lit x) unknown = no λ ()
  eqTerm unknown (var x args) = no λ ()
  eqTerm unknown (con c args) = no λ ()
  eqTerm unknown (def f args) = no λ ()
  eqTerm unknown (lam v y) = no λ ()
  eqTerm unknown (pi t₁ t₂) = no λ ()
  eqTerm unknown (agda-sort x) = no λ ()
  eqTerm unknown (lit x) = no λ ()

  eqTerm (var _ _) (meta _ _) = no λ ()
  eqTerm (con _ _) (meta _ _) = no λ ()
  eqTerm (def _ _) (meta _ _) = no λ ()
  eqTerm (lam _ _) (meta _ _) = no λ ()
  eqTerm (pi _ _) (meta _ _) = no λ ()
  eqTerm (agda-sort _) (meta _ _) = no λ ()
  eqTerm (lit _) (meta _ _) = no λ ()
  eqTerm unknown (meta _ _) = no λ ()
  eqTerm (meta _ _) (var _ _) = no λ ()
  eqTerm (meta _ _) (con _ _) = no λ ()
  eqTerm (meta _ _) (def _ _) = no λ ()
  eqTerm (meta _ _) (lam _ _) = no λ ()
  eqTerm (meta _ _) (pi _ _) = no λ ()
  eqTerm (meta _ _) (agda-sort _) = no λ ()
  eqTerm (meta _ _) (lit _) = no λ ()
  eqTerm (meta _ _) unknown = no λ ()

  eqTerm (var _ _) (pat-lam _ _) = no λ ()
  eqTerm (con _ _) (pat-lam _ _) = no λ ()
  eqTerm (def _ _) (pat-lam _ _) = no λ ()
  eqTerm (lam _ _) (pat-lam _ _) = no λ ()
  eqTerm (pi _ _) (pat-lam _ _) = no λ ()
  eqTerm (meta _ _) (pat-lam _ _) = no λ ()
  eqTerm (agda-sort _) (pat-lam _ _) = no λ ()
  eqTerm (lit _) (pat-lam _ _) = no λ ()
  eqTerm unknown (pat-lam _ _) = no λ ()
  eqTerm (pat-lam _ _) (var _ _) = no λ ()
  eqTerm (pat-lam _ _) (con _ _) = no λ ()
  eqTerm (pat-lam _ _) (def _ _) = no λ ()
  eqTerm (pat-lam _ _) (lam _ _) = no λ ()
  eqTerm (pat-lam _ _) (pi _ _) = no λ ()
  eqTerm (pat-lam _ _) (meta _ _) = no λ ()
  eqTerm (pat-lam _ _) (agda-sort _) = no λ ()
  eqTerm (pat-lam _ _) (lit _) = no λ ()
  eqTerm (pat-lam _ _) unknown = no λ ()

  eqSort (set t) (set t₁) = decEq₁ set-inj (eqTerm t t₁)
  eqSort (lit n) (lit n₁) = decEq₁ slit-inj (n == n₁)
  eqSort unknown unknown = yes refl
  eqSort (set t) (lit n) = no λ ()
  eqSort (set t) unknown = no λ ()
  eqSort (lit n) (set t) = no λ ()
  eqSort (lit n) unknown = no λ ()
  eqSort unknown (set t) = no λ ()
  eqSort unknown (lit n) = no λ ()

  eqPat (con c ps) (con c₁ ps₁) = decEq₂ pcon-inj₁ pcon-inj₂ (c == c₁) (eqPats ps ps₁)
  eqPat  dot        dot         = yes refl
  eqPat (var s)    (var s₁)     = decEq₁ pvar-inj (s == s₁)
  eqPat (lit l)    (lit l₁)     = decEq₁ plit-inj (l == l₁)
  eqPat (proj f)   (proj f₁)    = decEq₁ proj-inj (f == f₁)
  eqPat  absurd     absurd      = yes refl

  eqPat (con _ _) dot      = no λ ()
  eqPat (con _ _) (var _)  = no λ ()
  eqPat (con _ _) (lit _)  = no λ ()
  eqPat (con _ _) (proj _) = no λ ()
  eqPat (con _ _) absurd   = no λ ()

  eqPat dot (con _ _) = no λ ()
  eqPat dot (var _)   = no λ ()
  eqPat dot (lit _)   = no λ ()
  eqPat dot (proj _)  = no λ ()
  eqPat dot absurd    = no λ ()

  eqPat (var _) (con _ _) = no λ ()
  eqPat (var _) dot       = no λ ()
  eqPat (var _) (lit _)   = no λ ()
  eqPat (var _) (proj _)  = no λ ()
  eqPat (var _) absurd    = no λ ()

  eqPat (lit _) (con _ _) = no λ ()
  eqPat (lit _) dot       = no λ ()
  eqPat (lit _) (var _)   = no λ ()
  eqPat (lit _) (proj _)  = no λ ()
  eqPat (lit _) absurd    = no λ ()

  eqPat (proj _) (con _ _) = no λ ()
  eqPat (proj _) dot       = no λ ()
  eqPat (proj _) (var _)   = no λ ()
  eqPat (proj _) (lit _)   = no λ ()
  eqPat (proj _) absurd    = no λ ()

  eqPat absurd (con _ _) = no λ ()
  eqPat absurd dot       = no λ ()
  eqPat absurd (var _)   = no λ ()
  eqPat absurd (lit _)   = no λ ()
  eqPat absurd (proj _)  = no λ ()

  eqClause (clause ps t)      (clause ps₁ t₁)     = decEq₂ clause-inj₁ clause-inj₂ (eqPats ps ps₁) (eqTerm t t₁)
  eqClause (absurd-clause ps) (absurd-clause ps₁) = decEq₁ absurd-clause-inj (eqPats ps ps₁)
  eqClause (clause _ _) (absurd-clause _) = no λ ()
  eqClause (absurd-clause _) (clause _ _) = no λ ()

instance
  EqTerm : Eq Term
  _==_ {{EqTerm}} = eqTerm

  EqSort : Eq Sort
  _==_ {{EqSort}} = eqSort

  EqClause : Eq Clause
  _==_ {{EqClause}} = eqClause

  EqPattern : Eq Pattern
  _==_ {{EqPattern}} = eqPat


import cedille-options
open import general-util

module untyped-spans (options : cedille-options.options) {F : Set → Set} ⦃ monadF : monad F ⦄ where

open import ctxt
open import cedille-types
open import constants
open import conversion
open import free-vars
open import rename
open import spans options {F} ⦃ monadF ⦄
open import subst
open import syntax-util
open import to-string options
open import type-util
open import elab-util options

{-# TERMINATING #-}
untyped-term : ctxt → ex-tm → spanM term
untyped-type : ctxt → ex-tp → spanM type
untyped-kind : ctxt → ex-kd → spanM kind
untyped-tpkd : ctxt → ex-tk → spanM tpkd
untyped-arg : ctxt → ex-arg → spanM arg
untyped-args : ctxt → ex-args → spanM args
untyped-let : ctxt → ex-def → erased? → posinfo → posinfo → spanM (ctxt × var × tagged-val × (∀ {ed : exprd} → ⟦ ed ⟧ → ⟦ ed ⟧) × (term → term))
untyped-cases : ctxt → ex-cases → renamectxt → spanM cases
untyped-case : ctxt → ex-case → (siblings : ℕ) → (ℕ → err-m) → renamectxt → spanM (case × (ℕ → err-m) × maybe ℕ)

untyped-let Γ (ExDefTerm pi x Tₑ? t) e? fm to =
  maybe-map (untyped-type Γ) Tₑ? >>=? λ Tₑ?~ →
  untyped-term Γ t >>= λ t~ →
  elim-pair (compileFail-in Γ t~) λ tvs e →
  let Tₑ~ = maybe-else' Tₑ?~ (TpHole pi) id in
  [- Var-span (Γ , pi - x :` Tkt Tₑ~) pi x untyped tvs e -]
  return
    (ctxt-term-def pi localScope opacity-open x (just t~) Tₑ~ Γ ,
     pi % x ,
     binder-data Γ pi x (Tkt Tₑ~) e? (just t~) fm to ,
     (λ {ed} T' → [ Γ - t~ / (pi % x) ] T') ,
     (λ t' → LetTm e? x nothing t~ ([ Γ - Var x / (pi % x) ] t')))

untyped-let Γ (ExDefType pi x k T) e? fm to =
  untyped-kind Γ k >>= λ k~ →
  untyped-type Γ T >>= λ T~ →
  [- TpVar-span (Γ , pi - x :` Tkk k~) pi x untyped [] nothing -]
  return
    (ctxt-type-def pi localScope opacity-open x (just T~) k~ Γ ,
     pi % x ,
     binder-data Γ pi x (Tkk k~) e? (just T~) fm to ,
     (λ {ed} T' → [ Γ - T~ / (pi % x) ] T') ,
     (λ t' → LetTp x k~ T~ ([ Γ - TpVar x / (pi % x) ] t')))

untyped-term Γ (ExApp t e t') =
  [- App-span tt (term-start-pos t) (term-end-pos t') untyped [] nothing -]
  untyped-term Γ t >>= λ t~ →
  untyped-term Γ t' >>= λ t'~ →
  return (if e then t~ else App t~ t'~)

untyped-term Γ (ExAppTp t T) =
  [- AppTp-span tt (term-start-pos t) (type-end-pos T) untyped [] nothing -]
  untyped-type Γ T >>= λ T~ →
  untyped-term Γ t

untyped-term Γ (ExBeta pi t? t?') =
  maybe-map (λ {(PosTm t pi) → untyped-term Γ t}) t? >>=? λ t?~ →
  maybe-map (λ {(PosTm t pi) → untyped-term Γ t}) t?' >>=? λ t?'~ →
  [- Beta-span pi (term-end-pos (ExBeta pi t? t?')) untyped [] nothing -]
  return (maybe-else' t?'~ id-term id)

untyped-term Γ (ExChi pi T? t) =
  maybe-map (untyped-type Γ) T? >>=? λ T?~ →
  [- Chi-span Γ pi T?~ t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExDelta pi T? t) =
  [- Delta-span pi t untyped [] nothing -]
  maybe-map (untyped-type Γ) T? >>=? λ T?~ →
  untyped-term Γ t >>= λ t~ →
  return id-term

untyped-term Γ (ExEpsilon pi lr -? t) =
  [- Epsilon-span pi lr -? t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExHole pi) =
  [- hole-span Γ pi nothing untyped [] -]
  return (Hole pi)

untyped-term Γ (ExIotaPair pi t₁ t₂ Tₘ? pi') =
  let tv-f = λ {(ExGuide pi'' x Tₘ) →
               [ binder-data Γ pi'' x (Tkt (TpHole pi'')) ff nothing
                   (type-start-pos Tₘ) (type-end-pos Tₘ) ]} in
  [- IotaPair-span pi pi' untyped (maybe-else' Tₘ? [] tv-f) nothing -]
  untyped-term Γ t₁ >>= λ t₁~ →
  untyped-term Γ t₂ >>= λ t₂~ →
  maybe-map (λ {(ExGuide pi'' x Tₘ) →
    untyped-type (ctxt-term-decl pi'' x (TpHole pi'') Γ) Tₘ}) Tₘ? >>=? λ Tₘ?~ →
  return t₁~

untyped-term Γ (ExIotaProj t n pi) =
  [- IotaProj-span t pi untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExLam pi e pi' x tk? t) =
  (return tk? on-fail return (Tkt (TpHole pi')) >>=m untyped-tpkd Γ) >>= λ tk~ →
  untyped-term (Γ , pi' - x :` tk~) t >>= λ t~ →
  let eₖ? = tk? >>= λ _ → ifMaybej (tk-is-type tk~ && ~ e)
                             "λ-terms must bind a term, not a type (use Λ instead)"
      eₑ? = ifMaybej (e && is-free-in (pi' % x) (erase t~))
               "The Λ-bound variable occurs free in the erasure of the body" in
  [- var-span e (Γ , pi' - x :` tk~) pi' x untyped tk~ eₑ? -]
  [- Lam-span Γ untyped pi pi' e x tk~ t [] eₖ? -]
  return (if e then t~ else Lam ff x nothing ([ Γ - Var x / (pi' % x) ] t~))

untyped-term Γ (ExLet pi e? d t) =
  untyped-let Γ d e? (term-start-pos t) (term-end-pos t) >>= λ where
    (Γ' , x , tv , σ , f) →
      untyped-term Γ' t >>= λ t~ →
      [- punctuation-span "Parens (let)" pi (term-end-pos t) -]
      [- Let-span e? pi (term-end-pos t) untyped []
           (ifMaybej (e? && is-free-in x t~)
             (unqual-local x ^ "occurs free in the body of the term")) -]
      return (if is-free-in x t~ then f t~ else t~)

untyped-term Γ (ExOpen pi o pi' x t) =
  [- Var-span Γ pi' x untyped [ not-for-navigation ] nothing -]
  [- Open-span o pi x t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExParens pi t pi') =
  [- punctuation-span "Parens (term)" pi pi' -]
  untyped-term Γ t

untyped-term Γ (ExPhi pi t₌ t₁ t₂ pi') =
  [- Phi-span pi pi' untyped [] nothing -]
  untyped-term Γ t₌ >>
  untyped-term Γ t₁ >>
  untyped-term Γ t₂

untyped-term Γ (ExRho pi ρ+? ρ<ns>? t₌ Tₘ? t) =
  [- Rho-span pi t₌ t untyped ρ+?
       (maybe-else' Tₘ? (inj₁ 1) λ {(ExGuide pi' x Tₘ) → inj₂ x}) [] nothing -]
  untyped-term Γ t₌ >>
  maybe-map (λ {(ExGuide pi' x Tₘ) →
                  untyped-type (ctxt-var-decl-loc pi' x Γ) Tₘ}) Tₘ? >>=? λ Tₘ?~ →
  untyped-term Γ t

untyped-term Γ (ExVarSigma pi t) =
  [- VarSigma-span pi t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExTheta pi θ t ts) =
  [- Theta-span Γ pi θ t ts untyped [] nothing -]
  untyped-term Γ t >>= λ t~ →
  untyped-args Γ (map (λ {(Lterm e t) → ExTmArg e t}) ts) >>= λ as~ →
  return (recompose-apps (map Arg (erase-args as~)) t~)

untyped-term Γ (ExMu pi pi''' x t Tₘ? pi' ms pi'') =
  untyped-term Γ t >>= λ t~ →
  maybe-map (untyped-type Γ) Tₘ? >>=? λ Tₘ~? →
   [- Var-span Γ pi''' x untyped [] nothing -]
      let Γ' = ctxt-term-decl pi''' x (TpHole pi''') Γ
          ρ = renamectxt-single (pi''' % x) x
          tvs = [ binder-data Γ' pi''' x (Tkt (TpHole pi''')) ff nothing pi' pi'' ] in
      untyped-cases Γ' ms ρ >>= λ ms~ →
      -- Make sure we aren't matching upon a "False" datatype (e.g., one
      -- with no constructors) before any datatypes have been declared
      maybe-else' (head2 (trie-mappings (ctxt.μ Γ)))
        ([- Mu-span Γ pi pi'' Tₘ~? untyped tvs
              (just "No datatypes have been declared yet") -]
         return (Hole pi))
        λ where
          (Dₓ , ps , kᵢ , k , cs , eds , ecs) →
            [- Mu-span Γ pi pi'' Tₘ~? untyped tvs nothing -]
            return (Mu x t~ nothing (mk-data-info Dₓ Dₓ (params-to-args ps) [] ps kᵢ k cs cs eds ecs) ms~)
untyped-term Γ (ExSigma pi t? t Tₘ? pi' ms pi'') =
  untyped-term Γ t >>= λ t~ →
  maybe-map (untyped-type Γ) Tₘ? >>=? λ Tₘ~? →
      maybe-map (untyped-term Γ) t? >>=? λ t~? →
      let ρ = empty-renamectxt
          μ~ = t~?
          tvs = [] in
      untyped-cases Γ ms ρ >>= λ ms~ →
      -- Make sure we aren't matching upon a "False" datatype (e.g., one
      -- with no constructors) before any datatypes have been declared
      maybe-else' (head2 (trie-mappings (ctxt.μ Γ)))
        ([- Mu-span Γ pi pi'' Tₘ~? untyped tvs
              (just "No datatypes have been declared yet") -]
         return (Hole pi))
        λ where
          (Dₓ , ps , kᵢ , k , cs , eds , ecs) →
            [- Mu-span Γ pi pi'' Tₘ~? untyped tvs nothing -]
            return (Sigma μ~ t~ nothing (mk-data-info Dₓ Dₓ (params-to-args ps) [] ps kᵢ k cs cs eds ecs) ms~)

-- x
untyped-term Γ (ExVar pi x) =
  maybe-else' (ctxt-binds-term-var Γ x)
    ([- Var-span Γ pi x untyped [] (just "Not a term variable") -]
    return (Var x))
    λ {(qx , as) →
      [- Var-span Γ pi x untyped [] nothing -]
      return (recompose-apps (map Arg (erase-args as)) (Var qx))}

-- ∀/Π x : tk. T
untyped-type Γ (ExTpAbs pi e pi' x tk T) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-type (Γ , pi' - x :` tk~) T >>= λ T~ →
  let T~ = rename-var Γ (pi' % x) x T~ in
  [- punctuation-span "Forall" pi (posinfo-plus pi 1) -]
  [- var-span e (Γ , pi' - x :` tk~) pi' x untyped tk~ nothing -]
  [- TpQuant-span Γ e pi pi' x tk~ T untyped [] nothing -]
  return (TpAbs e x tk~ T~)

-- ι x : T₁. T₂
untyped-type Γ (ExTpIota pi pi' x T₁ T₂) =
  untyped-type Γ T₁ >>= λ T₁~ →
  untyped-type (Γ , pi' - x :` Tkt T₁~) T₂ >>= λ T₂~ →
  let T₂~ = rename-var Γ (pi' % x) x T₂~ in
  [- punctuation-span "Forall" pi (posinfo-plus pi 1) -]
  [- var-span ff (Γ , pi' - x :` Tkt T₁~) pi' x untyped (Tkt T₁~) nothing -]
  [- Iota-span Γ pi pi' x T₂~ T₂ untyped [] nothing -]
  return (TpIota x T₁~ T₂~)

-- {^ T ^} (generated by theta)
untyped-type Γ (ExTpNoSpans T pi) = untyped-type Γ T >>=spand return

-- [d] - T
untyped-type Γ (ExTpLet pi d T) =
  untyped-let Γ d ff (type-start-pos T) (type-end-pos T) >>= λ where
    (Γ' , x , tv , σ , f) →
      untyped-type Γ' T >>= λ T~ →
      [- punctuation-span "Parens (let)" pi (type-end-pos T) -]
      [- TpLet-span pi (type-end-pos T) untyped [ tv ] -]
      return (σ T~)

-- T · T'
untyped-type Γ (ExTpApp T T') =
  untyped-type Γ T >>= λ T~ →
  untyped-type Γ T' >>= λ T'~ →
  [- TpApp-span (type-start-pos T) (type-end-pos T) untyped [] nothing -]
  return (TpAppTp T~ T'~)

-- T t
untyped-type Γ (ExTpAppt T t) =
  untyped-type Γ T >>= λ T~ →
  untyped-term Γ t >>= λ t~ →
  [- TpAppt-span (type-start-pos T) (term-end-pos t) untyped [] nothing -]
  return (TpAppTm T~ t~)

-- T ➔/➾ T'
untyped-type Γ (ExTpArrow T e T') =
  untyped-type Γ T >>= λ T~ →
  untyped-type Γ T' >>= λ T'~ →
  [- TpArrow-span T T' untyped [] nothing -]
  return (TpAbs e ignored-var (Tkt T~) T'~)

-- { t₁ ≃ t₂ }
untyped-type Γ (ExTpEq pi t₁ t₂ pi') =
  untyped-term Γ t₁ >>= λ t₁~ →
  untyped-term Γ t₂ >>= λ t₂~ →
  [- punctuation-span "Parens (equation)" pi pi' -]
  [- TpEq-span pi pi' untyped [] nothing -]
  return (TpEq t₁~ t₂~)

-- ●
untyped-type Γ (ExTpHole pi) =
  [- tp-hole-span Γ pi nothing untyped [] -]
  return (TpHole pi)

-- λ x : tk. T
untyped-type Γ (ExTpLam pi pi' x tk T) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-type (Γ , pi' - x :` tk~) T >>= λ T~ →
  [- punctuation-span "Lambda (type)" pi (posinfo-plus pi 1) -]
  [- var-span ff (Γ , pi' - x :` tk~) pi' x untyped tk~ nothing -]
  [- TpLambda-span Γ pi pi' x tk~ T untyped [] nothing -]
  return (TpLam x tk~ (rename-var Γ (pi' % x) x T~))

-- (T)
untyped-type Γ (ExTpParens pi T pi') =
  [- punctuation-span "Parens (type)" pi pi' -]
  untyped-type Γ T

-- x
untyped-type Γ (ExTpVar pi x) =
  maybe-else' (ctxt-binds-type-var Γ x)
    ([- TpVar-span Γ pi x untyped [] (just "Undefined type variable") -]
     return (TpVar x))
    λ {(qx , as) →
      [- TpVar-span Γ pi x untyped [] nothing -]
      return (apps-type (TpVar qx) (erase-args-keep as))}

-- Π x : tk. k
untyped-kind Γ (ExKdAbs pi pi' x tk k) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-kind (Γ , pi' - x :` tk~) k >>= λ k~ →
  [- KdAbs-span Γ pi pi' x tk~ k untyped nothing -]
  [- var-span ff (Γ , pi' - x :` tk~) pi' x untyped tk~ nothing -]
  [- punctuation-span "Pi (kind)" pi (posinfo-plus pi 1) -]
  return (KdAbs x tk~ (rename-var Γ (pi' % x) x k~))

-- tk ➔ k
untyped-kind Γ (ExKdArrow tk k) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-kind Γ k >>= λ k~ →
  [- KdArrow-span tk k untyped nothing -]
  return (KdAbs ignored-var tk~ k~)

-- ●
untyped-kind Γ (ExKdHole pi) =
  [- kd-hole-span pi untyped -]
  return (KdHole pi)

-- (k)
untyped-kind Γ (ExKdParens pi k pi') =
  [- punctuation-span "Parens (kind)" pi pi' -]
  untyped-kind Γ k

-- ★
untyped-kind Γ (ExKdStar pi) =
  [- Star-span pi untyped nothing -]
  return KdStar

-- κ as...
untyped-kind Γ (ExKdVar pi κ as) =
  case ctxt-lookup-kind-var-def Γ κ of λ where
    nothing →
      [- KdVar-span Γ (pi , κ) (args-end-pos (posinfo-plus-str pi κ) as) [] untyped []
           (just "Undefined kind variable") -]
      return (KdHole pi)
    (just (ps , k)) →
      untyped-args Γ as >>= λ as~ →
      [- KdVar-span Γ (pi , κ)
           (args-end-pos (posinfo-plus-str pi κ) as)
           ps untyped (params-data Γ ps)
           (unless (length as =ℕ length ps)
             ("Expected " ^ ℕ-to-string (length ps) ^
              " argument" ^ (if length ps =ℕ 1 then "" else "s") ^
              ", but got " ^ ℕ-to-string (length as))) -]
      return (fst (subst-params-args' Γ ps as~ k))

untyped-arg Γ (ExTmArg ff t) = inj₁ <$> untyped-term Γ t
untyped-arg Γ (ExTmArg tt t) = (inj₂ ∘ inj₁) <$> untyped-term Γ t
untyped-arg Γ (ExTpArg T) = (inj₂ ∘ inj₂) <$> untyped-type Γ T

untyped-args Γ = sequenceA ∘ map (untyped-arg Γ)

untyped-tpkd Γ (ExTkt T) = Tkt <$> untyped-type Γ T
untyped-tpkd Γ (ExTkk k) = Tkk <$> untyped-kind Γ k

untyped-cases Γ ms ρ =
  let msₗ = length ms in
  foldl (λ m rec ms f → untyped-case Γ m msₗ f ρ >>= uncurry₂ λ m asₗ n? → rec (maybe-else' n? ms (λ n → set-nth n (just m) ms)) asₗ)
    (const ∘ return) ms (repeat (length ms) nothing) (λ _ → nothing) >>=r drop-nothing

untyped-case-args : ctxt → posinfo → ex-case-args → ex-tm → renamectxt → spanM (case-args × term)
untyped-case-args Γ pi cas t ρ =
  foldr {B = ctxt → renamectxt → 𝕃 tagged-val → (term → spanM ⊤) → spanM (case-args × term)}
    (λ {(ExCaseArg me pi x) rec Γ' ρ tvs sm →
      let tk = case me of λ {ExCaseArgTp → Tkk (KdHole pi-gen);
                             ExCaseArgTm → Tkt (TpHole pi-gen);
                             ExCaseArgEr → Tkt (TpHole pi-gen)} in
      rec
        (ctxt-tk-decl pi x tk Γ')
        (renamectxt-insert ρ (pi % x) x)
        (binder-data Γ' pi x tk (ex-case-arg-erased me) nothing
          (term-start-pos t) (term-end-pos t) :: tvs)
        (λ t →
          [- var-span (ex-case-arg-erased me) Γ' pi x untyped tk
            (when (ex-case-arg-erased me && is-free-in (pi % x) (erase t))
              "The bound variable occurs free in the erasure of the body (not allowed)") -]
          sm t) >>=c λ cas →
      return2 (case me of λ {ExCaseArgTm → CaseArg ff x nothing :: cas; _ → cas})})
    (λ Γ' ρ tvs sm →
      [- pattern-clause-span pi t (reverse tvs) -]
      untyped-term Γ' t >>= λ t~ →
      sm t~ >>
      return2 [] (subst-renamectxt Γ' ρ t~))
    cas Γ ρ [] λ _ → spanMok

untyped-case Γ (ExCase pi x cas t) csₗ asₗ ρ =
  untyped-case-args Γ pi cas t ρ >>=c λ cas~ t~ →
  case (qual-lookup Γ x) of λ where
    (just (qx , as , ctr-def ps T Cₗ cᵢ cₐ , loc)) →
      let c~ = Case qx cas~ t~ []
          eᵢ = "This constructor overlaps with " ^ x
          eₐ = unless (length cas~ =ℕ cₐ)
                 ("Expected " ^ ℕ-to-string cₐ ^
                  " arguments after erasure, but got " ^ ℕ-to-string (length cas~))
          eₗ = unless (Cₗ =ℕ csₗ)
                 ("Constructor's datatype has " ^ ℕ-to-string Cₗ ^
                  (if Cₗ =ℕ 1 then " constructor" else " constructors") ^
                  ", but expected " ^ ℕ-to-string csₗ) in
      [- Var-span Γ pi x untyped [] (asₗ cᵢ ||-maybe (eₐ ||-maybe eₗ)) -]
      return2 c~ ((λ cᵢ' → when (cᵢ =ℕ cᵢ') eᵢ) , (maybe-not (asₗ cᵢ) >> just cᵢ))
    _ →
      [- Var-span Γ pi x untyped [] (just $ "This is not a valid constructor name") -]
      return2 (Case x cas~ t~ []) (asₗ , nothing)