open import Silica
open import HeapProperties
import Context

open TypeEnvContext

open import Data.Nat
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Empty
import Relation.Binary.PropositionalEquality as Eq

data Preservation : Expr → Set where
  pres : ∀ {e e' : Expr}
       → ∀ {T T' : Type}
       → ∀ {Δ Δ'' Δ''' : StaticEnv}
       → ∀ {Σ Σ' : RuntimeEnv }
       → Δ ⊢ e ⦂ T ⊣ Δ''
       → Σ & Δ ok
       -- TODO: hdref(e)
       → Σ , e ⟶ Σ' , e'
       → (Δ' : StaticEnv)
       → (Δ' ⊢ e' ⦂ T' ⊣ Δ''')
       → (Σ' & Δ' ok)  --
       → (Δ''' <* Δ'')
       -----------------
       → Preservation e

splitIdempotent : ∀ {Γ T₁ T₂ T₃}
                    → Γ ⊢ T₁ ⇛ T₂ / T₃
                    → Γ ⊢ T₂ ⇛ T₂ / T₃
splitIdempotent {Γ} {.(base Void)} {.(base Void)} {.(base Void)} voidSplit = voidSplit
splitIdempotent {Γ} {.(base Boolean)} {.(base Boolean)} {.(base Boolean)} booleanSplit = booleanSplit
splitIdempotent {Γ} {.(contractType _)} {.(contractType _)} {.(contractType _)} (unownedSplit namesEq1 namesEq2 permsEq permUnowned) =
  unownedSplit refl (Eq.trans (Eq.sym namesEq1) namesEq2) refl permUnowned
splitIdempotent {Γ} {.(contractType _)} {.(contractType _)} {.(contractType _)} (shared-shared-shared x) =
  shared-shared-shared x
splitIdempotent {Γ} {.(contractType (tc _ Owned))} {.(contractType (tc _ Shared))} {.(contractType (tc _ Shared))} (owned-shared x) =
  shared-shared-shared refl
splitIdempotent {Γ} {.(contractType (record { contractName = _ ; perm = S _ }))}
                    {.(contractType (record { contractName = _ ; perm = Shared }))}
                    {.(contractType (record { contractName = _ ; perm = Shared }))}
                    (states-shared x) =
                    shared-shared-shared refl

preservation : ∀ {e e' : Expr}
               → {Γ : ContractEnv.ctx}
               → ∀ {T : Type}
               → ∀ {Δ Δ'' : StaticEnv}
               → ∀ {Σ Σ' : RuntimeEnv}
               → Δ ⊢ e ⦂ T ⊣ Δ''
               → Σ & Δ ok
               → Σ , e ⟶ Σ' , e'
               -----------------------
               → Preservation e

-- Proof proceeds by induction on the dynamic semantics.

preservation ty@(locTy {Γ} {Δ₀} l voidSplit) consis st@(SElookup {l = l} {v = voidVal} _ lookupL) =
  let
    Δ = (Δ₀ ,ₗ l ⦂ base Void)
    Δ' = Δ
    e'TypingJudgment = voidTy {Γ} {Δ = Δ'}
  in
    pres ty consis st Δ' e'TypingJudgment consis <*-refl
preservation ty@(locTy {Γ} {Δ₀} l booleanSplit) consis st@(SElookup {l = l} {v = boolVal b} _ lookupL) =
 let
    Δ = (Δ₀ ,ₗ l ⦂ base Boolean)
    Δ' = Δ
    e'TypingJudgment = boolTy {Γ} {Δ = Δ'} b
  in
    pres {Δ = Δ} ty consis st Δ' e'TypingJudgment consis <*-refl
-- The code duplication below is very sad, but I haven't figured out a way that doesn't require refactoring the split judgment to be two-level.
preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(unownedSplit _ _ _ _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
  let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected

preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(shared-shared-shared _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
   let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected
preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(owned-shared _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
   let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected
preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(states-shared _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
   let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected

preservation {T = contractType t₂}
  (locTy {Γ} {Δ₀} {contractType t₁} {.(contractType t₂)} {contractType t₃} l spl)
  (ok .(Δ₀ ,ₗ l ⦂ contractType t₁) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {l = l} {boolVal b} _ lookupL) =
    -- The context says the location refers to a contract, but also a boolean value?? Inconsistent.
      ⊥-elim (lookupNeq lookupUnique)
    where
      objLookupResult = objLookup l t₁ Z
      o = proj₁ objLookupResult
      lHasObjType = proj₁ (proj₂ objLookupResult)
      lookupUnique = IndirectRefContext.contextLookupUnique lHasObjType lookupL
      lookupNeq : (objVal o) ≢ boolVal b
      lookupNeq ()

preservation {T = contractType t₂}
  (locTy {Γ} {Δ₀} {contractType t₁} {.(contractType t₂)} {contractType t₃} l spl)
  (ok .(Δ₀ ,ₗ l ⦂ contractType t₁) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {l = l} {voidVal} _ lookupL) =
    -- The context says the location refers to a contract, but also a boolean value?? Inconsistent.
      ⊥-elim (lookupNeq lookupUnique)
    where
      objLookupResult = objLookup l t₁ Z
      o = proj₁ objLookupResult
      lHasObjType = proj₁ (proj₂ objLookupResult)
      lookupUnique = IndirectRefContext.contextLookupUnique lHasObjType lookupL
      lookupNeq : (objVal o) ≢ voidVal
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Void)} l voidSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Void) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {boolVal b} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = voidLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique lLookupResult lookupL
      lookupNeq : voidVal ≢ boolVal b
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Void)} l voidSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Void) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {objVal o} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = voidLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique lLookupResult lookupL
      lookupNeq : voidVal ≢ objVal o
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Boolean)} l booleanSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Boolean) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {voidVal} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = boolLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique (proj₂ lLookupResult) lookupL
      lookupNeq : boolVal (proj₁ lLookupResult) ≢ voidVal
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Boolean)} l booleanSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Boolean) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {objVal o} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = boolLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique (proj₂ lLookupResult) lookupL
      lookupNeq : boolVal (proj₁ lLookupResult) ≢ objVal o
      lookupNeq ()

preservation {Γ = Γ} {Δ = Δ} {Δ'' = Δ''} ty@(assertTyₓ _ _) consis st@(SEassertₓ x s) =
  pres ty consis st Δ (voidTy {Γ = Γ} {Δ = Δ}) consis <*-refl
preservation {Γ = Γ} {Δ = Δ} {Δ'' = Δ''} ty@(assertTyₗ _ _) consis st@(SEassertₗ x s) =
  pres ty consis st Δ (voidTy {Γ = Γ} {Δ = Δ}) consis <*-refl

preservation  {Γ = Γ} {Δ = Δ} {Δ'' = Δ''}
  ty@(newTy {C = C} {st = st} stOK ty₁ ty₂ CInΓ refl)
  consis
  step@(SEnew {Σ} {o = o} oFresh refl refl) =
    pres ty consis step Δ' newTypeJudgment {!!} {!!}
    where
      T = contractType (tc C (S [ st ]) )
      Δ' = Δ ,ₒ o ⦂ T
      spl = unownedSplit {Γ} refl refl refl refl
      newTypeJudgment = objTy o spl


open import Agda.Builtin.IO
open import Agda.Builtin.Unit

record Box (A : Set) : Set where
  field
    unbox : A

open Box public

record R : Set where
  coinductive
  field
    force : Box R

open R public

r : R
unbox (force r) = r

postulate
  seq    : {A B : Set} → A → B → B
  return : {A : Set} → A → IO A

{-# COMPILE GHC return = \_   -> return #-}
{-# COMPILE GHC seq    = \_ _ -> seq    #-}

main : IO ⊤
main = seq r (return tt)


{-# OPTIONS --safe --without-K #-}
module JVM.Types where

open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Product
open import Data.List
open import Data.String

open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Relation.Nullary

-- Primitive types
data Ty : Set where
  boolean                   : Ty
  byte short int long char  : Ty
  ref                       : String → Ty
  array                     : Ty → Ty

Integer = ref "java/lang/Integer"
Boolean = ref "java/lang/Boolean"

data Ret : Set where
  ty   : Ty → Ret
  void : Ret      -- clearly void is not a type... right? (Spec accurate)

IsIntegral : Ty → Set
IsIntegral boolean = ⊤ -- int instructions compatible with boolean
IsIntegral byte    = ⊤
IsIntegral short   = ⊤
IsIntegral int     = ⊤
IsIntegral long    = ⊤
IsIntegral char    = ⊤
IsIntegral _       = ⊥

StackTy  = List Ty
LocalsTy = List Ty
Labels   = List StackTy

_:?:_ : Ret → StackTy → StackTy
ty a :?: ψ = a ∷ ψ
void :?: ψ = ψ

record Fun : Set where
  constructor _/_:⟨_⟩_
  field
    cls     : String
    name    : String
    sf_args : List Ty
    sf_ret  : Ret

record Fld : Set where
  constructor _/_∶_
  field
    fld_cls  : String
    fld_name : String
    fld_ty   : Ty

data Constant : Set where
  class     : String → Constant
  fieldref  : Fld → Constant
  staticref : Fld → Constant -- in the actual constant pool static fields are fields
  virtual   : Fun → Constant
  staticfun : Fun → Constant

Constantpool = List Constant
FrameTy      = LocalsTy

variable
  𝑪                : Constantpool
  𝑹₁ 𝑹₂ 𝑹₃ 𝑹₄ 𝑹  : LocalsTy
  𝑭₁ 𝑭₂ 𝑭₃ 𝑭₄ 𝑭  : FrameTy
  𝑎 𝑏              : Fld
  𝑐 𝑛 𝑚           : String
  𝑓 𝑔              : Fun
  a b c r s t      : Ty
  as bs cs         : List Ty
  ψ₁ ψ₂ ψ₃ ψ      : StackTy  -- stack typings


mutual
  Loop : Set
  Loop = {!!}

  -- Should not solve ?0 := Loop → Loop
  solve : Loop → Loop → Loop
  solve x = x


-- 2012-01-17 Bug found by Rob Simmons, example simplified by Nisse
-- {-# OPTIONS -v tc.proj.like:50 #-}
-- {-# OPTIONS -v tc.conv.atom:50 #-}
module Issue553b  where

data E : Set where

module M (A : Set) where

  data D : Set where
    d₁ d₂ : D

  data B : Set where
    b : D → B

  -- T must not be classified as projection-like, because of deep matching
  T : B → Set
  T (b d₁) = E
  T (b d₂) = E

  data P : B → Set where
    p : (b : B) → T b → P b

  pb : (d : D) → T (b d) → P (b d)
  pb d t = p (b d) t


import cedille-options

module to-string (options : cedille-options.options) where

open import lib
open import cedille-types
open import constants
open import syntax-util
open import ctxt
open import rename
open import general-util

data expr-side : Set where
  left : expr-side
  right : expr-side
  neither : expr-side

not-left : expr-side → 𝔹
not-left left = ff
not-left _ = tt
not-right : expr-side → 𝔹
not-right right = ff
not-right _ = tt

no-parens : {ed : exprd} → {ed' : exprd} → ⟦ ed ⟧ → ⟦ ed' ⟧ → expr-side → 𝔹
no-parens {_} {TERM} _ (IotaPair pi t t' og pi') lr = tt
no-parens {_} {TYPE} _ (TpEq _ t t' _) lr = tt
no-parens {_} {TERM} _ (Beta pi ot ot') lr = tt
no-parens {_} {TERM} _ (Phi pi eq t t' pi') right = tt
no-parens {_} {TERM} _ (Phi pi eq t t' pi') neither = tt
no-parens {_} {TERM} _ (Rho _ _ _ _ _ _) right = tt
no-parens {_} {TERM} _ (Chi _ _ _) right = tt
no-parens {_} {TERM} _ (Delta _ _ _) right = tt
no-parens {_} {TERM} _ (Let _ _ _) lr = tt
no-parens {_} {TERM} _ (Lam _ _ _ _ _ _) lr = tt
no-parens {_} {TERM} _ (Mu _ _ _ _ _ _ _) lr = tt
no-parens {_} {TERM} _ (Mu' _ _ _ _ _ _) lr = tt
no-parens {_} {TYPE} _ (TpLambda _ _ _ _ _) lr = tt
no-parens {_} {TYPE} _ (Abs _ _ _ _ _ _) lr = tt
no-parens {_} {KIND} _ (KndPi _ _ _ _ _) lr = tt
no-parens {_} {TYPE} _ (Iota _ _ _ _ _) lr = tt
no-parens {_} {LIFTINGTYPE} _ (LiftPi _ _ _ _) lr = tt
no-parens{TERM} (App t me t') p lr = is-term-level-app p && not-right lr
no-parens{TERM} (AppTp t T) p lr = is-term-level-app p && not-right lr
no-parens{TERM} (Beta pi ot ot') p lr = tt
no-parens{TERM} (Chi pi mT t) p lr = ff
no-parens{TERM} (Delta pi mT t) p lr = ff
no-parens{TERM} (Epsilon pi lr' m t) p lr = is-eq-op p
no-parens{TERM} (Hole pi) p lr = tt
no-parens{TERM} (IotaPair pi t t' og pi') p lr = tt
no-parens{TERM} (IotaProj t n pi) p lr = tt
no-parens{TERM} (Lam pi l' pi' x oc t) p lr = ff
no-parens{TERM} (Let pi dtT t) p lr = ff
no-parens{TERM} (Open _ _ _) p lr = tt
no-parens{TERM} (Parens pi t pi') p lr = tt
no-parens{TERM} (Phi pi eq t t' pi') p lr = ff
no-parens{TERM} (Rho pi op on eq og t) p lr = ff
no-parens{TERM} (Sigma pi t) p lr = is-eq-op p
no-parens{TERM} (Theta pi theta t lts) p lr = ff
no-parens{TERM} (Var pi x) p lr = tt
no-parens{TERM} (Mu _ _ _ _ _ _ _) p lr = tt
no-parens{TERM} (Mu' _ _ _ _ _ _)  p lr = tt
no-parens{TYPE} (Abs pi b pi' x Tk T) p lr = is-arrow p && not-left lr
no-parens{TYPE} (Iota pi pi' x oT T) p lr = ff
no-parens{TYPE} (Lft pi pi' x t lT) p lr = ff
no-parens{TYPE} (NoSpans T pi) p lr = tt
no-parens{TYPE} (TpApp T T') p lr = is-arrow p || (is-type-level-app p && not-right lr)
no-parens{TYPE} (TpAppt T t) p lr = is-arrow p || (is-type-level-app p && not-right lr)
no-parens{TYPE} (TpArrow T a T') p lr = is-arrow p && not-left lr
no-parens{TYPE} (TpEq _ t t' _) p lr = tt
no-parens{TYPE} (TpHole pi) p lr = tt
no-parens{TYPE} (TpLambda pi pi' x Tk T) p lr = ff
no-parens{TYPE} (TpParens pi T pi') p lr = tt
no-parens{TYPE} (TpVar pi x) p lr = tt
no-parens{TYPE} (TpLet _ _ _) _ _ = ff
no-parens{KIND} (KndArrow k k') p lr = is-arrow p && not-left lr
no-parens{KIND} (KndParens pi k pi') p lr = tt
no-parens{KIND} (KndPi pi pi' x Tk k) p lr = is-arrow p && not-left lr
no-parens{KIND} (KndTpArrow T k) p lr = is-arrow p && not-left lr
no-parens{KIND} (KndVar pi x as) p lr = tt
no-parens{KIND} (Star pi) p lr = tt
no-parens{LIFTINGTYPE} (LiftArrow lT lT') p lr = is-arrow p && not-left lr
no-parens{LIFTINGTYPE} (LiftParens pi lT pi') p lr = tt
no-parens{LIFTINGTYPE} (LiftPi pi x T lT) p lr = is-arrow p && not-left lr
no-parens{LIFTINGTYPE} (LiftStar pi) p lr = tt
no-parens{LIFTINGTYPE} (LiftTpArrow T lT) p lr = is-arrow p && not-left lr
no-parens{TK} _ _ _ = tt
no-parens{QUALIF} _ _ _ = tt
no-parens{ARG} _ _ _ = tt

pattern ced-ops-drop-spine = cedille-options.options.mk-options _ _ _ _ ff _ ff
pattern ced-ops-conv-arr = cedille-options.options.mk-options _ _ _ _ _ _ ff
pattern ced-ops-conv-abs = cedille-options.options.mk-options _ _ _ _ _ _ tt

drop-spine : cedille-options.options → {ed : exprd} → ctxt → ⟦ ed ⟧ → ⟦ ed ⟧
drop-spine ced-ops-drop-spine = h
  where
  drop-mod-args : ctxt → maybeErased → spineApp → spineApp
  drop-mod-args Γ me (v , as) =
    let qv = unqual-all (ctxt-get-qualif Γ) v in qv ,
    maybe-else' (maybe-if (~ v =string qv) ≫maybe ctxt-qualif-args-length Γ me qv)
      as (λ n → reverse (drop n (reverse as)))

  h : {ed : exprd} → ctxt → ⟦ ed ⟧ → ⟦ ed ⟧
  h {TERM} Γ t = maybe-else' (term-to-spapp t) t (spapp-term ∘ drop-mod-args Γ Erased)
  h {TYPE} Γ T = maybe-else' (type-to-spapp T) T (spapp-type ∘ drop-mod-args Γ NotErased)
  h Γ x = x
drop-spine ops Γ x = x

to-string-rewrite : {ed : exprd} → ctxt → cedille-options.options → ⟦ ed ⟧ → Σi exprd ⟦_⟧
to-string-rewrite{TERM} Γ ops (Parens _ t _) = to-string-rewrite Γ ops t
to-string-rewrite{TYPE} Γ ops (TpParens _ T _) = to-string-rewrite Γ ops T
to-string-rewrite{KIND} Γ ops (KndParens _ k _) = to-string-rewrite Γ ops k
to-string-rewrite{LIFTINGTYPE} Γ ops (LiftParens _ lT _) = to-string-rewrite Γ ops lT
to-string-rewrite{TK} Γ ops (Tkt T) = to-string-rewrite Γ ops T
to-string-rewrite{TK} Γ ops (Tkk k) = to-string-rewrite Γ ops k
to-string-rewrite{TYPE} Γ ced-ops-conv-arr (Abs _ me _ ignored-var (Tkt T) T') = , TpArrow T me T'
to-string-rewrite{KIND} Γ ced-ops-conv-arr (KndPi _ _ ignored-var (Tkt T) k) = , KndTpArrow T k
to-string-rewrite{KIND} Γ ced-ops-conv-arr (KndPi _ _ ignored-var (Tkk k) k') = , KndArrow k k'
to-string-rewrite{LIFTINGTYPE} Γ ced-ops-conv-arr (LiftPi _ ignored-var T lT) = , LiftTpArrow T lT
to-string-rewrite{TYPE} Γ ced-ops-conv-abs (TpArrow T me T') = , Abs posinfo-gen me posinfo-gen ignored-var (Tkt T) T'
to-string-rewrite{KIND} Γ ced-ops-conv-abs (KndTpArrow T k) = , KndPi posinfo-gen posinfo-gen ignored-var (Tkt T) k
to-string-rewrite{KIND} Γ ced-ops-conv-abs (KndArrow k k') = , KndPi posinfo-gen posinfo-gen ignored-var (Tkk k) k'
to-string-rewrite{LIFTINGTYPE} Γ ced-ops-conv-abs (LiftTpArrow T lT) = , LiftPi posinfo-gen ignored-var T lT
to-string-rewrite{TERM} Γ ops (Sigma pi (Sigma pi' t)) = to-string-rewrite Γ ops t
to-string-rewrite Γ ops x = , drop-spine ops Γ x

-------------------------------
strM : Set
strM = ∀ {ed} → rope → ℕ → 𝕃 tag → ctxt → maybe ⟦ ed ⟧ → expr-side → rope × ℕ × 𝕃 tag

to-stringh : {ed : exprd} → ⟦ ed ⟧ → strM

strM-Γ : (ctxt → strM) → strM
strM-Γ f s n ts Γ = f Γ s n ts Γ

infixr 4 _≫str_

_≫str_ : strM → strM → strM
(m ≫str m') s n ts Γ pe lr with m s n ts Γ pe lr
(m ≫str m') s n ts Γ pe lr | s' , n' , ts' = m' s' n' ts' Γ pe lr

strAdd : string → strM
strAdd s s' n ts Γ pe lr = s' ⊹⊹ [[ s ]] , n + string-length s , ts

strΓ' : defScope → var → strM → strM
strΓ' ds v m s n ts Γ@(mk-ctxt (fn , mn , ps , q) syms i symb-occs d) pe =
  let gl = ds iff globalScope
      v' = if gl then (mn # v) else v in
  m s n ts (mk-ctxt
      (fn , mn , ps , qualif-insert-params q v' (unqual-local v) (if gl then ps else ParamsNil))
      syms (trie-insert i v' (var-decl , ("missing" , "missing"))) symb-occs d) pe

strΓ : var → strM → strM
strΓ x m s n ts Γ = m s n ts (ctxt-var-decl x Γ)

ctxt-get-file-id : ctxt → (filename : string) → ℕ
ctxt-get-file-id (mk-ctxt mod (syms , mn-fn , mn-ps , ids , id) is os _) =
  trie-lookup-else 0 ids

make-loc-tag : ctxt → (filename start-to end-to : string) → (start-from end-from : ℕ) → tag
make-loc-tag Γ fn s e = make-tag "loc"
  (("fn" , [[ ℕ-to-string (ctxt-get-file-id Γ fn) ]]) ::
   ("s" , [[ s ]]) :: ("e" , [[ e ]]) :: [])

var-loc-tag : ctxt → location → var → (start-from end-from : ℕ) → 𝕃 tag
var-loc-tag Γ ("missing" , "missing") x start end = []
var-loc-tag Γ (fn , pos) x start end =
  [ make-loc-tag Γ fn pos (posinfo-plus-str pos (unqual-local x)) start end ]

var-tags : ctxt → qvar → var → ℕ → ℕ → 𝕃 tag
var-tags Γ qv uqv s e with qv =string (qualif-var Γ uqv)
...| tt = var-loc-tag Γ (ctxt-var-location Γ qv) uqv s e
...| ff = make-tag "shadowed" [] s e :: var-loc-tag Γ (ctxt-var-location Γ qv) uqv s e

strVar : var → strM
strVar v s n ts Γ pe lr =
  let uqv = unqual-local $ unqual-all (ctxt-get-qualif Γ) v
      uqv' = if cedille-options.options.show-qualified-vars options then v else uqv
      n' = n + (string-length uqv') in
  s ⊹⊹ [[ uqv' ]] , n' , var-tags Γ (qualif-var Γ v) uqv n n' ++ ts

-- Only necessary to unqual-local because of module parameters
strBvar : var → (class body : strM) → strM
strBvar v cm bm = strAdd (unqual-local v) ≫str cm ≫str strΓ v bm

strMetaVar : var → span-location → strM
strMetaVar x (fn , pi , pi') s n ts Γ pe lr =
  let n' = n + string-length x in
  s ⊹⊹ [[ x ]] , n' , make-loc-tag Γ fn pi pi' n n' :: ts

strEmpty : strM
strEmpty s n ts Γ pe lr = s , n , ts

{-# TERMINATING #-}
term-to-stringh : term → strM
type-to-stringh : type → strM
kind-to-stringh : kind → strM
liftingType-to-stringh : liftingType → strM
tk-to-stringh : tk → strM
constructors-to-string : dataConsts → strM

params-to-string : params → strM
params-to-string' : strM → params → strM
file-to-string : start → strM
cmds-to-string : cmds → strM → strM
cmd-to-string : cmd → strM → strM
optTerm-to-string : optTerm → string → string → strM
optClass-to-string : optClass → strM
optGuide-to-string : optGuide → strM
optNums-to-string : optNums → strM
optType-to-string : optType → strM
maybeCheckType-to-string : optType → strM
lterms-to-string : lterms → strM
arg-to-string : arg → strM
args-to-string : args → strM
binder-to-string : maybeErased → string
opacity-to-string : opacity → string
maybeErased-to-string : maybeErased → string
lam-to-string : maybeErased → string
leftRight-to-string : leftRight → string
vars-to-string : vars → strM
nums-to-string : nums → strM
theta-to-string : theta → strM
arrowtype-to-string : maybeErased → string
maybeMinus-to-string : maybeMinus → string
optPlus-to-string : optPlus → string
optPublic-to-string : optPublic → string
optAs-to-string : optAs → strM

to-string-ed : {ed : exprd} → ⟦ ed ⟧ → strM
to-string-ed{TERM} = term-to-stringh
to-string-ed{TYPE} = type-to-stringh
to-string-ed{KIND} = kind-to-stringh
to-string-ed{LIFTINGTYPE} = liftingType-to-stringh
to-string-ed{TK} = tk-to-stringh
to-string-ed{ARG} = arg-to-string
to-string-ed{QUALIF} q = strEmpty

to-stringh' : {ed : exprd} → expr-side → ⟦ ed ⟧ → strM
to-stringh' {ed} lr t {ed'} s n ts Γ mp lr' =
  elim-Σi (to-string-rewrite Γ options t) λ t' →
  parens-unless (~ isJust (mp ≫=maybe λ pe → maybe-if (~ no-parens t' pe lr)))
    (to-string-ed t') s n ts Γ (just t') lr
  where
  parens-unless : 𝔹 → strM → strM
  parens-unless p s = if p then s else (strAdd "(" ≫str s ≫str strAdd ")")

to-stringl : {ed : exprd} → ⟦ ed ⟧ → strM
to-stringr : {ed : exprd} → ⟦ ed ⟧ → strM
to-stringl = to-stringh' left
to-stringr = to-stringh' right
to-stringh = to-stringh' neither

constructors-to-string DataNull                        = strEmpty
constructors-to-string (DataCons (DataConst _ x t) ds) =
  strAdd "  | "  ≫str
  strAdd x      ≫str
  strAdd " : "  ≫str
  type-to-stringh  t ≫str
  constructors-to-string ds

tk-to-stringh (Tkt T) = to-stringh T
tk-to-stringh (Tkk k) = to-stringh k

term-to-stringh (App t me t') = to-stringl t ≫str strAdd (" " ^ maybeErased-to-string me) ≫str to-stringr t'
term-to-stringh (AppTp t T) = to-stringl t ≫str strAdd " · " ≫str to-stringr T
term-to-stringh (Beta pi ot ot') = strAdd "β" ≫str optTerm-to-string ot " < " " >" ≫str optTerm-to-string ot' " { " " }"
term-to-stringh (Chi pi mT t) = strAdd "χ" ≫str optType-to-string mT ≫str strAdd " - " ≫str to-stringr t
term-to-stringh (Delta pi mT t) = strAdd "δ" ≫str optType-to-string mT ≫str strAdd " - " ≫str to-stringr t
term-to-stringh (Epsilon pi lr m t) = strAdd "ε" ≫str strAdd (leftRight-to-string lr) ≫str strAdd (maybeMinus-to-string m) ≫str to-stringh t
term-to-stringh (Hole pi) = strAdd "●"
term-to-stringh (IotaPair pi t t' og pi') = strAdd "[ " ≫str to-stringh t ≫str strAdd " , " ≫str to-stringh t' ≫str optGuide-to-string og ≫str strAdd " ]"
term-to-stringh (IotaProj t n pi) = to-stringh t ≫str strAdd ("." ^ n)
term-to-stringh (Lam pi l pi' x oc t) = strAdd (lam-to-string l) ≫str strAdd " " ≫str strBvar x (optClass-to-string oc) (strAdd " . " ≫str to-stringr t)
term-to-stringh (Let pi dtT t) with dtT
...| DefTerm pi' x m t' = strAdd "[ " ≫str strBvar x (maybeCheckType-to-string m ≫str strAdd " = " ≫str to-stringh t' ≫str strAdd " ] - ") (to-stringh t)
...| DefType pi' x k t' = strAdd "[ " ≫str strBvar x (strAdd " ◂ " ≫str to-stringh k ≫str strAdd " = " ≫str to-stringh t' ≫str strAdd " ] - ") (to-stringh t)
term-to-stringh (Open pi x t) = strAdd "open " ≫str strVar x ≫str strAdd " - " ≫str to-stringh t
term-to-stringh (Parens pi t pi') = to-stringh t
term-to-stringh (Phi pi eq t t' pi') = strAdd "φ " ≫str to-stringl eq ≫str strAdd " - " ≫str to-stringh t ≫str strAdd " {" ≫str to-stringr t' ≫str strAdd "}"
term-to-stringh (Rho pi op on eq og t) = strAdd "ρ" ≫str strAdd (optPlus-to-string op) ≫str optNums-to-string on ≫str strAdd " " ≫str to-stringl eq ≫str optGuide-to-string og ≫str strAdd " - " ≫str to-stringr t
term-to-stringh (Sigma pi t) = strAdd "ς " ≫str to-stringh t
term-to-stringh (Theta pi theta t lts) = theta-to-string theta ≫str to-stringh t ≫str lterms-to-string lts
term-to-stringh (Var pi x) = strVar x
term-to-stringh (Mu pi x t ot pi' cs pi'') = strAdd "μ " ≫str strBvar x (strAdd " . " ≫str to-stringh t) strEmpty ≫str optType-to-string ot ≫str strAdd "TODO"
term-to-stringh (Mu' pi t ot pi' cs pi'')  = strAdd "μ' " ≫str to-stringh t ≫str strAdd " . " ≫str optType-to-string ot ≫str strAdd "TODO"

type-to-stringh (Abs pi b pi' x Tk T) = strAdd (binder-to-string b ^ " ") ≫str strBvar x (strAdd " : " ≫str tk-to-stringh Tk ≫str strAdd " . ") (to-stringh T)
type-to-stringh (Iota pi pi' x T T') = strAdd "ι " ≫str strBvar x (strAdd " : " ≫str to-stringh T ≫str strAdd " . ") (to-stringh T')
type-to-stringh (Lft pi pi' x t lT) = strAdd "↑ " ≫str strBvar x (strAdd " . ") (to-stringh t) ≫str strAdd " : " ≫str to-stringh lT
type-to-stringh (NoSpans T pi) = to-string-ed T
type-to-stringh (TpApp T T') = to-stringl T ≫str strAdd " · " ≫str to-stringr T'
type-to-stringh (TpAppt T t) = to-stringl T ≫str strAdd " " ≫str to-stringr t
type-to-stringh (TpArrow T a T') = to-stringl T ≫str strAdd (arrowtype-to-string a) ≫str to-stringr T'
type-to-stringh (TpEq _ t t' _) = strAdd "{ " ≫str to-stringh (erase-term t) ≫str strAdd " ≃ " ≫str to-stringh (erase-term t') ≫str strAdd " }"
type-to-stringh (TpHole pi) = strAdd "●"
type-to-stringh (TpLambda pi pi' x Tk T) = strAdd "λ " ≫str strBvar x (strAdd " : " ≫str tk-to-stringh Tk ≫str strAdd " . ") (to-stringr T)
type-to-stringh (TpParens pi T pi') = to-stringh T
type-to-stringh (TpVar pi x) = strVar x
type-to-stringh (TpLet pi dtT t) with dtT
...| DefTerm pi' x m t' = strAdd "[ " ≫str strBvar x (maybeCheckType-to-string m ≫str strAdd " = " ≫str to-stringh t' ≫str strAdd " ] - ") (to-stringh t)
...| DefType pi' x k t' = strAdd "[ " ≫str strBvar x (strAdd " ◂ " ≫str to-stringh k ≫str strAdd " = " ≫str to-stringh t' ≫str strAdd " ] - ") (to-stringh t)

kind-to-stringh (KndArrow k k') = to-stringl k ≫str strAdd " ➔ " ≫str to-stringr k'
kind-to-stringh (KndParens pi k pi') = to-stringh k
kind-to-stringh (KndPi pi pi' x Tk k) = strAdd "Π " ≫str strBvar x (strAdd " : " ≫str tk-to-stringh Tk ≫str strAdd " . ") (to-stringh k)
kind-to-stringh (KndTpArrow T k) = to-stringl T ≫str strAdd " ➔ " ≫str to-stringr k
kind-to-stringh (KndVar pi x as) = strVar x ≫str args-to-string as
kind-to-stringh (Star pi) = strAdd "★"

liftingType-to-stringh (LiftArrow lT lT') = to-stringl lT ≫str strAdd " ➔↑ " ≫str to-stringr lT'
liftingType-to-stringh (LiftParens pi lT pi') = strAdd "(" ≫str to-string-ed lT ≫str strAdd ")"
liftingType-to-stringh (LiftPi pi x T lT) = strAdd "Π↑ " ≫str strBvar x (strAdd " : " ≫str to-stringh T ≫str strAdd " . ") (to-stringh lT)
liftingType-to-stringh (LiftStar pi) = strAdd "☆"
liftingType-to-stringh (LiftTpArrow T lT) = to-stringl T ≫str strAdd " ➔↑ " ≫str to-stringr lT
optTerm-to-string NoTerm c1 c2 = strEmpty
optTerm-to-string (SomeTerm t _) c1 c2 = strAdd c1 ≫str to-stringh (erase-term t) ≫str strAdd c2
optClass-to-string NoClass = strEmpty
optClass-to-string (SomeClass Tk) = strAdd " : " ≫str tk-to-stringh Tk
optGuide-to-string NoGuide = strEmpty
optGuide-to-string (Guide pi v T) = strAdd " @ " ≫str strBvar v (strAdd " . ") (to-stringh T)
optType-to-string NoType = strEmpty
optType-to-string (SomeType T) = strAdd " " ≫str to-stringh T
maybeCheckType-to-string NoType = strEmpty
maybeCheckType-to-string (SomeType T) = strAdd " ◂ " ≫str to-stringh T
lterms-to-string (LtermsCons m t ts) = strAdd (" " ^ maybeErased-to-string m) ≫str to-stringh t ≫str lterms-to-string ts
lterms-to-string (LtermsNil _) = strEmpty
arg-to-string (TermArg me t) = strAdd (maybeErased-to-string me) ≫str to-stringh t
arg-to-string (TypeArg T) = strAdd "· " ≫str to-stringh T
args-to-string (ArgsCons t ts) = strAdd " " ≫str arg-to-string t ≫str args-to-string ts
args-to-string ArgsNil = strEmpty
binder-to-string All = "∀"
binder-to-string Pi = "Π"
opacity-to-string OpacOpaque = "opaque "
opacity-to-string OpacTrans = ""
maybeErased-to-string Erased = "-"
maybeErased-to-string NotErased = ""
lam-to-string Erased = "Λ"
lam-to-string NotErased = "λ"
leftRight-to-string Left = "l"
leftRight-to-string Right = "r"
leftRight-to-string Both = ""
vars-to-string (VarsStart v) = strVar v
vars-to-string (VarsNext v vs) = strVar v ≫str strAdd " " ≫str vars-to-string vs
theta-to-string Abstract = strAdd "θ "
theta-to-string AbstractEq = strAdd "θ+ "
theta-to-string (AbstractVars vs) = strAdd "θ<" ≫str vars-to-string vs ≫str strAdd "> "
nums-to-string (NumsStart n) = strAdd n
nums-to-string (NumsNext n ns) = strAdd n ≫str strAdd " " ≫str nums-to-string ns
optNums-to-string NoNums = strEmpty
optNums-to-string (SomeNums ns) = strAdd "<" ≫str nums-to-string ns ≫str strAdd ">"
arrowtype-to-string NotErased = " ➔ "
arrowtype-to-string Erased = " ➾ "
maybeMinus-to-string EpsHnf = ""
maybeMinus-to-string EpsHanf = "-"
optPlus-to-string RhoPlain = ""
optPlus-to-string RhoPlus = "+"
optPublic-to-string NotPublic = ""
optPublic-to-string IsPublic = "public "
optAs-to-string NoOptAs = strEmpty
optAs-to-string (SomeOptAs _ x) = strAdd " as " ≫str strAdd x

braceL : maybeErased → string
braceL Erased = "{"
braceL NotErased = "("

braceR : maybeErased → string
braceR Erased = "}"
braceR NotErased = ")"

param-to-string : decl → strM → strM
param-to-string (Decl _ pi me v atk _) f =
  strAdd (braceL me) ≫str
  strAdd (unqual-local v) ≫str
  strAdd " : " ≫str
  tk-to-stringh atk ≫str
  strAdd (braceR me) ≫str
  strΓ' localScope v f
params-to-string' f ParamsNil = f
params-to-string' f (ParamsCons p ParamsNil) = param-to-string p f
params-to-string' f (ParamsCons p ps) = param-to-string p (strAdd " " ≫str params-to-string' f ps)

params-to-string = params-to-string' strEmpty

file-to-string (File _ is _ _ mn ps cs _) =
   cmds-to-string (imps-to-cmds is)
  (strAdd "module " ≫str
   strAdd mn ≫str
   strAdd " " ≫str
   params-to-string'
  (strAdd "." ≫str strAdd "\n" ≫str
   cmds-to-string cs strEmpty) ps)

cmds-to-string CmdsStart f = f
cmds-to-string (CmdsNext c cs) f =
   strAdd "\n" ≫str
   cmd-to-string c
  (strAdd "\n" ≫str
   cmds-to-string cs f)

cmd-to-string (DefTermOrType op (DefTerm pi x mcT t) _) f =
  strM-Γ λ Γ →
  let ps = ctxt-get-current-params Γ in
  strAdd (opacity-to-string op) ≫str
  strAdd x ≫str
  maybeCheckType-to-string (case mcT of λ where
     NoType → NoType
     (SomeType T) → SomeType (abs-expand-type ps T)) ≫str
  strAdd " = " ≫str
  to-stringh (lam-expand-term ps t) ≫str
  strAdd " ." ≫str
  strΓ' globalScope x f
cmd-to-string (DefTermOrType op (DefType pi x k T) _) f =
  strM-Γ λ Γ →
  let ps = ctxt-get-current-params Γ in
  strAdd (opacity-to-string op) ≫str
  strAdd x ≫str
  strAdd " ◂ " ≫str
  to-stringh (abs-expand-kind ps k) ≫str
  strAdd " = " ≫str
  to-stringh (lam-expand-type ps T) ≫str
  strAdd " ." ≫str
  strΓ' globalScope x f
cmd-to-string (DefKind pi x ps k _) f =
  strM-Γ λ Γ →
  let ps' = ctxt-get-current-params Γ in
  strAdd x ≫str
  params-to-string (append-params ps' ps) ≫str
  strAdd " = " ≫str
  to-stringh k ≫str
  strAdd " ." ≫str
  strΓ' globalScope x f
cmd-to-string (ImportCmd (Import _ op _ fn oa as _)) f =
  strAdd "import " ≫str
  strAdd (optPublic-to-string op) ≫str
  strAdd fn ≫str
  optAs-to-string oa ≫str
  args-to-string as ≫str
  strAdd " ." ≫str
  f
cmd-to-string (DefDatatype (Datatype pi pix x ps k cs pi') pi'') f =
  strAdd "data " ≫str
  strAdd x ≫str
  strAdd " " ≫str
  params-to-string ps ≫str
  strAdd " : " ≫str
  kind-to-stringh k ≫str
  strAdd " = " ≫str
  constructors-to-string cs ≫str
  strΓ' globalScope x f

strRun : ctxt → strM → rope
strRun Γ m = fst (m {TERM} [[]] 0 [] Γ nothing neither)

strRunTag : (name : string) → ctxt → strM → tagged-val
strRunTag name Γ m with m {TERM} [[]] 0 [] Γ nothing neither
...| s , n , ts = name , s , ts

to-string-tag : {ed : exprd} → string → ctxt → ⟦ ed ⟧ → tagged-val
to-string-tag name Γ t = strRunTag name Γ
  (to-stringh
    (if cedille-options.options.erase-types options
       then erase t
       else t))

to-string : {ed : exprd} → ctxt → ⟦ ed ⟧ → rope
to-string Γ t = strRun Γ (to-stringh t)

tk-to-string : ctxt → tk → rope
tk-to-string Γ atk = strRun Γ (tk-to-stringh atk)

params-to-string-tag : string → ctxt → params → tagged-val
params-to-string-tag name Γ ps = strRunTag name Γ (params-to-string ps)


import Issue4267.M using ()

-- foo : {!Issue4267.M.R!} -- cannot give, but this is the solution
foo = record { f = Set}


module _ where

open import Agda.Builtin.Nat

postulate
  T : Set

  C₁ : Set
  instance I₁ : C₁

  C₂ : Nat → Set
  instance I₂ : ∀ {n} → C₂ n

it : {A : Set} {{_ : A}} → A
it {{x}} = x

postulate
  f₁ : {{_ : Nat → C₁}} → T
  f₂ : {{_ : ∀ n → C₂ n}} → T

works₁ : T
works₁ = f₁         -- f₁ {{λ _ → I₁}}

fails₁ : T
fails₁ = f₁ {{it}}  -- internal error

works₂ : T
works₂ = f₂         -- f₂ {{λ n → I₂ {n}}}

fails₂ : T
fails₂ = f₂ {{it}}  -- internal error


-- Andreas, 2018-06-30, issue #3147 reported by bafain
-- Pattern linearity ignored for as-patterns

-- {-# OPTIONS -v tc.lhs.top:30 #-}
-- {-# OPTIONS -v tc.lhs.linear:100 #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

f : Nat → Nat
f zero      = zero
f x@(suc x) = x    -- rhs context:
                   -- x : Nat
                   -- x : Nat

-- Should fail during lhs-checking

f-id-1 : f 1 ≡ 1
f-id-1 = refl

f-pre-1 : f 1 ≡ 0
f-pre-1 = refl


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
import      LibraBFT.Impl.Consensus.SafetyRules.SafetyRules as SafetyRules
import      LibraBFT.Impl.Consensus.TestUtils.MockStorage   as MockStorage
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.MetricsSafetyRules where

module performInitialize
  (self : SafetyRules)
  (obmPersistentLivenessStorage : PersistentLivenessStorage)
  where

  step₀ : EitherD ErrLog SafetyRules
  step₁ : EpochChangeProof → EitherD ErrLog SafetyRules

  step₀ = do
    let consensusState = SafetyRules.consensusState self
        srWaypoint     = consensusState ^∙ csWaypoint
    proofs             ← MockStorage.retrieveEpochChangeProofED
                           (srWaypoint ^∙ wVersion) obmPersistentLivenessStorage
    step₁ proofs
  step₁ proofs = SafetyRules.initialize-ed-abs self proofs

abstract
  performInitialize-ed-abs = performInitialize.step₀
  performInitialize-abs : SafetyRules → PersistentLivenessStorage → Either ErrLog SafetyRules
  performInitialize-abs sr storage = toEither $ performInitialize-ed-abs sr storage
  performInitialize-abs-≡ : (sr : SafetyRules) (storage : PersistentLivenessStorage)
                          → performInitialize-abs sr storage ≡ EitherD-run (performInitialize-ed-abs sr storage)
  performInitialize-abs-≡ sr storage = refl


module _ where

open import Common.Prelude hiding (_>>=_)
open import Common.Reflection

pattern `Nat = def (quote Nat) []

unquoteDecl f =
  declareDef (vArg f) `Nat


{-# OPTIONS --safe #-}
module Issue2728-3 where
foo = Set -- something to cache
postulate B : Set


------------------------------------------------------------------------
-- The Agda standard library
--
-- Core definitions for Strings
------------------------------------------------------------------------

module Data.String.Core where

open import Data.List using (List)
open import Data.Bool using (Bool; true; false)
open import Data.Char.Core using (Char)

------------------------------------------------------------------------
-- The type

postulate
  String : Set

{-# BUILTIN STRING String #-}
{-# COMPILED_TYPE String String #-}

------------------------------------------------------------------------
-- Primitive operations

primitive
  primStringAppend   : String → String → String
  primStringToList   : String → List Char
  primStringFromList : List Char → String
  primStringEquality : String → String → Bool
  primShowString     : String → String

  -- Here instead of Data.Char.Core to avoid an import cycle
  primShowChar       : Char → String


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Fst {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as Wk hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Introductions.Pi

open import Tools.Product
import Tools.PropositionalEquality as PE

fst-subst* : ∀ {Γ F G t t′} → Γ ⊢ F → Γ ∙ F ⊢ G
             → Γ ⊢ t ⇒* t′ ∷ Σ F ▹ G → Γ ⊢ fst t ⇒* fst t′ ∷ F
fst-subst* ⊢F ⊢G (id x) = id (fstⱼ ⊢F ⊢G x)
fst-subst* ⊢F ⊢G (x ⇨ t⇒t′) = fst-subst ⊢F ⊢G x ⇨ fst-subst* ⊢F ⊢G t⇒t′

-- Reducibility of fst with a specific typing derivation
fst′ : ∀ {F G t Γ l l′}
       ([F] : Γ ⊩⟨ l′ ⟩ F)
       ([ΣFG] : Γ ⊩⟨ l ⟩B⟨ BΣ ⟩ Σ F ▹ G)
       ([t] : Γ ⊩⟨ l ⟩ t ∷ Σ F ▹ G / B-intr BΣ [ΣFG])
       → Γ ⊩⟨ l′ ⟩ fst t ∷ F / [F]
fst′ {F = F} {t = t} {Γ = Γ} [F] (noemb (Bᵣ F' G' D ⊢F ⊢G A≡A [F'] [G'] G-ext))
     (Σₜ p d pProd p≅p [fstp] [sndp]) with
       B-PE-injectivity BΣ (whnfRed* (red D) Σₙ)
... | PE.refl , PE.refl =
  let [fstp] : Γ ⊩⟨ _ ⟩ fst p ∷ F / [F]
      [fstp] = irrelevanceTerm′ (wk-id F)
                                ([F'] id (wf ⊢F)) [F]
                                [fstp]
  in  proj₁ (redSubst*Term (fst-subst* ⊢F ⊢G (redₜ d))
                           [F] [fstp])
fst′ {t = t} {Γ = Γ} {l = l} [F] (emb 0<1 x) [t] = fst′ [F] x [t]

-- Reducibility of fst with a general typing derivation
fst″ : ∀ {F G t Γ l l′}
       ([F] : Γ ⊩⟨ l′ ⟩ F)
       ([ΣFG] : Γ ⊩⟨ l ⟩ Σ F ▹ G)
       ([t] : Γ ⊩⟨ l ⟩ t ∷ Σ F ▹ G / [ΣFG])
       → Γ ⊩⟨ l′ ⟩ fst t ∷ F / [F]
fst″ {t = t} {Γ = Γ} {l = l} [F] [ΣFG] [t] =
  let [t]′ = irrelevanceTerm [ΣFG] (B-intr BΣ (Σ-elim [ΣFG])) [t]
  in  fst′ [F] (Σ-elim [ΣFG]) [t]′

fst-cong′ : ∀ {F G t t′ Γ l l′}
            ([F] : Γ ⊩⟨ l′ ⟩ F)
            ([ΣFG] : Γ ⊩⟨ l ⟩B⟨ BΣ ⟩ Σ F ▹ G)
            ([t≡t′] : Γ ⊩⟨ l ⟩ t ≡ t′ ∷ Σ F ▹ G / B-intr BΣ [ΣFG])
            → Γ ⊩⟨ l′ ⟩ fst t ≡ fst t′ ∷ F / [F]
fst-cong′ {F = F} {G = G} {Γ = Γ} [F]
          [ΣFG]@(noemb (Bᵣ F' G' D ⊢F ⊢G A≡A [F'] [G'] G-ext))
          [t≡t′]@(Σₜ₌ p p′ d d′ pProd pProd′ p≅p′ [t] [t′] [fstp] [fstp′] [fst≡] [snd≡]) with
            B-PE-injectivity BΣ (whnfRed* (red D) Σₙ)
... | PE.refl , PE.refl =
  let ⊢Γ = wf ⊢F
      [fstp]₁ = irrelevanceTerm′ (wk-id F) ([F'] id ⊢Γ) [F] [fstp]
      [fstp′]₁ = irrelevanceTerm′ (wk-id F) ([F'] id ⊢Γ) [F] [fstp′]
      [fst≡]₁ = irrelevanceEqTerm′ (wk-id F) ([F'] id ⊢Γ) [F] [fst≡]
      [fstt≡fstp] = proj₂ (redSubst*Term (fst-subst* ⊢F ⊢G (redₜ d)) [F] [fstp]₁)
      [fstt′≡fstp′] = proj₂ (redSubst*Term (fst-subst* ⊢F ⊢G (redₜ d′)) [F] [fstp′]₁)
  in  transEqTerm [F] [fstt≡fstp] (transEqTerm [F] [fst≡]₁ (symEqTerm [F] [fstt′≡fstp′]))
fst-cong′ [F] (emb 0<1 x) = fst-cong′ [F] x

-- Reducibility of congruence of fst
fst-cong″ : ∀ {F G t t′ Γ l l′}
            ([F] : Γ ⊩⟨ l′ ⟩ F)
            ([ΣFG] : Γ ⊩⟨ l ⟩ Σ F ▹ G)
            ([t≡t′] : Γ ⊩⟨ l ⟩ t ≡ t′ ∷ Σ F ▹ G / [ΣFG])
            → Γ ⊩⟨ l′ ⟩ fst t ≡ fst t′ ∷ F / [F]
fst-cong″ {F} {G} [F] [ΣFG] [t≡t′] =
  let [t≡t′] = irrelevanceEqTerm [ΣFG] (B-intr BΣ (Σ-elim [ΣFG])) [t≡t′]
  in  fst-cong′ [F] (Σ-elim [ΣFG]) [t≡t′]

fst-congᵛ : ∀ {F G t t′ Γ l}
            ([Γ] : ⊩ᵛ Γ)
            ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
            ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / [Γ] ∙ [F])
            ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
            ([t′] : Γ ⊩ᵛ⟨ l ⟩ t′ ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
            ([t≡t′] : Γ ⊩ᵛ⟨ l ⟩ t ≡ t′ ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
          → Γ ⊩ᵛ⟨ l ⟩ fst t ≡ fst t′ ∷ F / [Γ] / [F]
fst-congᵛ {F} {G} [Γ] [F] [G] [t] [t′] [t≡t′] ⊢Δ [σ] =
  let [ΣFG] = Σᵛ {F} {G} [Γ] [F] [G]
      ⊩σF = proj₁ ([F] ⊢Δ [σ])
      ⊩σΣFG = proj₁ ([ΣFG] ⊢Δ [σ])
      ⊩σt≡t′ = [t≡t′] ⊢Δ [σ]
  in  fst-cong″ ⊩σF ⊩σΣFG ⊩σt≡t′

-- Validity of first projection
fstᵛ : ∀ {F G t Γ l}
       ([Γ] : ⊩ᵛ Γ)
       ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
       ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / [Γ] ∙ [F])
       ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
       → Γ ⊩ᵛ⟨ l ⟩ fst t ∷ F / [Γ] / [F]
fstᵛ {F} {G} {t} {Γ} {l} [Γ] [F] [G] [t] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [ΣFG] = Σᵛ {F} {G} [Γ] [F] [G]
      σfst : ∀ {Δ σ} (⊢Δ : ⊢ Δ) ([σ] : Δ ⊩ˢ σ ∷ Γ / [Γ] / ⊢Δ)
           → Δ ⊩⟨ l ⟩ subst σ (fst t) ∷ subst σ F / proj₁ ([F] ⊢Δ [σ])
      σfst {Δ} {σ} ⊢Δ [σ] =
        let ⊩σF = proj₁ ([F] ⊢Δ [σ])
            ⊩σΣFG = proj₁ ([ΣFG] ⊢Δ [σ])
            ⊩σt = proj₁ ([t] ⊢Δ [σ])
        in  fst″ ⊩σF ⊩σΣFG ⊩σt

  in  σfst ⊢Δ [σ] ,
      (λ {σ′} [σ′] [σ≡σ′] →
        let [σF] = proj₁ ([F] ⊢Δ [σ])
            [σΣFG] = proj₁ ([ΣFG] ⊢Δ [σ])
            [σt≡σ′t] = proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′]
        in  fst-cong″ [σF] [σΣFG] [σt≡σ′t])


module UnSized.SelfRef where

open import Data.Unit.Base
open import Data.Product
open import Data.String.Base
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr)

open import Size
--open import SimpleCell
open import SizedIO.Object
open import SizedIO.IOObject
open import SizedIO.ConsoleObject
-- open import PrimTypeHelpersSmall

open import UnSizedIO.Base hiding (main)
open import UnSizedIO.Console hiding (main)

open import NativeIO
--open import SimpleCell

-- Object Alpha

data AlphaMethod A : Set where
    print : AlphaMethod A
    set : A → AlphaMethod A
    m1 : AlphaMethod A
    m2 : AlphaMethod A

AlphaResponses : {A : Set} (c : AlphaMethod A) → Set
AlphaResponses _  = ⊤

alphaI : (A : Set) → Interface
Method   (alphaI A)   = AlphaMethod A
Result  (alphaI A) m = AlphaResponses m

alphaC : (i : Size) → Set
alphaC i = ConsoleObject i (alphaI String)

--
--  Self Referential: method 'm1' calls method 'm2'
--
{-
-- {-# NON_TERMINATING #-}
alphaO :  ∀{i} (s : String) → alphaC i
method (alphaO s) print =
  exec (putStrLn s) >>
  return (_ , alphaO s)

method (alphaO s) (set x) =
  return (_ , alphaO x)

-- force (method (alphaO s) m1) = exec (putStrLn s) λ _ →
--   method (alphaO s) m2  >>= λ{ (_ , c₀) →
--   return (_ , c₀) }
method (alphaO s) m1 =
  exec1 (putStrLn s) >>
  method (alphaO s) m2  >>= λ{ (_ , c₀) →
  return (_ , c₀) }
method (alphaO s) m2 =
  return (_ , alphaO (s ++ "->m2"))

program : String → IOConsole ∞ Unit
program arg =
  let c₀ = alphaO ("start̄\n====\n\n") in
  method c₀ m1  >>= λ{ (_ , c₁) →   --- ===> m1 called, but m2 prints out text
  method c₁ print  >>= λ{ (_ , c₂) →
  exec1 (putStrLn "\n\n====\nend")        }}

main : NativeIO Unit
main = translateIOConsole (program "")
-}


open import Agda.Primitive.Cubical

record Bad : IUniv where


module FixityOutOfScopeInRecord where

postulate _+_ : Set

record R : Set where
  infixl 30 _+_

-- Should complain that _+_ is not in (the same) scope
-- in (as) its fixity declaration.


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Inference.Solver(x : X) where
  import OutsideIn.Inference.Separator as S
  import OutsideIn.Expressions as E
  import OutsideIn.Constraints as C
  open import Data.Bool renaming (_∧_ to _and_)
  open E(x)
  open S(x)
  open X(x)
  open C(x)

  private module PlusN-m {n} = Monad (PlusN-is-monad {n})
          module QC-f = Functor (qconstraint-is-functor)
          module Ax-f = Functor (axiomscheme-is-functor)
          module Type-f = Functor (type-is-functor)
          module Type-m = Monad (type-is-monad)

  mutual
    data _,_solvI►_ {x : Set}⦃ eq : Eq x ⦄(Q : AxiomScheme x)(Qg : QConstraint x) : {s : Shape} → Implications x s → Set where
      I-ε : Q , Qg solvI► imp-ε
      I-∧ : ∀ {r₁ r₂}{a : Implications x r₁}{b : Implications x r₂}
          → Q , Qg solvI► a → Q , Qg solvI► b → Q , Qg solvI► (a imp-∧ b)
      I-i : ∀ {r}{n}{Qv}{C : SeparatedConstraint _ r}{n′}{θ}
          → ( let peq = (PlusN-eq {n} eq) in  Q , Qg ∧ Qv , n solv► C ↝ n′ , ε , θ)
          → Q , Qg solvI► imp (∃ n · Qv ⊃ C)

    data _,_,_solv►_↝_,_,_ {x : Set}⦃ eq : Eq x ⦄(Q : AxiomScheme x)(Qg : QConstraint x)(n : ℕ) : {s : Shape} →
                        (SeparatedConstraint (x ⨁ n) s) → (m : ℕ) → (Qr : QConstraint (x ⨁ m)) → (θ : x ⨁ n → Type (x ⨁ m)) → Set where
      SOLVE : ∀ {s}{simpl}{imps : Implications _ s}{m}{Qr}{θ}
            → simplifier eq n Q Qg simpl ≡ m , Qr , solved Qr θ
            → let peq = (PlusN-eq {m} eq) in (Ax-f.map (PlusN-m.unit {m}) Q) , (Qr ∧ QC-f.map (PlusN-m.unit {m}) Qg) solvI► substituteImp θ imps
            → Q , Qg , n solv► SC simpl imps ↝ m , Qr , θ

  solveImps : {x : Set}{s : Shape} → (eq : Eq x) → (Q : AxiomScheme x) → (Qg : QConstraint x) → (C : Implications x s)
            → Ⓢ (Q , Qg solvI► C)
  solver′ : {x : Set}{s : Shape} → (eq : Eq x)
          → (n : ℕ) → (Q : AxiomScheme x) → (Qg : QConstraint x) →  (C : SeparatedConstraint (x ⨁ n) s)
          → Ⓢ (∃ (λ m → ∃ (λ θ →  Q , Qg , n solv► C ↝ m , ε , θ)))
  solver′  eq n axioms given (SC simpl imps) with simplifier eq n axioms given simpl | inspect (simplifier eq n axioms given) simpl
  ... | m , ε? , solved .ε? θ | iC prf with is-ε ε?
  solver′  eq n axioms given (SC simpl imps)
      | m , .ε , solved .ε θ | iC prf | yes refl = solveImps (PlusN-eq {m} eq)
                                                             (Ax-f.map (PlusN-m.unit {m}) axioms)
                                                             ( ε ∧ QC-f.map (PlusN-m.unit {m}) given)
                                                             (substituteImp θ imps)
                                               >>= λ impP →  suc (m , θ , SOLVE prf impP)
       where open Monad(Ⓢ-is-monad)
  ...                        | no isntε = zero
  solveImps eq Q Qg imp-ε = suc I-ε
  solveImps eq Q Qg (a imp-∧ b) = solveImps eq Q Qg a
                       >>= λ a′ → solveImps eq Q Qg b
                       >>= λ b′ → suc (I-∧ a′ b′)
       where open Monad(Ⓢ-is-monad)
  solveImps eq Q Qg (imp (∃ n · Qv ⊃ C)) = solver′ eq n Q (Qg ∧ Qv) C >>= λ { (m , θ , prf) → suc (I-i prf) }
       where open Monad(Ⓢ-is-monad)

  solver : {x : Set}{s : Shape} → (eq : Eq x)
         → (n : ℕ) → (Q : AxiomScheme x) → (Qg : QConstraint x) →  (C : SeparatedConstraint (x ⨁ n) s)
         → Ⓢ (∃ (λ m → ∃ (λ Qr → ∃ (λ θ →  Q , Qg , n solv► C ↝ m , Qr , θ))))
  solver eq n Q Qg (SC simpl imps) with simplifier eq n Q Qg simpl | inspect (simplifier eq n Q Qg) simpl
  ... | m , Qr , solved .Qr θ | iC prf = solveImps (PlusN-eq {m} eq)
                                                   (Ax-f.map (PlusN-m.unit {m}) Q)
                                                   (Qr ∧ QC-f.map (PlusN-m.unit {m}) Qg)
                                                   (substituteImp θ imps)
                                     >>= λ prf′ → suc (m , Qr , θ , SOLVE prf prf′)
       where open Monad(Ⓢ-is-monad)


{-# TERMINATING         #-}
{-# NO_POSITIVITY_CHECK #-}
mutual
  data D₁ : Set where
    lam : (D₁ → D₁) → D₁

  Foo₁ : Set
  Foo₁ = Foo₁

{-# NON_TERMINATING     #-}
{-# NO_POSITIVITY_CHECK #-}
mutual
  data D₂ : Set where
    lam : (D₂ → D₂) → D₂

  Foo₂ : Set
  Foo₂ = Foo₂


-- An ATP type must be used with data-types or postulates.

-- This error is detected by Syntax.Translation.ConcreteToAbstract.

module ATPBadType1 where

data Bool : Set where
  false true : Bool

{-# ATP type false #-}


-- New NO_POSITIVITY_CHECK pragma for data definitions and mutual
-- blocks

-- Skipping an old-style mutual block: Somewhere within a `mutual`
-- block before a data definition.
mutual
  data Cheat : Set where
    cheat : Oops → Cheat

  {-# NO_POSITIVITY_CHECK #-}
  data Oops : Set where
    oops : (Cheat → Cheat) → Oops


{-# OPTIONS --safe --no-qualified-instances #-}
module CF.Transform.Compile.Expressions where

open import Function using (_∘_)
open import Level
open import Data.Unit
open import Data.Bool
open import Data.Product as P
open import Data.List as L hiding (null; [_])
open import Data.List.Membership.Propositional
open import Data.List.Membership.Propositional.Properties
open import Data.List.Relation.Unary.All
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Unary hiding (_∈_)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Monad
open import Relation.Ternary.Construct.Bag.Properties

private
  module Src where
    open import CF.Syntax.DeBruijn public
    open import CF.Types public
    open import CF.Contexts.Lexical using (module DeBruijn) public; open DeBruijn public

  module Tgt where
    open import JVM.Types public
    open import JVM.Model StackTy public
    open import JVM.Syntax.Values public
    open import JVM.Syntax.Instructions public

open Src
open Tgt

open import JVM.Compiler
open import CF.Transform.Compile.ToJVM

-- Compilation of CF expressions
compileₑₛ : ∀ {as ψ Γ} → Exps as Γ → ε[ Compiler ⟦ Γ ⟧ ψ (⟦ as ⟧ ++ ψ) Emp ]

compileₑ  : ∀ {a ψ Γ}  → Exp a Γ   → ε[ Compiler ⟦ Γ ⟧ ψ (⟦ a ⟧ ∷ ψ) Emp ]

compileₑ (unit) = do
  code (push (bool true))

compileₑ (num x) = do
  code (push (num x))

compileₑ (bool b) = do
  code (push (bool b))

compileₑ (var' x) = do
  code (load ⟦ x ⟧)

compileₑ (bop f e₁ e₂) = do
  compileₑ e₁
  compileₑ e₂
  compile-bop f

  where

    -- a < b compiles to (assume a and b on stack):
    --
    --     if_icmplt l⁻
    --     iconst_1
    --     goto e⁻
    -- l⁺: iconst_0
    -- e⁺: nop
    --
    -- Other comparisons go similar
    compile-comp : ∀ {Γ as} → Comparator as → ε[ Compiler Γ (as ++ ψ) (boolean ∷ ψ) Emp ]
    compile-comp cmp = do
      ↓ lfalse⁻ ∙⟨ σ ⟩ lfalse⁺ ← ✴-swap ⟨$⟩ freshLabel
      lfalse⁺                  ← ✴-id⁻ˡ ⟨$⟩ (code (if cmp lfalse⁻) ⟨ Up _  # σ ⟩& lfalse⁺)
      lfalse⁺                  ← ✴-id⁻ˡ ⟨$⟩ (code (push (bool false)) ⟨ Up _  # ∙-idˡ ⟩& lfalse⁺)
      ↓ lend⁻ ∙⟨ σ ⟩ labels    ← (✴-rotateₗ ∘ ✴-assocᵣ) ⟨$⟩ (freshLabel ⟨ Up _  # ∙-idˡ ⟩& lfalse⁺)
      lfalse⁺ ∙⟨ σ ⟩ lend⁺     ← ✴-id⁻ˡ ⟨$⟩ (code (goto lend⁻) ⟨ _ ✴ _ # σ ⟩& labels)
      lend⁺                    ← ✴-id⁻ˡ ⟨$⟩ (attach lfalse⁺ ⟨ Up _ # σ ⟩& lend⁺)
      code (push (bool true))
      attach lend⁺

    -- Compile comparisons and other binary operations
    compile-bop : ∀ {Γ a b c} → BinOp a b c → ε[ Compiler Γ (⟦ b ⟧ ∷ ⟦ a ⟧ ∷ ψ) (⟦ c ⟧ ∷ ψ) Emp ]
    compile-bop add = code (bop add)
    compile-bop sub = code (bop sub)
    compile-bop mul = code (bop mul)
    compile-bop div = code (bop div)
    compile-bop xor = code (bop xor)
    compile-bop eq  = compile-comp icmpeq
    compile-bop ne  = compile-comp icmpne
    compile-bop lt  = compile-comp icmplt
    compile-bop ge  = compile-comp icmpge
    compile-bop gt  = compile-comp icmpgt
    compile-bop le  = compile-comp icmplt

compileₑ (ifthenelse c e₁ e₂) = do
  -- condition
  compileₑ c
  lthen+ ∙⟨ σ ⟩ ↓ lthen-  ← freshLabel
  lthen+                  ← ✴-id⁻ˡ ⟨$⟩ (code (if ne lthen-) ⟨ Up _  # ∙-comm σ     ⟩& lthen+)

  -- else
  compileₑ e₂
  ↓ lend- ∙⟨ σ ⟩ labels   ← (✴-rotateₗ ∘ ✴-assocᵣ) ⟨$⟩ (freshLabel ⟨ Up _  # ∙-idˡ        ⟩& lthen+)

  -- then
  lthen+ ∙⟨ σ ⟩ lend+     ← ✴-id⁻ˡ ⟨$⟩ (code (goto lend-) ⟨ _ ✴ _ # σ ⟩& labels)
  lend+                   ← ✴-id⁻ˡ ⟨$⟩ (attach lthen+ ⟨ Up _  # σ ⟩& lend+)
  compileₑ e₁

  -- label the end
  attach lend+

compileₑₛ [] = return refl
compileₑₛ (e ∷ es) = do
  compileₑₛ es
  compileₑ e


------------------------------------------------------------------------
-- Functional semantics for a non-deterministic untyped λ-calculus
-- with constants
------------------------------------------------------------------------

{-# OPTIONS --no-termination-check #-}

module Lambda.Closure.Functional.Non-deterministic.No-workarounds where

open import Category.Monad.Partiality as Pa using (_⊥; now; later)
open import Codata.Musical.Notation
open import Data.Fin using (Fin; zero; suc; #_)
open import Data.List hiding (lookup)
open import Data.Maybe hiding (_>>=_)
open import Data.Nat
open import Data.Vec using ([]; _∷_; lookup)
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Nullary.Decidable

open import Lambda.Syntax using (Ty; Ctxt)
open Lambda.Syntax.Closure using (con; ƛ)
open Lambda.Syntax.Ty
open import Lambda.VirtualMachine
  hiding (comp; comp-val; comp-env; lookup-hom)
open Functional
private
  module VM = Lambda.Syntax.Closure Code

------------------------------------------------------------------------
-- A monad with partiality, failure and non-determinism

-- This is basically the maybe monad transformer applied to the
-- partiality monad transformer applied to the non-determinism monad
-- N A = μX. A ⊎ X × X. Unfortunately it is somewhat awkward to
-- implement the partiality monad transformer in Agda: the definition
--
--   data Partiality′ (M : Set → Set) (A : Set) : Set where
--     now-or-later : M (A ⊎ Partiality′ M A) → Partiality′ M A
--
-- is rejected, because M might use its argument negatively.

infixr 6 _∣_

data D (A : Set) : Set where
  fail   : D A
  return : (x : A) → D A
  _∣_    : (x y : D A) → D A
  later  : (x : ∞ (D A)) → D A

-- The function force n removes (up to) n layers of later
-- constructors.

force : {A : Set} → ℕ → D A → D A
force (suc n) (later x) = force n (♭ x)
force n       (x₁ ∣ x₂) = force n x₁ ∣ force n x₂
force _       x         = x

-- Bind.

infixl 5 _>>=_

_>>=_ : {A B : Set} → D A → (A → D B) → D B
fail      >>= f = fail
return x  >>= f = f x
(x₁ ∣ x₂) >>= f = (x₁ >>= f) ∣ (x₂ >>= f)
later x   >>= f = later (♯ (♭ x >>= f))

-- A deterministic non-terminating computation.

never : {A : Set} → D A
never = later (♯ never)

-- Strong bisimilarity.

infix 4 _≅_

data _≅_ {A : Set} : D A → D A → Set where
  fail   : fail ≅ fail
  return : ∀ {x} → return x ≅ return x
  _∣_    : ∀ {x₁ x₂ y₁ y₂}
           (x₁≅y₁ : x₁ ≅ y₁) (x₂≅y₂ : x₂ ≅ y₂) → x₁ ∣ x₂ ≅ y₁ ∣ y₂
  later  : ∀ {x y} (x≅y : ∞ (♭ x ≅ ♭ y)) → later x ≅ later y

-- Strong bisimilarity is reflexive.

infixr 3 _∎

_∎ : {A : Set} (x : D A) → x ≅ x
fail     ∎ = fail
return x ∎ = return
x₁ ∣ x₂  ∎ = (x₁ ∎) ∣ (x₂ ∎)
later x  ∎ = later (♯ (♭ x ∎))

-- Strong bisimilarity is symmetric.

sym : {A : Set} {x y : D A} → x ≅ y → y ≅ x
sym fail            = fail
sym return          = return
sym (x₁≅y₁ ∣ x₂≅y₂) = sym x₁≅y₁ ∣ sym x₂≅y₂
sym (later x≅y)     = later (♯ sym (♭ x≅y))

-- Strong bisimilarity is transitive.

infixr 2 _≅⟨_⟩_

_≅⟨_⟩_ : ∀ {A : Set} (x : D A) {y z} → x ≅ y → y ≅ z → x ≅ z
._ ≅⟨ fail          ⟩ fail          = fail
._ ≅⟨ return        ⟩ return        = return
._ ≅⟨ x₁≅y₁ ∣ x₂≅y₂ ⟩ y₁≅z₁ ∣ y₂≅z₂ = (_ ≅⟨ x₁≅y₁ ⟩ y₁≅z₁) ∣ (_ ≅⟨ x₂≅y₂ ⟩ y₂≅z₂)
._ ≅⟨ later x≅y     ⟩ later y≅z     = later (♯ (_ ≅⟨ ♭ x≅y ⟩ ♭ y≅z))

-- The monad laws hold up to strong bisimilarity.

left-identity : {A B : Set} {x : A} {f : A → D B} →
                return x >>= f ≅ f x
left-identity {x = x} {f} = f x ∎

right-identity : {A : Set} (x : D A) → x >>= return ≅ x
right-identity fail       = fail
right-identity (return x) = return
right-identity (x₁ ∣ x₂)  = right-identity x₁ ∣ right-identity x₂
right-identity (later x)  = later (♯ right-identity (♭ x))

associative : {A B C : Set} (x : D A) {f : A → D B} {g : B → D C} →
              x >>= f >>= g ≅ x >>= λ y → f y >>= g
associative fail               = fail
associative (return x) {f} {g} = f x >>= g ∎
associative (x₁ ∣ x₂)          = associative x₁ ∣ associative x₂
associative (later x)          = later (♯ associative (♭ x))

-- Bind respects strong bisimilarity.

infixl 5 _>>=-cong_

_>>=-cong_ : {A B : Set} {x₁ x₂ : D A} {f₁ f₂ : A → D B} →
             x₁ ≅ x₂ → (∀ y → f₁ y ≅ f₂ y) → x₁ >>= f₁ ≅ x₂ >>= f₂
fail          >>=-cong f₁≅f₂ = fail
return        >>=-cong f₁≅f₂ = f₁≅f₂ _
later x≅y     >>=-cong f₁≅f₂ = later (♯ (♭ x≅y >>=-cong f₁≅f₂))
x₁≅x₂ ∣ y₁≅y₂ >>=-cong f₁≅f₂ =
  (x₁≅x₂ >>=-cong f₁≅f₂) ∣ (y₁≅y₂ >>=-cong f₁≅f₂)

-- More laws.

never-left-zero : {A B : Set} {f : A → D B} → never >>= f ≅ never
never-left-zero = later (♯ never-left-zero)

fail-left-zero : {A B : Set} {f : A → D B} → fail >>= f ≅ fail
fail-left-zero = fail ∎

------------------------------------------------------------------------
-- Syntax

infixl 9 _·_

data Tm (n : ℕ) : Set where
  con : (i : ℕ) → Tm n
  var : (x : Fin n) → Tm n
  ƛ   : (t : Tm (suc n)) → Tm n
  _·_ : (t₁ t₂ : Tm n) → Tm n
  _∣_ : (t₁ t₂ : Tm n) → Tm n

-- Convenient helper.

vr : ∀ m {n} {m<n : True (suc m ≤? n)} → Tm n
vr _ {m<n = m<n} = var (#_ _ {m<n = m<n})

open Lambda.Syntax.Closure Tm hiding (con; ƛ)

------------------------------------------------------------------------
-- Semantics

infix 9 _∙_

mutual

  ⟦_⟧ : ∀ {n} → Tm n → Env n → D Value
  ⟦ con i ⟧   ρ = return (con i)
  ⟦ var x ⟧   ρ = return (lookup ρ x)
  ⟦ ƛ t ⟧     ρ = return (ƛ t ρ)
  ⟦ t₁ · t₂ ⟧ ρ = ⟦ t₁ ⟧ ρ >>= λ v₁ →
                  ⟦ t₂ ⟧ ρ >>= λ v₂ →
                  v₁ ∙ v₂
  ⟦ t₁ ∣ t₂ ⟧ ρ = ⟦ t₁ ⟧ ρ ∣ ⟦ t₂ ⟧ ρ

  _∙_ : Value → Value → D Value
  con i  ∙ v₂ = fail
  ƛ t₁ ρ ∙ v₂ = later (♯ (⟦ t₁ ⟧ (v₂ ∷ ρ)))

-- An abbreviation.

infix 9 _⟦·⟧_

_⟦·⟧_ : D Value → D Value → D Value
v₁ ⟦·⟧ v₂ = v₁ >>= λ v₁ → v₂ >>= λ v₂ → v₁ ∙ v₂

------------------------------------------------------------------------
-- Compiler

-- The compiler takes a code continuation.
--
-- Non-determinism is resolved by always picking the left choice.

comp : ∀ {n} → Tm n → Code n → Code n
comp (con i)   c = con i ∷ c
comp (var x)   c = var x ∷ c
comp (ƛ t)     c = clo (comp t [ ret ]) ∷ c
comp (t₁ · t₂) c = comp t₁ (comp t₂ (app ∷ c))
comp (t₁ ∣ t₂) c = comp t₁ c

-- Environments and values can also be compiled.

mutual

  comp-env : ∀ {n} → Env n → VM.Env n
  comp-env []      = []
  comp-env (v ∷ ρ) = comp-val v ∷ comp-env ρ

  comp-val : Value → VM.Value
  comp-val (con i) = con i
  comp-val (ƛ t ρ) = ƛ (comp t [ ret ]) (comp-env ρ)

-- lookup x is homomorphic with respect to comp-env/comp-val.

lookup-hom : ∀ {n} (x : Fin n) ρ →
             lookup (comp-env ρ) x ≡ comp-val (lookup ρ x)
lookup-hom zero    (v ∷ ρ) = P.refl
lookup-hom (suc x) (v ∷ ρ) = lookup-hom x ρ

------------------------------------------------------------------------
-- Examples

-- A non-terminating term.

Ω : Tm 0
Ω = ω · ω
  where ω = ƛ (vr 0 · vr 0)

Ω-loops : ⟦ Ω ⟧ [] ≅ never
Ω-loops = later (♯ Ω-loops)

-- A call-by-value fix-point combinator.

Z : {n : ℕ} → Tm n
Z = ƛ (t · t)
  where t = ƛ (vr 1 · ƛ (vr 1 · vr 1 · vr 0))

-- A non-deterministically non-terminating term.

! : Tm 0
! = Z · ƛ (ƛ (vr 1 · vr 0 ∣ vr 1 · vr 0)) · con 0

-- Its semantics.

!-sem : D Value
!-sem = later (♯ later (♯ later (♯ later (♯ (!-sem ∣ !-sem)))))

⟦!⟧≅!-sem : ⟦ ! ⟧ [] ≅ !-sem
⟦!⟧≅!-sem = later (♯ lem)
  where
  lem : force 1 (⟦ ! ⟧ []) ≅ force 1 !-sem
  lem = later (♯ later (♯ later (♯ (later (♯ lem) ∣ later (♯ lem)))))

-- How did I come up with this proof term? Through a manual
-- calculation...
--
-- Let us first define some abbreviations:
--
--   t₀ = vr 1 · vr 1 · vr 0
--   t₁ = ƛ t₀
--   t₂ = vr 1 · t₁
--   t₃ = ƛ t₂
--
--   u₀ = vr 1 · vr 0
--   u₁ = u₀ ∣ u₀
--   u₂ = ƛ u₁
--   u₃ = ƛ u₂
--
--   c₀ = ƛ u₂ []
--   c₁ = ƛ t₂ (c₀ ∷ [])
--   c₂ = ƛ t₀ (c₁ ∷ c₀ ∷ [])
--
-- Now we can calculate as follows (ignoring ♯):
--
--   ⟦ Z · u₃ · con 0 ⟧ []
-- = ⟦ Z · u₃ ⟧ [] ⟦·⟧ return (con 0)
-- = ƛ (t₃ · t₃) [] ∙ c₀ ⟦·⟧ return (con 0)
-- = later (⟦ t₃ · t₃ ⟧ (c₀ ∷ []) ⟦·⟧ return (con 0))
-- = later (c₁ ∙ c₁ ⟦·⟧ return (con 0))
--
-- = c₁ ∙ c₁ ⟦·⟧ return (con 0)
-- = later (⟦ t₂ ⟧ (c₁ ∷ c₀ ∷ []) ⟦·⟧ return (con 0))
-- = later (c₀ ∙ c₂ ⟦·⟧ return (con 0))
-- = later (later (⟦ u₂ ⟧ (c₂ ∷ []) ⟦·⟧ return (con 0)))
-- = later (later (ƛ u₁ (c₂ ∷ []) ∙ con 0))
-- = later (later (later (⟦ u₁ ⟧ (con 0 ∷ c₂ ∷ []))))
-- = later (later (later (⟦ u₀ ⟧ (con 0 ∷ c₂ ∷ []) ∣
--                        ⟦ u₀ ⟧ (con 0 ∷ c₂ ∷ []))))
-- = later (later (later (c₂ ∙ con 0 ∣ c₂ ∙ con 0)))
-- = later (later (later (⟦ t₀ ⟧ (con 0 ∷ c₁ ∷ c₀ ∷ []) ∣
--                        ⟦ t₀ ⟧ (con 0 ∷ c₁ ∷ c₀ ∷ []))))
-- = later (later (later (later (c₁ ∙ c₁ ⟦·⟧ return (con 0)) ∣
--                        later (c₁ ∙ c₁ ⟦·⟧ return (con 0)))))

------------------------------------------------------------------------
-- A relation relating deterministic and non-deterministic
-- computations

-- x ≈∈ y means that x implements /one/ possible semantics of y (up to
-- weak bisimilarity).

infix 4 _≈∈_

data _≈∈_ {A : Set} : Maybe A ⊥ → D A → Set where
  fail   : now nothing ≈∈ fail

  return : ∀ {x} → now (just x) ≈∈ return x

  ∣ˡ     : ∀ {x y₁ y₂} (x≈∈y₁ : x ≈∈ y₁) → x ≈∈ y₁ ∣ y₂
  ∣ʳ     : ∀ {x y₁ y₂} (x≈∈y₂ : x ≈∈ y₂) → x ≈∈ y₁ ∣ y₂

  later  : ∀ {x y} (x≈∈y : ∞ (♭ x ≈∈ ♭ y)) → later x ≈∈ later y
  laterˡ : ∀ {x y} (x≈∈y :    ♭ x ≈∈   y ) → later x ≈∈       y
  laterʳ : ∀ {x y} (x≈∈y :      x ≈∈ ♭ y ) →       x ≈∈ later y

-- A transitivity-like result for _≡_ and _≈∈_.

infixr 2 _≡⟨_⟩_

_≡⟨_⟩_ : ∀ {A : Set} (x : Maybe A ⊥) {y z} → x ≡ y → y ≈∈ z → x ≈∈ z
_ ≡⟨ P.refl ⟩ y≈z = y≈z

-- A transitivity-like result for _≈∈_ and _≅_.

infixr 2 _≈∈⟨_⟩_

_≈∈⟨_⟩_ : ∀ {A : Set} (x : Maybe A ⊥) {y z} → x ≈∈ y → y ≅ z → x ≈∈ z
._ ≈∈⟨ fail        ⟩ fail          = fail
._ ≈∈⟨ return      ⟩ return        = return
_  ≈∈⟨ ∣ˡ x₁≈∈y₁   ⟩ y₁≅z₁ ∣ y₂≅z₂ = ∣ˡ (_ ≈∈⟨ x₁≈∈y₁ ⟩ y₁≅z₁)
_  ≈∈⟨ ∣ʳ x₂≈∈y₂   ⟩ y₁≅z₁ ∣ y₂≅z₂ = ∣ʳ (_ ≈∈⟨ x₂≈∈y₂ ⟩ y₂≅z₂)
._ ≈∈⟨ later  x≈∈y ⟩ later y≅z     = later (♯ (_ ≈∈⟨ ♭ x≈∈y ⟩ ♭ y≅z))
._ ≈∈⟨ laterˡ x≈∈y ⟩       y≅z     = laterˡ   (_ ≈∈⟨   x≈∈y ⟩   y≅z)
_  ≈∈⟨ laterʳ x≈∈y ⟩ later y≅z     = laterʳ   (_ ≈∈⟨   x≈∈y ⟩ ♭ y≅z)

-- An example.

lemma : Pa.never ≈∈ !-sem
lemma = later (♯ later (♯ later (♯ later (♯ ∣ˡ lemma))))

------------------------------------------------------------------------
-- Compiler correctness

module Correctness where

  mutual

    correct :
      ∀ {n} t {ρ : Env n} {c s} {k : Value → D VM.Value} →
      (∀ v → exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≈∈ k v) →
      exec ⟨ comp t c , s , comp-env ρ ⟩ ≈∈ (⟦ t ⟧ ρ >>= k)
    correct (con i) {ρ} {c} {s} {k} hyp = laterˡ (
      exec ⟨ c , val (con i) ∷ s , comp-env ρ ⟩  ≈∈⟨ hyp (con i) ⟩
      k (con i)                                  ∎)
    correct (var x) {ρ} {c} {s} {k} hyp = laterˡ (
      exec ⟨ c , val (lookup (comp-env ρ) x) ∷ s , comp-env ρ ⟩  ≡⟨ P.cong (λ v → exec ⟨ c , val v ∷ s , comp-env ρ ⟩) (lookup-hom x ρ) ⟩
      exec ⟨ c , val (comp-val (lookup ρ x)) ∷ s , comp-env ρ ⟩  ≈∈⟨ hyp (lookup ρ x) ⟩
      k (lookup ρ x)                                             ∎)
    correct (ƛ t) {ρ} {c} {s} {k} hyp = laterˡ (
      exec ⟨ c , val (comp-val (ƛ t ρ)) ∷ s , comp-env ρ ⟩  ≈∈⟨ hyp (ƛ t ρ) ⟩
      k (ƛ t ρ)                                             ∎)
    correct (t₁ · t₂) {ρ} {c} {s} {k} hyp =
      exec ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩      ≈∈⟨ correct t₁ (λ v₁ → correct t₂ (λ v₂ → ∙-correct v₁ v₂ hyp)) ⟩
      (⟦ t₁ ⟧ ρ >>= λ v₁ →  ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂  >>= k)  ≅⟨ ((⟦ t₁ ⟧ ρ ∎) >>=-cong λ _ → sym $ associative (⟦ t₂ ⟧ ρ)) ⟩
      (⟦ t₁ ⟧ ρ >>= λ v₁ → (⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂) >>= k)  ≅⟨ sym $ associative (⟦ t₁ ⟧ ρ) ⟩
      (⟦ t₁ ⟧ ρ ⟦·⟧ ⟦ t₂ ⟧ ρ >>= k)                              ≅⟨ _ ∎ ⟩
      (⟦ t₁ · t₂ ⟧ ρ >>= k)                                      ∎
    correct (t₁ ∣ t₂) {ρ} {c} {s} {k} hyp =
      exec ⟨ comp t₁ c , s , comp-env ρ ⟩  ≈∈⟨ ∣ˡ (correct t₁ hyp) ⟩
      (⟦ t₁ ⟧ ρ >>= k) ∣ (⟦ t₂ ⟧ ρ >>= k)  ∎

    ∙-correct :
      ∀ {n} v₁ v₂ {ρ : Env n} {c s} {k : Value → D VM.Value} →
      (∀ v → exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≈∈ k v) →
      exec ⟨ app ∷ c , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s , comp-env ρ ⟩ ≈∈
      v₁ ∙ v₂ >>= k
    ∙-correct (con i)   v₂                 _   = fail
    ∙-correct (ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} hyp =
      exec ⟨ app ∷ c , val (comp-val v₂) ∷ val (comp-val (ƛ t₁ ρ₁)) ∷ s , comp-env ρ ⟩  ≈∈⟨ later (♯ (

        exec ⟨ comp t₁ [ ret ] , ret c (comp-env ρ) ∷ s , comp-env (v₂ ∷ ρ₁) ⟩                ≈∈⟨ correct t₁ (λ v → laterˡ (hyp v)) ⟩
        (⟦ t₁ ⟧ (v₂ ∷ ρ₁) >>= k)                                                              ∎)) ⟩

      (ƛ t₁ ρ₁ ∙ v₂ >>= k)                                                              ∎

correct : ∀ t →
          exec ⟨ comp t [] , [] , [] ⟩ ≈∈
          ⟦ t ⟧ [] >>= λ v → return (comp-val v)
correct t = Correctness.correct t (λ _ → return)

------------------------------------------------------------------------
-- Type system (following Leroy and Grall)

infix 4 _⊢_∈_

data _⊢_∈_ {n} (Γ : Ctxt n) : Tm n → Ty → Set where
  con : ∀ {i} → Γ ⊢ con i ∈ nat
  var : ∀ {x} → Γ ⊢ var x ∈ lookup Γ x
  ƛ   : ∀ {t σ τ} (t∈ : ♭ σ ∷ Γ ⊢ t ∈ ♭ τ) → Γ ⊢ ƛ t ∈ σ ⇾ τ
  _·_ : ∀ {t₁ t₂ σ τ} (t₁∈ : Γ ⊢ t₁ ∈ σ ⇾ τ) (t₂∈ : Γ ⊢ t₂ ∈ ♭ σ) →
        Γ ⊢ t₁ · t₂ ∈ ♭ τ
  _∣_ : ∀ {t₁ t₂ σ} (t₁∈ : Γ ⊢ t₁ ∈ σ) (t₂∈ : Γ ⊢ t₂ ∈ σ) →
        Γ ⊢ t₁ ∣ t₂ ∈ σ

-- Ω is well-typed.

Ω-well-typed : (τ : Ty) → [] ⊢ Ω ∈ τ
Ω-well-typed τ =
  _·_ {σ = ♯ σ} {τ = ♯ τ} (ƛ (var · var)) (ƛ (var · var))
  where σ = ♯ σ ⇾ ♯ τ

-- The call-by-value fix-point combinator is also well-typed.

fix-well-typed :
  ∀ {σ τ} → [] ⊢ Z ∈ ♯ (♯ (σ ⇾ τ) ⇾ ♯ (σ ⇾ τ)) ⇾ ♯ (σ ⇾ τ)
fix-well-typed =
  ƛ (_·_ {σ = υ} {τ = ♯ _}
         (ƛ (var · ƛ (var · var · var)))
         (ƛ (var · ƛ (var · var · var))))
  where
  υ : ∞ Ty
  υ = ♯ (υ ⇾ ♯ _)

------------------------------------------------------------------------
-- Type soundness

-- WF-Value, WF-Env and WF-DV specify when a
-- value/environment/computation is well-formed with respect to a
-- given context (and type).

mutual

  data WF-Value : Ty → Value → Set where
    con : ∀ {i} → WF-Value nat (con i)
    ƛ   : ∀ {n Γ σ τ} {t : Tm (1 + n)} {ρ}
          (t∈ : ♭ σ ∷ Γ ⊢ t ∈ ♭ τ) (ρ-wf : WF-Env Γ ρ) →
          WF-Value (σ ⇾ τ) (ƛ t ρ)

  infixr 5 _∷_

  data WF-Env : ∀ {n} → Ctxt n → Env n → Set where
    []  : WF-Env [] []
    _∷_ : ∀ {n} {Γ : Ctxt n} {ρ σ v}
          (v-wf : WF-Value σ v) (ρ-wf : WF-Env Γ ρ) →
          WF-Env (σ ∷ Γ) (v ∷ ρ)

data WF-DV (σ : Ty) : D Value → Set where
  return : ∀ {v} (v-wf : WF-Value σ v) → WF-DV σ (return v)
  _∣_    : ∀ {x y}
           (x-wf : WF-DV σ x) (y-wf : WF-DV σ y) → WF-DV σ (x ∣ y)
  later  : ∀ {x} (x-wf : ∞ (WF-DV σ (♭ x))) → WF-DV σ (later x)

-- Variables pointing into a well-formed environment refer to
-- well-formed values.

lookup-wf : ∀ {n Γ ρ} (x : Fin n) → WF-Env Γ ρ →
            WF-Value (lookup Γ x) (lookup ρ x)
lookup-wf zero    (v-wf ∷ ρ-wf) = v-wf
lookup-wf (suc x) (v-wf ∷ ρ-wf) = lookup-wf x ρ-wf

-- If we can prove WF-DV σ x, then x does not "go wrong".

does-not-go-wrong : ∀ {σ x} → WF-DV σ x → ¬ now nothing ≈∈ x
does-not-go-wrong (return v-wf) ()
does-not-go-wrong (x-wf ∣ y-wf) (∣ˡ x↯)     = does-not-go-wrong x-wf x↯
does-not-go-wrong (x-wf ∣ y-wf) (∣ʳ y↯)     = does-not-go-wrong y-wf y↯
does-not-go-wrong (later x-wf)  (laterʳ x↯) =
  does-not-go-wrong (♭ x-wf) x↯

-- Bind preserves WF-DV in the following way:

_>>=-cong-WF_ :
  ∀ {σ τ x f} →
  WF-DV σ x → (∀ {v} → WF-Value σ v → WF-DV τ (f v)) →
  WF-DV τ (x >>= f)
return v-wf   >>=-cong-WF f-wf = f-wf v-wf
(x-wf ∣ y-wf) >>=-cong-WF f-wf = (x-wf >>=-cong-WF f-wf)
                               ∣ (y-wf >>=-cong-WF f-wf)
later x-wf    >>=-cong-WF f-wf = later (♯ (♭ x-wf >>=-cong-WF f-wf))

-- Well-typed programs do not "go wrong".

mutual

  ⟦⟧-wf : ∀ {n Γ} (t : Tm n) {σ} → Γ ⊢ t ∈ σ →
          ∀ {ρ} → WF-Env Γ ρ → WF-DV σ (⟦ t ⟧ ρ)
  ⟦⟧-wf (con i)   con             ρ-wf = return con
  ⟦⟧-wf (var x)   var             ρ-wf = return (lookup-wf x ρ-wf)
  ⟦⟧-wf (ƛ t)     (ƛ t∈)          ρ-wf = return (ƛ t∈ ρ-wf)
  ⟦⟧-wf (t₁ ∣ t₂) (t₁∈ ∣ t₂∈)     ρ-wf = ⟦⟧-wf t₁ t₁∈ ρ-wf
                                       ∣ ⟦⟧-wf t₂ t₂∈ ρ-wf
  ⟦⟧-wf (t₁ · t₂) (t₁∈ · t₂∈) {ρ} ρ-wf =
    ⟦⟧-wf t₁ t₁∈ ρ-wf >>=-cong-WF λ f-wf →
    ⟦⟧-wf t₂ t₂∈ ρ-wf >>=-cong-WF λ v-wf →
    ∙-wf f-wf v-wf

  ∙-wf : ∀ {σ τ f v} →
         WF-Value (σ ⇾ τ) f → WF-Value (♭ σ) v →
         WF-DV (♭ τ) (f ∙ v)
  ∙-wf (ƛ t₁∈ ρ₁-wf) v₂-wf = later (♯ ⟦⟧-wf _ t₁∈ (v₂-wf ∷ ρ₁-wf))

type-soundness : ∀ {t : Tm 0} {σ} →
                 [] ⊢ t ∈ σ → ¬ now nothing ≈∈ ⟦ t ⟧ []
type-soundness t∈ = does-not-go-wrong (⟦⟧-wf _ t∈ [])


open import Prelude hiding (⊥)

module Implicits.Resolution.Infinite.Algorithm where

open import Data.Bool
open import Data.Unit.Base
open import Data.Maybe using (is-just; functor)
open import Coinduction
open import Data.Fin.Substitution
open import Data.Vec hiding (_>>=_)
open import Data.List hiding (monad)
open import Data.List.Any hiding (tail)
open import Data.Maybe hiding (monad; module Eq)

open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Implicits.Syntax.Type.Unification
open import Implicits.Resolution.Termination

open import Category.Monad
open import Category.Functor
open import Category.Monad.Partiality as P
open import Category.Monad.Partiality.All
private module M {f} = RawMonad (monad {f})
private module MaybeFunctor {f} = RawFunctor (functor {f})
open import Induction.WellFounded
open import Induction.Nat

module _ where
  open P.Workaround

  m<-Acc : ∀ {m ν} → MetaType m ν → Set
  m<-Acc {m} {ν} r = Acc _m<_ (m , ν , r)

  mutual

    map-bool' : ∀ {A : Set} → A → Bool → Maybe A ⊥P
    map-bool' u true = now (just u)
    map-bool' u false = now nothing

    delayed-resolve' : ∀ {ν} (Δ : ICtx ν) a → Bool ⊥P
    delayed-resolve' Δ a = (later (♯ (resolve' Δ a)))

    resolve-context' : ∀ {ν m} (Δ : ICtx ν) a → (Maybe (Sub (flip MetaType ν) m zero)) →
                      (Maybe (Sub (flip MetaType ν) m zero)) ⊥P
    resolve-context' Δ a (just u) =
      (delayed-resolve' Δ (from-meta (MetaTypeMetaSubst._/_ a u)))
        >>= (map-bool' u)
    resolve-context' Δ a nothing = now nothing

    -- match' uses MetaType m ν instead of Type ν to be able to distinguish unification variables
    -- from other, non-unifiable tvars.
    -- The difference is subtle but the gist is that we can only unify variables that we open
    -- during matching. Any variables that are already open in the context are fixed.
    match-u' : ∀ {ν m} (Δ : ICtx ν) → (τ : SimpleType ν) → (r : MetaType m ν) →
               m<-Acc r →
              (Maybe (Sub (flip MetaType ν) m zero)) ⊥P
    -- For rule types we first check if b matches our query τ.
    -- If this is the case, we use the unifier to instantiate the unification vars in a and
    -- recursively try to resolve the result.
    match-u' {ν} {m} Δ τ (a ⇒ b) (acc f) =
      (match-u' Δ τ b (f _ (b-m<-a⇒b a b))) >>= (resolve-context' Δ a)

    -- On type vars we simply open it up, adding the tvar to the set of unification variables.
    -- and recursively try to match.
    match-u' Δ τ (∀' a) (acc f) = (match-u' Δ τ (open-meta a) (f _ (open-meta-a-m<-∀'a a))) >>=
      (now ∘ (MaybeFunctor._<$>_ tail))

    -- The only thing left to do is to try and unify τ and x.
    match-u' Δ τ (simpl x) _ = now (mgu (simpl x) τ)

    match' : ∀ {ν} (Δ : ICtx ν) → (τ : SimpleType ν) → Type ν → Bool ⊥P
    match' {ν} Δ τ r = match-u' Δ τ (to-meta {zero} r) (m<-well-founded _) >>= (now ∘ is-just)

    match1st-recover' : ∀ {ν} (Δ ρs : ICtx ν) → (τ : SimpleType ν) → Bool → Bool ⊥P
    match1st-recover' _ _ _ true = now true
    match1st-recover' Δ ρs τ false = match1st' Δ ρs τ

    match1st' : ∀ {ν} (Δ : ICtx ν) → (ρs : ICtx ν) → (τ : SimpleType ν) → Bool ⊥P
    match1st' Δ List.[] _ = now false
    match1st' Δ (x List.∷ ρs) τ = match' Δ τ x >>= (match1st-recover' Δ ρs τ)

    -- resolution in ResP
    resolve' : ∀ {ν} (Δ : ICtx ν) (a : Type ν) → Bool ⊥P
    resolve' Δ (simpl x) = match1st' Δ Δ x
    resolve' Δ (a ⇒ b) = resolve' (a List.∷ Δ) b
    resolve' Δ (∀' a) = resolve' (ictx-weaken Δ) a

module _ where
  open P.Workaround using (⟦_⟧P)
  open P.Workaround.Correct
  open M

  module Eq {l} {A : Set l} where
    open import Relation.Binary.PropositionalEquality as PEq using (_≡_) public
    open module Eq = P.Equality  {A = A} _≡_ public
    open module R  = P.Reasoning (PEq.isEquivalence {A = A}) public

  map-bool : ∀ {A : Set} → A → Bool → (Maybe A) ⊥
  map-bool x b = ⟦ map-bool' x b ⟧P

  delayed-resolve : ∀ {ν} (Δ : ICtx ν) a → Bool ⊥
  delayed-resolve Δ a = ⟦ delayed-resolve' Δ a ⟧P

  resolve-context : ∀ {ν m} (Δ : ICtx ν) a → (Maybe (Sub (flip MetaType ν) m zero)) →
                      (Maybe (Sub (flip MetaType ν) m zero)) ⊥
  resolve-context Δ a p = ⟦ resolve-context' Δ a p ⟧P

  match-u : ∀ {ν m} (Δ : ICtx ν) → SimpleType ν → (r : MetaType m ν) → m<-Acc r →
            (Maybe (Sub (flip MetaType ν) m zero)) ⊥
  match-u Δ τ r f = ⟦ match-u' Δ τ r f ⟧P

  match : ∀ {ν} (Δ : ICtx ν) → (τ : SimpleType ν) → (r : Type ν) → Bool ⊥
  match Δ τ r = ⟦ match' Δ τ r ⟧P

  match1st-recover : ∀ {ν} (Δ : ICtx ν) → (ρs : ICtx ν) → (τ : SimpleType ν) → Bool → Bool ⊥
  match1st-recover Δ ρs τ b = ⟦ match1st-recover' Δ ρs τ b ⟧P

  match1st : ∀ {ν} (Δ : ICtx ν) → (ρs : ICtx ν) → (τ : SimpleType ν) → Bool ⊥
  match1st Δ ρs τ = ⟦ match1st' Δ ρs τ ⟧P

  resolve : ∀ {ν} (Δ : ICtx ν) (r : Type ν) → Bool ⊥
  resolve Δ r = ⟦ resolve' Δ r ⟧P

  --
  -- compositionality of resolution functions
  --

  resolve-context-comp : ∀ {m ν} (Δ : ICtx ν) a u →
                        (resolve-context {ν} {m} Δ a (just u))
                          Eq.≅
                        (delayed-resolve Δ (from-meta (MetaTypeMetaSubst._/_ a u))
                          >>= (map-bool u))
  resolve-context-comp {m} {ν} Δ a u =
    (resolve-context {ν} {m} Δ a (just u))
      Eq.≅⟨ >>=-hom (delayed-resolve' Δ (from-meta (MetaTypeMetaSubst._/_ a u))) _ ⟩
    (delayed-resolve Δ (from-meta (MetaTypeMetaSubst._/_ a u)) >>= (map-bool u)) Eq.∎

  match-u-iabs-comp : ∀ {m ν} (Δ : ICtx ν) τ (a b : MetaType m ν) f →
                      (match-u Δ τ (a ⇒ b) (acc f))
                        Eq.≅
                      ((match-u Δ τ b (f _ (b-m<-a⇒b a b))) >>= (resolve-context Δ a))
  match-u-iabs-comp Δ τ a b f =
    (match-u Δ τ (a ⇒ b) (acc f))
      Eq.≅⟨ >>=-hom (match-u' Δ τ b (f _ (b-m<-a⇒b a b))) _ ⟩
    ((match-u Δ τ b (f _ (b-m<-a⇒b a b))) >>= (resolve-context Δ a)) Eq.∎

  match-u-tabs-comp : ∀ {m ν} (Δ : ICtx ν) τ (r : MetaType m (suc ν)) f →
                                  (match-u Δ τ (∀' r) (acc f))
                                    Eq.≅
                                  ((match-u Δ τ (open-meta r) (f _ (open-meta-a-m<-∀'a r))) >>=
                                    (now ∘ (MaybeFunctor._<$>_ tail)))
  match-u-tabs-comp Δ τ r f =
    match-u Δ τ (∀' r) (acc f)
      Eq.≅⟨ >>=-hom (match-u' Δ τ (open-meta r) (f _ (open-meta-a-m<-∀'a r))) _ ⟩
    ((match-u Δ τ (open-meta r) (f _ (open-meta-a-m<-∀'a r))) >>= (now ∘ (MaybeFunctor._<$>_ tail))) Eq.∎

  match-comp : ∀ {ν} (Δ : ICtx ν) τ r →
               match Δ τ r
                 Eq.≅
               ((match-u Δ τ (to-meta {zero} r) (m<-well-founded _)) >>= (now ∘ is-just))
  match-comp Δ τ r =
    match Δ τ r
      Eq.≅⟨ >>=-hom (match-u' Δ τ (to-meta {zero} r) (m<-well-founded _)) _ ⟩
    _>>=_ (match-u Δ τ (to-meta {zero} r) (m<-well-founded _)) (now ∘ is-just) Eq.∎

  match1st-comp : ∀ {ν} (Δ : ICtx ν) x ρs τ → match1st Δ (x List.∷ ρs) τ Eq.≅ ((match Δ τ x) >>=
                    (match1st-recover Δ ρs τ))
  match1st-comp Δ x ρs τ =
    match1st Δ (x List.∷ ρs) τ
      Eq.≅⟨ >>=-hom (match' Δ τ x) _ ⟩
    ((match Δ τ x) >>= (match1st-recover Δ ρs τ)) Eq.∎


-- Andreas, 2017-08-24, issue #2717, reported by m0davis
--
-- Internal error in DisplayForm.hs triggered by -v 100.
-- Regression introduced by #2590

{-# OPTIONS -v tc.display.top:100 -v tc.polarity.dep:20 #-} -- KEEP

module _ (A : Set) where

module M (_ : Set) where
  data D (n : Set) : Set where
    d : D n

open M A


-- Andreas, 2016-07-28, issue #779

record R : Set1 where

  Bla : Set1
  Bla with Set
  ... | _ = Set

  field
    F : Set

-- Current error:
-- Missing definition for Bla

-- Expected:
-- Success, or error outlawing pattern matching definition before last field.