------------------------------------------------------------------------
-- Lemmas related to application of substitutions
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Data.Application.Application222
  {i u e} {Uni : IndexedUniverse i u e}
  where

import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Data.Application.Application221
open import deBruijn.Substitution.Data.Basics
open import deBruijn.Substitution.Data.Map
open import deBruijn.Substitution.Data.Simple
open import Function using (_$_)
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

-- Lemmas related to application.

record Application₂₂₂
  {t₁} {T₁ : Term-like t₁}
  {t₂} {T₂ : Term-like t₂}

  -- Simple substitutions for the first kind of terms.
  (simple₁ : Simple T₁)

  -- Simple substitutions for the second kind of terms.
  (simple₂ : Simple T₂)

  -- A translation from the first to the second kind of terms.
  (trans : [ T₁ ⟶⁼ T₂ ])
  : Set (i ⊔ u ⊔ e ⊔ t₁ ⊔ t₂) where

  open Term-like T₁ using () renaming (_⊢_ to _⊢₁_)
  open Term-like T₂ using ([_]) renaming (_⊢_ to _⊢₂_; _≅-⊢_ to _≅-⊢₂_)
  open Simple simple₁
    using ()
    renaming ( id to id₁; sub to sub₁; var to var₁
             ; wk to wk₁; wk[_] to wk₁[_]
             ; _↑ to _↑₁; _↑_ to _↑₁_; _↑⁺_ to _↑⁺₁_; _↑₊_ to _↑₊₁_
             ; _↑⋆ to _↑⋆₁; _↑⁺⋆_ to _↑⁺⋆₁_
             )
  open Simple simple₂
    using ()
    renaming ( var to var₂
             ; weaken to weaken₂; weaken[_] to weaken₂[_]; wk⁺ to wk⁺₂
             ; wk-subst to wk-subst₂; wk-subst[_] to wk-subst₂[_]
             ; _↑ to _↑₂; _↑_ to _↑₂_; _↑⁺_ to _↑⁺₂_; _↑₊_ to _↑₊₂_
             )

  field
    application₂₂₁ : Application₂₂₁ simple₁ simple₂ trans

  open Application₂₂₁ application₂₂₁ public

  abstract

    -- A variant of suc-/∋-↑.

    suc-/⊢⋆-↑⋆ :
      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ}
      σ {τ} (x : Γ ∋ τ) (ρs : Subs T₁ ρ̂) →
      var₂ · suc[ σ ] x /⊢⋆ ρs ↑⋆₁ ≅-⊢₂
      var₂ · x /⊢⋆ (ρs ▻ wk₁[ σ /⋆ ρs ])
    suc-/⊢⋆-↑⋆ σ x ε = begin
      [ var₂ · suc x    ]  ≡⟨ P.sym $ var-/⊢-wk-↑⁺ ε x ⟩
      [ var₂ · x /⊢ wk₁ ]  ∎
    suc-/⊢⋆-↑⋆ σ x (ρs ▻ ρ) = begin
      [ var₂ · suc[ σ ] x /⊢⋆ ρs ↑⋆₁ /⊢ ρ ↑₁      ]  ≡⟨ /⊢-cong (suc-/⊢⋆-↑⋆ σ x ρs) (P.refl {x = [ ρ ↑₁ ]}) ⟩
      [ var₂ · x /⊢⋆ ρs /⊢ wk₁[ σ /⋆ ρs ] /⊢ ρ ↑₁ ]  ≡⟨ P.sym $ /⊢-/⊢-wk (σ /⋆ ρs) (var₂ · x /⊢⋆ ρs) ρ ⟩
      [ var₂ · x /⊢⋆ ρs /⊢ ρ /⊢ wk₁               ]  ∎

    -- The antecedent of var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ follows from a less
    -- complicated statement.

    var-/⊢⋆-⇒-var-/⊢⋆-↑⁺⋆ :
      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} {ρs₁ : Subs T₁ ρ̂} {ρs₂ : Subs T₁ ρ̂} →
      (∀ {σ} (x : Γ ∋ σ) → var₂ · x /⊢⋆ ρs₁ ≅-⊢₂ var₂ · x /⊢⋆ ρs₂) →
      ∀ Γ⁺ {σ} (x : Γ ++⁺ Γ⁺ ∋ σ) →
      var₂ · x /⊢⋆ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢₂ var₂ · x /⊢⋆ ρs₂ ↑⁺⋆₁ Γ⁺
    var-/⊢⋆-⇒-var-/⊢⋆-↑⁺⋆                   hyp ε        x    = hyp x
    var-/⊢⋆-⇒-var-/⊢⋆-↑⁺⋆ {ρs₁ = ρs₁} {ρs₂} hyp (Γ⁺ ▻ σ) zero = begin
      [ var₂ · zero /⊢⋆ ρs₁ ↑⁺⋆₁ (Γ⁺ ▻ σ) ]  ≡⟨ zero-/⊢⋆-↑⋆ σ (ρs₁ ↑⁺⋆₁ Γ⁺) ⟩
      [ var₂ · zero                       ]  ≡⟨ P.sym $ zero-/⊢⋆-↑⋆ σ (ρs₂ ↑⁺⋆₁ Γ⁺) ⟩
      [ var₂ · zero /⊢⋆ ρs₂ ↑⁺⋆₁ (Γ⁺ ▻ σ) ]  ∎
    var-/⊢⋆-⇒-var-/⊢⋆-↑⁺⋆ {ρs₁ = ρs₁} {ρs₂} hyp (Γ⁺ ▻ σ) (suc x) = begin
      [ var₂ · suc x /⊢⋆ ρs₁ ↑⁺⋆₁ (Γ⁺ ▻ σ)  ]  ≡⟨ suc-/⊢⋆-↑⋆ σ x (ρs₁ ↑⁺⋆₁ Γ⁺) ⟩
      [ var₂ · x     /⊢⋆ ρs₁ ↑⁺⋆₁ Γ⁺ /⊢ wk₁ ]  ≡⟨ /⊢-cong (var-/⊢⋆-⇒-var-/⊢⋆-↑⁺⋆ hyp Γ⁺ x) (P.refl {x = [ wk₁ ]}) ⟩
      [ var₂ · x     /⊢⋆ ρs₂ ↑⁺⋆₁ Γ⁺ /⊢ wk₁ ]  ≡⟨ P.sym $ suc-/⊢⋆-↑⋆ σ x (ρs₂ ↑⁺⋆₁ Γ⁺) ⟩
      [ var₂ · suc x /⊢⋆ ρs₂ ↑⁺⋆₁ (Γ⁺ ▻ σ)  ]  ∎

    -- Variants of var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ which may be easier to use.

    var-/⊢⋆-⇒-/⊢⋆-↑⁺⋆ :
      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs₁ : Subs T₁ ρ̂) (ρs₂ : Subs T₁ ρ̂) →
      (∀ {σ} (x : Γ ∋ σ) → var₂ · x /⊢⋆ ρs₁ ≅-⊢₂ var₂ · x /⊢⋆ ρs₂) →
      ∀ Γ⁺ {σ} (t : Γ ++⁺ Γ⁺ ⊢₂ σ) →
      t /⊢⋆ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢₂ t /⊢⋆ ρs₂ ↑⁺⋆₁ Γ⁺
    var-/⊢⋆-⇒-/⊢⋆-↑⁺⋆ ρs₁ ρs₂ hyp =
      var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ ρs₁ ρs₂ (var-/⊢⋆-⇒-var-/⊢⋆-↑⁺⋆ hyp)

    var-/⊢⋆-⇒-/⊢⋆ :
      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs₁ : Subs T₁ ρ̂) (ρs₂ : Subs T₁ ρ̂) →
      (∀ {σ} (x : Γ ∋ σ) → var₂ · x /⊢⋆ ρs₁ ≅-⊢₂ var₂ · x /⊢⋆ ρs₂) →
      ∀ {σ} (t : Γ ⊢₂ σ) → t /⊢⋆ ρs₁ ≅-⊢₂ t /⊢⋆ ρs₂
    var-/⊢⋆-⇒-/⊢⋆ ρs₁ ρs₂ hyp = var-/⊢⋆-⇒-/⊢⋆-↑⁺⋆ ρs₁ ρs₂ hyp ε

    -- The identity substitution has no effect.

    /⊢-id : ∀ {Γ σ} (t : Γ ⊢₂ σ) → t /⊢ id₁ ≅-⊢₂ t
    /⊢-id = var-/⊢⋆-⇒-/⊢⋆ (ε ▻ id₁) ε var-/⊢-id

    -- id is a right identity of _∘_.

    ∘-id : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₂ ρ̂) → ρ ∘ id₁ ≅-⇨ ρ
    ∘-id ρ = extensionality P.refl λ x → begin
        [ x /∋ ρ ∘ id₁  ]  ≡⟨ /∋-∘ x ρ id₁ ⟩
        [ x /∋ ρ /⊢ id₁ ]  ≡⟨ /⊢-id (x /∋ ρ) ⟩
        [ x /∋ ρ        ]  ∎

    -- Lifting distributes over composition.

    ∘-↑ : ∀ {Γ Δ Ε} σ {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε}
          (ρ₁ : Sub T₂ ρ̂₁) (ρ₂ : Sub T₁ ρ̂₂) →
          (ρ₁ ∘ ρ₂) ↑₂ σ ≅-⇨ ρ₁ ↑₂ σ ∘ ρ₂ ↑₁
    ∘-↑ σ ρ₁ ρ₂ =
      let ρ₂↑ = ρ₂ ↑₁ (σ / ρ₁)

          lemma₁ = begin
            [ wk-subst₂ (ρ₁ ∘ ρ₂)              ]  ≡⟨ P.refl ⟩
            [ map weaken₂ (map (app ρ₂) ρ₁)    ]  ≡⟨ P.sym $ map-[∘] weaken₂ (app ρ₂) ρ₁ ⟩
            [ map (weaken₂ [∘] app ρ₂) ρ₁      ]  ≡⟨ map-cong-ext₁ P.refl
                                                       (λ t → begin
                                                          [ weaken₂ · (t /⊢ ρ₂) ]  ≡⟨ P.sym $ /⊢-wk (t /⊢ ρ₂) ⟩
                                                          [ t /⊢ ρ₂ /⊢ wk₁      ]  ≡⟨ /⊢-/⊢-wk (σ / ρ₁) t ρ₂ ⟩
                                                          [ t /⊢ wk₁ /⊢ ρ₂↑     ]  ≡⟨ /⊢-cong (/⊢-wk t) P.refl ⟩
                                                          [ weaken₂ · t /⊢ ρ₂↑  ]  ∎)
                                                       (P.refl {x = [ ρ₁ ]}) ⟩
            [ map (app ρ₂↑ [∘] weaken₂) ρ₁     ]  ≡⟨ map-[∘] (app ρ₂↑) weaken₂ ρ₁ ⟩
            [ map (app ρ₂↑) (map (weaken₂) ρ₁) ]  ∎

          lemma₂ = begin
            [ var₂ · zero           ]  ≡⟨ P.sym $ trans-var zero ⟩
            [ trans · (var₁ · zero) ]  ≡⟨ trans-cong (P.sym $ Simple.zero-/∋-↑ simple₁ (σ / ρ₁) ρ₂) ⟩
            [ trans · (zero /∋ ρ₂↑) ]  ≡⟨ P.sym $ var-/⊢ zero ρ₂↑ ⟩
            [ var₂ · zero /⊢ ρ₂↑    ]  ∎

      in begin
      [ (ρ₁ ∘ ρ₂) ↑₂                                                  ]  ≡⟨ Simple.unfold-↑ simple₂ (ρ₁ ∘ ρ₂) ⟩
      [ wk-subst₂ (ρ₁ ∘ ρ₂) ▻ var₂ · zero                             ]  ≡⟨ ▻⇨-cong P.refl lemma₁ lemma₂ ⟩
      [ map (app ρ₂↑) (map weaken₂[ σ / ρ₁ ] ρ₁) ▻ var₂ · zero /⊢ ρ₂↑ ]  ≡⟨ P.sym $
                                                                              map-▻ (app ρ₂↑) (wk-subst₂[ σ / ρ₁ ] ρ₁) (var₂ · zero) ⟩
      [ map (app ρ₂↑) (wk-subst₂[ σ / ρ₁ ] ρ₁ ▻ var₂ · zero)          ]  ≡⟨ map-cong (app ρ₂↑ ∎-⟶)
                                                                                (P.sym $ Simple.unfold-↑ simple₂ ρ₁) ⟩
      [ map (app ρ₂↑) (ρ₁ ↑₂)                                         ]  ≡⟨ P.refl ⟩
      [ ρ₁ ↑₂ ∘ ρ₂ ↑₁                                                 ]  ∎

    -- N-ary lifting distributes over composition.

    ∘-↑⁺ : ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε}
           (ρ₁ : Sub T₂ ρ̂₁) (ρ₂ : Sub T₁ ρ̂₂) Γ⁺ →
           (ρ₁ ∘ ρ₂) ↑⁺₂ Γ⁺ ≅-⇨ ρ₁ ↑⁺₂ Γ⁺ ∘ ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁)
    ∘-↑⁺ ρ₁ ρ₂ ε        = P.refl
    ∘-↑⁺ ρ₁ ρ₂ (Γ⁺ ▻ σ) = begin
      [ ((ρ₁ ∘ ρ₂) ↑⁺₂ Γ⁺) ↑₂                   ]  ≡⟨ Simple.↑-cong simple₂ (∘-↑⁺ ρ₁ ρ₂ Γ⁺) P.refl ⟩
      [ (ρ₁ ↑⁺₂ Γ⁺ ∘ ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁)) ↑₂      ]  ≡⟨ ∘-↑ σ (ρ₁ ↑⁺₂ Γ⁺) (ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁)) ⟩
      [ (ρ₁ ↑⁺₂ Γ⁺) ↑₂ ∘ (ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁)) ↑₁ ]  ∎

    ∘-↑₊ : ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε}
           (ρ₁ : Sub T₂ ρ̂₁) (ρ₂ : Sub T₁ ρ̂₂) Γ₊ →
           (ρ₁ ∘ ρ₂) ↑₊₂ Γ₊ ≅-⇨ ρ₁ ↑₊₂ Γ₊ ∘ ρ₂ ↑₊₁ (Γ₊ /₊ ρ₁)
    ∘-↑₊ ρ₁ ρ₂ ε        = P.refl
    ∘-↑₊ ρ₁ ρ₂ (σ ◅ Γ₊) = begin
      [ (ρ₁             ∘ ρ₂   ) ↑₂ σ ↑₊₂ Γ₊      ]  ≡⟨ Simple.↑₊-cong simple₂ (∘-↑ σ ρ₁ ρ₂) (P.refl {x = [ Γ₊ ]}) ⟩
      [ (ρ₁ ↑₂ σ        ∘ ρ₂ ↑₁)      ↑₊₂ Γ₊      ]  ≡⟨ ∘-↑₊ (ρ₁ ↑₂ σ) (ρ₂ ↑₁) Γ₊ ⟩
      [ ρ₁ ↑₊₂ (σ ◅ Γ₊) ∘ ρ₂ ↑₊₁ ((σ ◅ Γ₊) /₊ ρ₁) ]  ∎

    -- First weakening and then substituting something for the first
    -- variable is equivalent to doing nothing.

    /⊢-wk-/⊢-sub : ∀ {Γ σ τ} (t : Γ ⊢₂ τ) (t′ : Γ ⊢₁ σ) →
                   t /⊢ wk₁ /⊢ sub₁ t′ ≅-⊢₂ t
    /⊢-wk-/⊢-sub t t′ = var-/⊢⋆-⇒-/⊢⋆ (ε ▻ wk₁ ▻ sub₁ t′) ε (λ x → begin
      [ var₂ · x /⊢ wk₁ /⊢ sub₁ t′ ]  ≡⟨ /⊢-cong (/∋-≅-⊢-var x wk₁ (Simple./∋-wk simple₁ x)) P.refl ⟩
      [ var₂ · suc x /⊢ sub₁ t′    ]  ≡⟨ suc-/⊢-sub x t′ ⟩
      [ var₂ · x                   ]  ∎) t

    -- Weakening a substitution and composing with sub is the same as
    -- doing nothing.

    wk-subst-∘-sub : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₂ ρ̂) (t : Δ ⊢₁ σ) →
                     wk-subst₂ ρ ∘ sub₁ t ≅-⇨ ρ
    wk-subst-∘-sub ρ t = extensionality P.refl λ x →
      let lemma = begin
            [ x /∋ wk-subst₂ ρ   ]  ≡⟨ Simple./∋-wk-subst simple₂ x ρ ⟩
            [ weaken₂ · (x /∋ ρ) ]  ≡⟨ P.sym $ /⊢-wk (x /∋ ρ) ⟩
            [ x /∋ ρ /⊢ wk₁      ]  ∎
      in begin
        [ x /∋ wk-subst₂ ρ ∘ sub₁ t    ]  ≡⟨ /∋-∘ x (wk-subst₂ ρ) (sub₁ t) ⟩
        [ x /∋ wk-subst₂ ρ /⊢ sub₁ t   ]  ≡⟨ /⊢-cong lemma P.refl ⟩
        [ x /∋ ρ /⊢ wk₁ /⊢ sub₁ t      ]  ≡⟨ /⊢-wk-/⊢-sub (x /∋ ρ) t ⟩
        [ x /∋ ρ                       ]  ∎

    -- Unfolding lemma for wk⁺.

    wk⁺-▻ : ∀ {Γ} (Γ⁺ : Ctxt⁺ Γ) {σ} →
            wk⁺₂ (Γ⁺ ▻ σ) ≅-⇨ wk⁺₂ Γ⁺ ∘ wk₁[ σ ]
    wk⁺-▻ Γ⁺ {σ = σ} = begin
      [ wk⁺₂ (Γ⁺ ▻ σ)       ]  ≡⟨ P.refl ⟩
      [ wk-subst₂ (wk⁺₂ Γ⁺) ]  ≡⟨ P.sym $ ∘-wk (wk⁺₂ Γ⁺) ⟩
      [ wk⁺₂ Γ⁺ ∘ wk₁       ]  ∎


-- Semantics of syntactic kits and explicit substitutions
module Semantics.Substitution.Kits where

open import Syntax.Types
open import Syntax.Context renaming (_,_ to _,,_)
open import Syntax.Terms
open import Syntax.Substitution.Kits

open import Semantics.Types
open import Semantics.Context
open import Semantics.Terms

open import CategoryTheory.Categories
open import CategoryTheory.Instances.Reactive renaming (top to Top)
open import CategoryTheory.Functor
open import CategoryTheory.Comonad
open import TemporalOps.Diamond
open import TemporalOps.Box
open import TemporalOps.Linear

open import Data.Sum
open import Data.Product
open import Relation.Binary.PropositionalEquality as ≡
    using (_≡_ ; refl)

open Comonad W-□
private module F-□ = Functor F-□

-- Semantic interpretation of kits, grouping together
-- lemmas for the kit operations
record ⟦Kit⟧ {𝒮 : Schema} (k : Kit 𝒮) : Set where
    open Kit k
    field
        -- Interpretation of the syntactic entity of the given scheme
        ⟦_⟧ : ∀{A Δ} -> 𝒮 Δ A -> ⟦ Δ ⟧ₓ ⇴ ⟦ A ⟧ⱼ
        -- Variable conversion lemma
        ⟦𝓋⟧ : ∀ A Δ
           -> ⟦ 𝓋 {Δ ,, A} top ⟧ ≈ π₂
        -- Term conversion lemma
        ⟦𝓉⟧ : ∀{A Δ} (T : 𝒮 Δ A)
           -> ⟦ 𝓉 T ⟧ₘ ≈ ⟦ T ⟧
        -- Weakening map lemma
        ⟦𝓌⟧ : ∀ B {Δ A} (T : 𝒮 Δ A)
           -> ⟦ 𝓌 {B} T ⟧ ≈ ⟦ T ⟧ ∘ π₁
        -- Context stabilisation lemma
        ⟦𝒶⟧ : ∀{A Δ} (T : 𝒮 Δ (A always))
           -> F-□.fmap ⟦ 𝒶 T ⟧ ∘ ⟦ Δ ˢ⟧□ ≈ δ.at ⟦ A ⟧ₜ ∘ ⟦ T ⟧

-- | Interpretation of substitutions and combinators
module ⟦K⟧ {𝒮} {k : Kit 𝒮} (⟦k⟧ : ⟦Kit⟧ k) where
    open ⟦Kit⟧ ⟦k⟧
    open Kit k

    -- Denotation of substitutions as a map between contexts
    ⟦subst⟧ : ∀{Γ Δ} -> Subst 𝒮 Γ Δ -> ⟦ Δ ⟧ₓ ⇴ ⟦ Γ ⟧ₓ
    ⟦subst⟧ ●       = !
    ⟦subst⟧ (σ ▸ T) = ⟨ ⟦subst⟧ σ , ⟦ T ⟧ ⟩

    -- Simplified context stabilisation lemma for non-boxed stabilisation
    ⟦𝒶⟧′ : ∀{A Δ} (T : 𝒮 Δ (A always))
       -> ⟦ 𝒶 T ⟧ ∘ ⟦ Δ ˢ⟧ ≈ ⟦ T ⟧
    ⟦𝒶⟧′ {A} {Δ} T {n} {⟦Δ⟧} rewrite ⟦ˢ⟧-factor Δ {n} {⟦Δ⟧}
                           = □-≡ n n (⟦𝒶⟧ T) n

    -- Denotation of weakening
    ⟦⁺⟧ : ∀ A {Γ Δ} -> (σ : Subst 𝒮 Γ Δ)
       -> ⟦subst⟧ (_⁺_ {A} σ k) ≈ ⟦subst⟧ σ ∘ π₁
    ⟦⁺⟧ A ● = refl
    ⟦⁺⟧ A (_▸_ {B} σ T) {n} {a} rewrite ⟦⁺⟧ A σ {n} {a}
                                     | ⟦𝓌⟧ A T {n} {a} = refl
    -- Denotation of lifting
    ⟦↑⟧ : ∀ A {Δ Γ} -> (σ : Subst 𝒮 Γ Δ)
       -> ⟦subst⟧ (_↑_ {A} σ k) ≈ (⟦subst⟧ σ * id)
    ⟦↑⟧ A {Δ} ● {n} {a} rewrite ⟦𝓋⟧ A Δ {n} {a} = refl
    ⟦↑⟧ A {Δ} (σ ▸ T) {n} {a} rewrite ⟦⁺⟧ A σ {n} {a}
                                   | ⟦𝓌⟧ A T {n} {a}
                                   | ⟦𝓋⟧ A Δ {n} {a} = refl

    -- Denotation of stabilisation (naturality condition for ⟦_ˢ⟧□)
    ⟦↓ˢ⟧ : ∀ {Γ Δ} -> (σ : Subst 𝒮 Γ Δ)
       -> F-□.fmap (⟦subst⟧ (σ ↓ˢ k)) ∘ ⟦ Δ ˢ⟧□ ≈ ⟦ Γ ˢ⟧□ ∘ ⟦subst⟧ σ
    ⟦↓ˢ⟧ ● = refl
    ⟦↓ˢ⟧ (_▸_ {A now} σ T) {n} {a} rewrite ⟦↓ˢ⟧ σ {n} {a} = refl
    ⟦↓ˢ⟧ {Δ = Δ} (_▸_ {A always}{Γ} σ T) {n} {a}  = ext lemma
        where
        lemma : ∀ l -> (F-□.fmap (⟦subst⟧ ((σ ▸ T) ↓ˢ k)) ∘ ⟦ Δ ˢ⟧□) n a l
                     ≡ (⟦ Γ ,, A always ˢ⟧□ ∘ ⟦subst⟧ (σ ▸ T)) n a l
        lemma l rewrite □-≡ n l (⟦↓ˢ⟧ σ {n} {a}) l
                      | □-≡ n l (⟦𝒶⟧ T {n} {a}) l = refl

    -- Simplified denotation of stabilisation
    ⟦↓ˢ⟧′ : ∀ {Γ Δ} -> (σ : Subst 𝒮 Γ Δ)
       -> ⟦subst⟧ (σ ↓ˢ k) ∘ ⟦ Δ ˢ⟧ ≈ ⟦ Γ ˢ⟧ ∘ ⟦subst⟧ σ
    ⟦↓ˢ⟧′ {Γ} {Δ} σ {n} {a} rewrite ⟦ˢ⟧-factor Δ {n} {a}
                                | □-≡ n n (⟦↓ˢ⟧ σ {n} {a}) n
                                | ⟦ˢ⟧-factor Γ {n} {(⟦subst⟧ σ n a)} = refl

    -- Denotation of stabilisation idempotence
    ⟦ˢˢ⟧ : ∀ Γ -> F-□.fmap (⟦subst⟧ (Γ ˢˢₛ k)) ∘ ⟦ Γ ˢ ˢ⟧□ ∘ ⟦ Γ ˢ⟧ ≈ ⟦ Γ ˢ⟧□
    ⟦ˢˢ⟧ ∙ = refl
    ⟦ˢˢ⟧ (Γ ,, B now) = ⟦ˢˢ⟧ Γ
    ⟦ˢˢ⟧ (Γ ,, B always) {n} {⟦Γˢ⟧ , □⟦B⟧} = ext lemma
        where
        lemma : ∀ l → (F-□.fmap (⟦subst⟧ ((Γ ,, B always) ˢˢₛ k))
                        ∘ ⟦ (Γ ,, B always) ˢ ˢ⟧□
                        ∘ ⟦ Γ ,, B always ˢ⟧) n (⟦Γˢ⟧ , □⟦B⟧) l
                    ≡ (⟦ Γ ˢ⟧□ n ⟦Γˢ⟧ l , □⟦B⟧)
        lemma l rewrite ⟦𝓋⟧ (B always) (Γ ˢ ˢ) {l} {⟦ Γ ˢ ˢ⟧□ n (⟦ Γ ˢ⟧ n ⟦Γˢ⟧) l , □⟦B⟧}
                      | ⟦⁺⟧ (B always) (Γ ˢˢₛ k) {l} {(⟦ Γ ˢ ˢ⟧□ n (⟦ Γ ˢ⟧ n ⟦Γˢ⟧) l , □⟦B⟧)}
                      | □-≡ n l (⟦ˢˢ⟧ Γ {n} {⟦Γˢ⟧}) l = refl

    -- Denotation of identity substitution
    ⟦idₛ⟧ : ∀ {Γ} -> ⟦subst⟧ (idₛ {Γ} k) ≈ id
    ⟦idₛ⟧ {∙} = refl
    ⟦idₛ⟧ {Γ ,, A} {n} {⟦Γ⟧ , ⟦A⟧}
        rewrite ⟦⁺⟧ A {Γ} (idₛ k) {n} {⟦Γ⟧ , ⟦A⟧}
              | ⟦idₛ⟧ {Γ} {n} {⟦Γ⟧}
              | ⟦𝓋⟧ A Γ {n} {⟦Γ⟧ , ⟦A⟧} = refl

    -- | Other lemmas

    -- Substitution by the Γ ˢ ⊆ Γ subcontext substitution is the same as
    -- stabilising the context
    ⟦subst⟧-Γˢ⊆Γ : ∀ Γ -> ⟦subst⟧ (Γˢ⊆Γ Γ ⊆ₛ k) ≈ ⟦ Γ ˢ⟧
    ⟦subst⟧-Γˢ⊆Γ ∙ = refl
    ⟦subst⟧-Γˢ⊆Γ (Γ ,, A now) {n} {⟦Γ⟧ , ⟦A⟧}
        rewrite ⟦⁺⟧ (A now) (Γˢ⊆Γ Γ ⊆ₛ k) {n} {⟦Γ⟧ , ⟦A⟧} = ⟦subst⟧-Γˢ⊆Γ Γ
    ⟦subst⟧-Γˢ⊆Γ (Γ ,, A always) {n} {⟦Γ⟧ , ⟦A⟧}
        rewrite ⟦↑⟧ (A always) (Γˢ⊆Γ Γ ⊆ₛ k) {n} {⟦Γ⟧ , ⟦A⟧}
              | ⟦subst⟧-Γˢ⊆Γ Γ {n} {⟦Γ⟧} = refl

    -- Interpretation of substitution and selection can be commuted
    ⟦subst⟧-handle : ∀{Δ Γ A B C} -> (σ : Subst 𝒮 Γ Δ)
        -> {⟦C₁⟧ : ⟦ Γ ˢ ⟧ₓ ⊗   ⟦ A ⟧ₜ ⊗ ◇ ⟦ B ⟧ₜ ⇴ ◇ ⟦ C ⟧ₜ}
        -> {⟦C₂⟧ : ⟦ Γ ˢ ⟧ₓ ⊗ ◇ ⟦ A ⟧ₜ ⊗   ⟦ B ⟧ₜ ⇴ ◇ ⟦ C ⟧ₜ}
        -> {⟦C₃⟧ : ⟦ Γ ˢ ⟧ₓ ⊗   ⟦ A ⟧ₜ ⊗   ⟦ B ⟧ₜ ⇴ ◇ ⟦ C ⟧ₜ}
        -> (handle
            (⟦C₁⟧ ∘ (⟦subst⟧ (_↑_ {Event B now} (_↑_ {A now} (σ ↓ˢ k) k) k)))
            (⟦C₂⟧ ∘ (⟦subst⟧ (_↑_ {B now} (_↑_ {Event A now} (σ ↓ˢ k) k) k)))
            (⟦C₃⟧ ∘ (⟦subst⟧ (_↑_ {B now} (_↑_ {A now}       (σ ↓ˢ k) k) k))))
         ≈ handle ⟦C₁⟧ ⟦C₂⟧ ⟦C₃⟧ ∘ (⟦subst⟧ (σ ↓ˢ k) * id)
    ⟦subst⟧-handle {A = A} {B} σ {n = n} {⟦Δ⟧ , inj₁ (inj₁ (⟦A⟧ , ⟦◇B⟧))}
        rewrite ⟦↑⟧ (Event B now) (_↑_ {A now} (σ ↓ˢ k) k) {n} {(⟦Δ⟧ , ⟦A⟧) , ⟦◇B⟧}
              | ⟦↑⟧ (A now) (σ ↓ˢ k) {n} {⟦Δ⟧ , ⟦A⟧} = refl
    ⟦subst⟧-handle {A = A} {B} σ {n = n} {⟦Δ⟧ , inj₁ (inj₂ (⟦B⟧ , ⟦◇A⟧))}
        rewrite ⟦↑⟧ (B now) (_↑_ {Event A now} (σ ↓ˢ k) k) {n} {(⟦Δ⟧ , ⟦B⟧) , ⟦◇A⟧}
              | ⟦↑⟧ (Event A now) (σ ↓ˢ k) {n} {⟦Δ⟧ , ⟦B⟧} = refl
    ⟦subst⟧-handle {A = A} {B} σ {n = n} {⟦Δ⟧ , inj₂ (⟦A⟧ , ⟦B⟧)}
        rewrite ⟦↑⟧ (B now) (_↑_ {A now} (σ ↓ˢ k) k) {n} {(⟦Δ⟧ , ⟦A⟧) , ⟦B⟧}
              | ⟦↑⟧ (A now) (σ ↓ˢ k) {n} {⟦Δ⟧ , ⟦A⟧} = refl


module hello-world where

open import IO
open import Level

main = run {0ℓ} (putStrLn "Hello, World!")


{-# OPTIONS --erased-cubical #-}

module Erased-cubical-Open-public.Erased (_ : Set₁) where

postulate
  A : Set


postulate
  F    : (Set → Set) → Set
  !_   : Set → Set
  !_,_ : Set → Set → Set
  X    : Set

syntax F (λ X → A) = X , A

infix 1 F
infix 2 !_

Foo : Set
Foo = ! X , X

-- This expression can be parsed in exactly one way. However, Agda
-- rejects it:
--
--   Expected variable name in binding position
--
-- The error is thrown from pure code in rebuildBinding, and this
-- action circumvents the parser logic.
--
-- The error was introduced in the fix for Issue 1129, and the problem
-- raised in Issue 1129 was introduced in a fix for Issue 1108
-- ("Operator parser performance").


module Luau.RuntimeError.ToString where

open import FFI.Data.String using (String; _++_)
open import Luau.RuntimeError using (RuntimeErrorᴮ; RuntimeErrorᴱ; local; return; NilIsNotAFunction; UnboundVariable; SEGV; app; block)
open import Luau.Addr.ToString using (addrToString)
open import Luau.Var.ToString using (varToString)

errToStringᴱ : ∀ {H B} → RuntimeErrorᴱ H B → String
errToStringᴮ : ∀ {H B} → RuntimeErrorᴮ H B → String

errToStringᴱ NilIsNotAFunction = "nil is not a function"
errToStringᴱ (UnboundVariable x) = "variable " ++ varToString x ++ " is unbound"
errToStringᴱ (SEGV a x) = "address " ++ addrToString a ++ " is unallocated"
errToStringᴱ (app E) = errToStringᴱ E
errToStringᴱ (block b E) = errToStringᴮ E ++ "\n  in call of function " ++ varToString b

errToStringᴮ (local x E) = errToStringᴱ E ++ "\n  in definition of " ++ varToString x
errToStringᴮ (return E) = errToStringᴱ E ++ "\n  in return statement"


-- Andreas, 2015-06-28, issue reported by Nisse

{-# OPTIONS -vtc.pos.occ:20 #-} -- KEEP!, this triggered the __IMPOSSIBLE__

-- {-# OPTIONS -vtc.pos.occ:70 -v tc.rec:80 --show-implicit #-}

data ⊥ : Set where

F : ⊥ → Set
F ()

record R (i : ⊥) : Set₁ where
  constructor c
  field
    P Q : F i → Set

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/Syntax/Translation/InternalToAbstract.hs:874

-- The error is triggered by the use of prettyTCM in
-- Agda.TypeChecking.Positivity.getOccurrences.

-- tel = (_ : Prop) (_ : Prop) -- WRONG
-- perm = id
-- ps = (c x x : R @0) _
-- body = λ x _y _z -> x _z
-- type = F @1 → Set


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

   Copyright (c) 2020, 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 Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle
open        EpochConfig
open import LibraBFT.Yasm.Base ℓ-RoundManager

-- In this module, we instantiate the system model with parameters to
-- model a system using the simple implementation model we have so
-- far, which aims to obey the VotesOnceRule, but not PreferredRoundRule
-- yet.  This will evolve as we build out a model of a real
-- implementation.

module LibraBFT.Concrete.System.Parameters where
 ConcSysParms : SystemParameters
 ConcSysParms = mkSysParms
                 NodeId
                 _≟NodeId_
                 GenesisInfo
                 genInfo
                 RoundManager
                 initRM
                 NetworkMsg
                 Vote
                 sig-Vote
                 _⊂Msg_
                 ∈GenInfo
                 initWrapper
                 peerStep


open import Common.Prelude

data Wrap (A : Set) : Set where wrap : A → Wrap A

appWrap : ∀ {A B : Set} → (A → B) → Wrap A → B
appWrap f (wrap a) = f a

app : ∀ {A B : Set} → (A → B) → A → B
app f a = appWrap f (wrap a)

works : Nat
works = (λ _ → 42) ((λ _ → tt) 13)

-- (λ _ → tt) is erased but `app` tries to apply it
buggy : Nat
buggy = app (λ _ → 42) (app (λ _ → tt) 13)

main : IO ⊤
main = printNat buggy


------------------------------------------------------------------------
-- Representation-independent results for non-dependent lenses
------------------------------------------------------------------------

{-# OPTIONS --cubical --safe #-}

import Equality.Path as P

module Lens.Non-dependent
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J as Bij using (module _↔_)
open import Equivalence equality-with-J using (_≃_)
open import Erased.Cubical eq
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level equality-with-J as H-level
open import H-level.Closure equality-with-J
open import Surjection equality-with-J using (_↠_)

private
  variable
    a b c c₁ c₂ c₃    : Level
    A B               : Set a
    Lens₁ Lens₂ Lens₃ : Set a → Set b → Set c

------------------------------------------------------------------------
-- An existence result

-- There is, in general, no lens for the first projection from a
-- Σ-type, assuming that lenses with contractible domains have
-- contractible codomains.

no-first-projection-lens :
  (Lens : Set (a ⊔ b) → Set a → Set c) →
  @0 (∀ {A B} → Lens A B → Contractible A → Contractible B) →
  ∃ λ (A : Set a) → ∃ λ (B : A → Set b) →
    ¬ Lens (Σ A B) A
no-first-projection-lens {b = b} _ contractible-to-contractible =
  ↑ _ Bool ,
  (λ b → ↑ _ (lower b ≡ true)) ,
  λ l →                                           $⟨ singleton-contractible _ ⟩
     Contractible (Singleton true)                ↝⟨ H-level.respects-surjection surj 0 ⟩
     Contractible (∃ λ b → ↑ _ (lower b ≡ true))  ↝⟨ (λ hyp → [ contractible-to-contractible l hyp ]) ⟩
     Erased (Contractible (↑ _ Bool))             ↝⟨ Erased-cong (H-level.respects-surjection (_↔_.surjection Bij.↑↔) 0) ⟩
     Erased (Contractible Bool)                   ↝⟨ Erased-cong (mono₁ 0) ⟩
     Erased (Is-proposition Bool)                 ↝⟨ inverse-ext? ¬-Erased↔¬ _ ¬-Bool-propositional ⟩□
     ⊥                                            □
  where
  surj : Singleton true ↠ ∃ λ b → ↑ _ (lower b ≡ true)
  surj = record
    { logical-equivalence = record
      { to   = λ { (b , b≡true) → lift b , lift b≡true }
      ; from = λ { (lift b , lift b≡true) → b , b≡true }
      }
    ; right-inverse-of = refl
    }

------------------------------------------------------------------------
-- Statements of preservation results, and some related lemmas

-- Lens-like things with getters and setters.

record Has-getter-and-setter
         (Lens : Set a → Set b → Set c) :
         Set (lsuc (a ⊔ b ⊔ c)) where
  field
    -- Getter.
    get : {A : Set a} {B : Set b} → Lens A B → A → B

    -- Setter.
    set : {A : Set a} {B : Set b} → Lens A B → A → B → A

-- A statement of what it means for two lenses to have the same getter
-- and setter.

Same-getter-and-setter :
  {Lens₁ : Set a → Set b → Set c₁}
  {Lens₂ : Set a → Set b → Set c₂}
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  {A : Set a} {B : Set b} →
  Lens₁ A B → Lens₂ A B → Set (a ⊔ b)
Same-getter-and-setter ⦃ L₁ = L₁ ⦄ ⦃ L₂ = L₂ ⦄ l₁ l₂ =
  get L₁ l₁ ≡ get L₂ l₂ ×
  set L₁ l₁ ≡ set L₂ l₂
  where
  open Has-getter-and-setter

-- A statement of what it means for a function to preserve getters and
-- setters for all inputs.

Preserves-getters-and-setters-→ :
  {Lens₁ : Set a → Set b → Set c₁}
  {Lens₂ : Set a → Set b → Set c₂}
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  (A : Set a) (B : Set b) →
  (Lens₁ A B → Lens₂ A B) →
  Set (a ⊔ b ⊔ c₁)
Preserves-getters-and-setters-→ {Lens₁ = Lens₁} A B f =
  (l : Lens₁ A B) → Same-getter-and-setter (f l) l

-- A statement of what it means for a logical equivalence to preserve
-- getters and setters.

Preserves-getters-and-setters-⇔ :
  {Lens₁ : Set a → Set b → Set c₁}
  {Lens₂ : Set a → Set b → Set c₂}
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  (A : Set a) (B : Set b) →
  (Lens₁ A B ⇔ Lens₂ A B) →
  Set (a ⊔ b ⊔ c₁ ⊔ c₂)
Preserves-getters-and-setters-⇔ A B eq =
  Preserves-getters-and-setters-→ A B (_⇔_.to eq) ×
  Preserves-getters-and-setters-→ A B (_⇔_.from eq)

-- Composition preserves Preserves-getters-and-setters-→.

Preserves-getters-and-setters-→-∘ :
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  ⦃ L₃ : Has-getter-and-setter Lens₃ ⦄
  {f : Lens₂ A B → Lens₃ A B}
  {g : Lens₁ A B → Lens₂ A B} →
  Preserves-getters-and-setters-→ A B f →
  Preserves-getters-and-setters-→ A B g →
  Preserves-getters-and-setters-→ A B (f ∘ g)
Preserves-getters-and-setters-→-∘ p-f p-g _ =
    trans (proj₁ (p-f _)) (proj₁ (p-g _))
  , trans (proj₂ (p-f _)) (proj₂ (p-g _))

-- Composition preserves Preserves-getters-and-setters-⇔.

Preserves-getters-and-setters-⇔-∘ :
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  ⦃ L₃ : Has-getter-and-setter Lens₃ ⦄
  {f : Lens₂ A B ⇔ Lens₃ A B}
  {g : Lens₁ A B ⇔ Lens₂ A B} →
  Preserves-getters-and-setters-⇔ A B f →
  Preserves-getters-and-setters-⇔ A B g →
  Preserves-getters-and-setters-⇔ A B (f F.∘ g)
Preserves-getters-and-setters-⇔-∘ p-f p-g =
    Preserves-getters-and-setters-→-∘ (proj₁ p-f) (proj₁ p-g)
  , Preserves-getters-and-setters-→-∘ (proj₂ p-g) (proj₂ p-f)

-- The function inverse preserves Preserves-getters-and-setters-⇔.

Preserves-getters-and-setters-⇔-inverse :
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  {f : Lens₁ A B ⇔ Lens₂ A B} →
  Preserves-getters-and-setters-⇔ A B f →
  Preserves-getters-and-setters-⇔ A B (inverse f)
Preserves-getters-and-setters-⇔-inverse = swap

-- If the forward direction of a split surjection preserves getters
-- and setters, then both directions do.

Preserves-getters-and-setters-→-↠-⇔ :
  ⦃ L₁ : Has-getter-and-setter Lens₁ ⦄
  ⦃ L₂ : Has-getter-and-setter Lens₂ ⦄
  (f : Lens₁ A B ↠ Lens₂ A B) →
  Preserves-getters-and-setters-→ A B (_↠_.to f) →
  Preserves-getters-and-setters-⇔ A B (_↠_.logical-equivalence f)
Preserves-getters-and-setters-→-↠-⇔ ⦃ L₁ = L₁ ⦄ ⦃ L₂ = L₂ ⦄ f p =
    p
  , λ l →
        (get L₁ (_↠_.from f l)             ≡⟨ sym $ proj₁ $ p (_↠_.from f l) ⟩
         get L₂ (_↠_.to f (_↠_.from f l))  ≡⟨ cong (get L₂) $ _↠_.right-inverse-of f _ ⟩∎
         get L₂ l                          ∎)
      , (set L₁ (_↠_.from f l)             ≡⟨ sym $ proj₂ $ p (_↠_.from f l) ⟩
         set L₂ (_↠_.to f (_↠_.from f l))  ≡⟨ cong (set L₂) $ _↠_.right-inverse-of f _ ⟩∎
         set L₂ l                          ∎)
  where
  open Has-getter-and-setter


module Issue113 where

module X where

  postulate D : Set

open X public

postulate x : D

-- Should give the proper error message, not __IMPOSSIBLE__ from Highlight.Generate
typeIncorrect : Set
typeIncorrect = Set1


{-

Automatically generating proofs of UnivalentStr for records

-}
{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Structures.Record where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Univalence
open import Cubical.Data.Sigma
open import Cubical.Data.Nat
open import Cubical.Data.List as List
open import Cubical.Data.Vec as Vec
open import Cubical.Data.Bool
open import Cubical.Data.Maybe
open import Cubical.Data.Sum
open import Cubical.Structures.Auto
import Cubical.Structures.Macro as M
import Agda.Builtin.Reflection as R
open import Cubical.Reflection.Base

-- Magic number
private
  FUEL = 10000

-- Types for specifying inputs to the tactics

data AutoFieldSpec : Typeω where
  autoFieldSpec : ∀ {ℓ ℓ₁ ℓ₂} (R : Type ℓ → Type ℓ₁) {S : Type ℓ → Type ℓ₂}
    → ({X : Type ℓ} → R X → S X)
    → AutoFieldSpec

module _ {ℓ ℓ₁ ℓ₁'} where
  mutual
    data AutoFields (R : Type ℓ → Type ℓ₁) (ι : StrEquiv R ℓ₁') : Typeω
      where
      fields: : AutoFields R ι
      _data[_∣_] : (fs : AutoFields R ι)
        → ∀ {ℓ₂ ℓ₂'} {S : Type ℓ → Type ℓ₂} {ι' : StrEquiv S ℓ₂'}
        → (f : {X : Type ℓ} → R X → S X)
        → ({A B : TypeWithStr ℓ R} {e : typ A ≃ typ B} → ι A B e → ι' (map-snd f A) (map-snd f B) e)
        → AutoFields R ι
      _prop[_∣_] : (fs : AutoFields R ι)
        → ∀ {ℓ₂} {P : (X : Type ℓ) → GatherFields fs X → Type ℓ₂}
        → ({X : Type ℓ} (r : R X) → P X (projectFields fs r))
        → isPropProperty R ι fs P
        → AutoFields R ι

    GatherFieldsLevel : {R : Type ℓ → Type ℓ₁} {ι : StrEquiv R ℓ₁'}
      → AutoFields R ι
      → Level
    GatherFieldsLevel fields: = ℓ-zero
    GatherFieldsLevel (_data[_∣_] fs {ℓ₂ = ℓ₂} _ _) = ℓ-max (GatherFieldsLevel fs) ℓ₂
    GatherFieldsLevel (_prop[_∣_] fs {ℓ₂ = ℓ₂} _ _) = ℓ-max (GatherFieldsLevel fs) ℓ₂

    GatherFields : {R : Type ℓ → Type ℓ₁} {ι : StrEquiv R ℓ₁'}
      (dat : AutoFields R ι)
      → Type ℓ → Type (GatherFieldsLevel dat)
    GatherFields fields: X = Unit
    GatherFields (_data[_∣_] fs {S = S} _ _) X = GatherFields fs X × S X
    GatherFields (_prop[_∣_] fs {P = P} _ _) X =
      Σ[ s ∈ GatherFields fs X ] (P X s)

    projectFields : {R : Type ℓ → Type ℓ₁} {ι : StrEquiv R ℓ₁'}
      (fs : AutoFields R ι)
      → {X : Type ℓ} → R X → GatherFields fs X
    projectFields fields: = _
    projectFields (fs data[ f ∣ _ ]) r = projectFields fs r , f r
    projectFields (fs prop[ f ∣ _ ]) r = projectFields fs r , f r

    isPropProperty : ∀ {ℓ₂} (R : Type ℓ → Type ℓ₁)
      (ι : StrEquiv R ℓ₁')
      (fs : AutoFields R ι)
      (P : (X : Type ℓ) → GatherFields fs X → Type ℓ₂)
      → Type (ℓ-max (ℓ-suc ℓ) (ℓ-max ℓ₁ ℓ₂))
    isPropProperty R ι fs P =
      {X : Type ℓ} (r  : R X) → isProp (P X (projectFields fs r))

  data AutoRecordSpec : Typeω where
    autoRecordSpec : (R : Type ℓ → Type ℓ₁) (ι : StrEquiv R ℓ₁')
      → AutoFields R ι
      → AutoRecordSpec

-- Some reflection utilities
private
  tApply : R.Term → List (R.Arg R.Term) → R.Term
  tApply t l = R.def (quote idfun) (R.unknown v∷ t v∷ l)

  tStrMap : R.Term → R.Term → R.Term
  tStrMap A f = R.def (quote map-snd) (f v∷ A v∷ [])

  tStrProj : R.Term → R.Name → R.Term
  tStrProj A sfield = tStrMap A (R.def sfield [])

  Fun : ∀ {ℓ ℓ'} → Type ℓ → Type ℓ' → Type (ℓ-max ℓ ℓ')
  Fun A B = A → B

-- Helper functions used in the generated univalence proof
private
  pathMap : ∀ {ℓ ℓ'} {S : I → Type ℓ} {T : I → Type ℓ'} (f : {i : I} → S i → T i)
    {x : S i0} {y : S i1} → PathP S x y → PathP T (f x) (f y)
  pathMap f p i = f (p i)

  -- Property field helper functions
  module _
    {ℓ ℓ₁ ℓ₁' ℓ₂}
    (R : Type ℓ → Type ℓ₁) -- Structure record
    (ι : StrEquiv R ℓ₁') -- Equivalence record
    (fs : AutoFields R ι) -- Prior fields
    (P : (X : Type ℓ) → GatherFields fs X → Type ℓ₂) -- Property type
    (f : {X : Type ℓ} (r : R X) → P X (projectFields fs r)) -- Property projection
    where

    prev = projectFields fs
    Prev = GatherFields fs

    PropHelperCenterType : Type _
    PropHelperCenterType =
      (A B : TypeWithStr ℓ R) (e : A .fst ≃ B .fst)
      (p : PathP (λ i → Prev (ua e i)) (prev (A .snd)) (prev (B .snd)))
      → PathP (λ i → P (ua e i) (p i)) (f (A .snd)) (f (B .snd))

    PropHelperContractType : PropHelperCenterType → Type _
    PropHelperContractType c =
      (A B : TypeWithStr ℓ R) (e : A .fst ≃ B .fst)
      {p₀ : PathP (λ i → Prev (ua e i)) (prev (A .snd)) (prev (B .snd))}
      (q : PathP (λ i → R (ua e i)) (A .snd) (B .snd))
      (p : p₀ ≡ (λ i → prev (q i)))
      → PathP (λ k → PathP (λ i → P (ua e i) (p k i)) (f (A .snd)) (f (B .snd)))
        (c A B e p₀)
        (λ i → f (q i))

    PropHelperType : Type _
    PropHelperType =
      Σ PropHelperCenterType PropHelperContractType

    derivePropHelper : isPropProperty R ι fs P → PropHelperType
    derivePropHelper propP .fst A B e p =
      isOfHLevelPathP' 0 (propP _) (f (A .snd)) (f (B .snd)) .fst
    derivePropHelper propP .snd A B e q p =
      isOfHLevelPathP' 0 (isOfHLevelPathP 1 (propP _) _ _) _ _ .fst

  -- Build proof of univalence from an isomorphism
  module _ {ℓ ℓ₁ ℓ₁'} (S : Type ℓ → Type ℓ₁) (ι : StrEquiv S ℓ₁') where

    fwdShape : Type _
    fwdShape =
      (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → ι A B e → PathP (λ i → S (ua e i)) (str A) (str B)

    bwdShape : Type _
    bwdShape =
      (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → PathP (λ i → S (ua e i)) (str A) (str B) → ι A B e

    fwdBwdShape : fwdShape → bwdShape → Type _
    fwdBwdShape fwd bwd =
      (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → ∀ p → fwd A B e (bwd A B e p) ≡ p

    bwdFwdShape : fwdShape → bwdShape → Type _
    bwdFwdShape fwd bwd =
      (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → ∀ r → bwd A B e (fwd A B e r) ≡ r

    -- The implicit arguments A,B in UnivalentStr make some things annoying so let's avoid them
    ExplicitUnivalentStr : Type _
    ExplicitUnivalentStr =
      (A B : TypeWithStr _ S) (e : typ A ≃ typ B) → ι A B e ≃ PathP (λ i → S (ua e i)) (str A) (str B)

    explicitUnivalentStr : (fwd : fwdShape) (bwd : bwdShape)
      → fwdBwdShape fwd bwd → bwdFwdShape fwd bwd
      → ExplicitUnivalentStr
    explicitUnivalentStr fwd bwd fwdBwd bwdFwd A B e = isoToEquiv isom
      where
      open Iso
      isom : Iso _ _
      isom .fun = fwd A B e
      isom .inv = bwd A B e
      isom .rightInv = fwdBwd A B e
      isom .leftInv = bwdFwd A B e

  ExplicitUnivalentDesc : ∀ ℓ → (d : M.Desc ℓ) → Type _
  ExplicitUnivalentDesc _ d =
    ExplicitUnivalentStr (M.MacroStructure d) (M.MacroEquivStr d)

  explicitUnivalentDesc : ∀ ℓ → (d : M.Desc ℓ) → ExplicitUnivalentDesc ℓ d
  explicitUnivalentDesc _ d A B e = M.MacroUnivalentStr d e

-- Internal record specification type
private
  record TypedTerm : Type where
    field
      type : R.Term
      term : R.Term

  record InternalDatumField : Type where
    field
      sfield : R.Name -- name of structure field
      efield : R.Name -- name of equivalence field

  record InternalPropField : Type where
    field
      sfield : R.Name -- name of structure field

  InternalField : Type
  InternalField = InternalDatumField ⊎ InternalPropField

  record InternalSpec (A : Type) : Type where
    field
      srec : R.Term -- structure record type
      erec : R.Term -- equivalence record type
      fields : List (InternalField × A) -- in reverse order

  open TypedTerm
  open InternalDatumField
  open InternalPropField

-- Parse a field and record specifications
private
  findName : R.Term → R.TC R.Name
  findName (R.def name _) = R.returnTC name
  findName (R.lam R.hidden (R.abs _ t)) = findName t
  findName t = R.typeError (R.strErr "Not a name + spine: " ∷ R.termErr t ∷ [])

  parseFieldSpec : R.Term → R.TC (R.Term × R.Term × R.Term × R.Term)
  parseFieldSpec (R.con (quote autoFieldSpec) (ℓ h∷ ℓ₁ h∷ ℓ₂ h∷ R v∷ S h∷ f v∷ [])) =
    R.reduce ℓ >>= λ ℓ →
    R.returnTC (ℓ , ℓ₂ , S , f)
  parseFieldSpec t =
    R.typeError (R.strErr "Malformed field specification: " ∷ R.termErr t ∷ [])

  parseSpec : R.Term → R.TC (InternalSpec TypedTerm)
  parseSpec (R.con (quote autoRecordSpec) (ℓ h∷ ℓ₁ h∷ ℓ₁' h∷ srecTerm v∷ erecTerm v∷ fs v∷ [])) =
    parseFields fs >>= λ fs' →
    R.returnTC λ { .srec → srecTerm ; .erec → erecTerm ; .fields → fs'}
    where
    open InternalSpec

    parseFields : R.Term → R.TC (List (InternalField × TypedTerm))
    parseFields (R.con (quote fields:) _) = R.returnTC []
    parseFields (R.con (quote _data[_∣_])
      (ℓ h∷ ℓ₁ h∷ ℓ₁' h∷ R h∷ ι h∷ fs v∷ ℓ₂ h∷ ℓ₂' h∷ S h∷ ι' h∷ sfieldTerm v∷ efieldTerm v∷ []))
      =
      R.reduce ℓ >>= λ ℓ →
      findName sfieldTerm >>= λ sfieldName →
      findName efieldTerm >>= λ efieldName →
      buildDesc FUEL ℓ ℓ₂ S >>= λ d →
      let
        f : InternalField × TypedTerm
        f = λ
          { .fst → inl λ { .sfield → sfieldName ; .efield → efieldName }
          ; .snd .type → R.def (quote ExplicitUnivalentDesc) (ℓ v∷ d v∷ [])
          ; .snd .term → R.def (quote explicitUnivalentDesc) (ℓ v∷ d v∷ [])
          }
      in
      liftTC (f ∷_) (parseFields fs)
    parseFields (R.con (quote _prop[_∣_])
      (ℓ h∷ ℓ₁ h∷ ℓ₁' h∷ R h∷ ι h∷ fs v∷ ℓ₂ h∷ P h∷ fieldTerm v∷ prop v∷ []))
      =
      findName fieldTerm >>= λ fieldName →
      let
        p : InternalField × TypedTerm
        p = λ
          { .fst → inr λ { .sfield → fieldName }
          ; .snd .type →
            R.def (quote PropHelperType) (srecTerm v∷ erecTerm v∷ fs v∷ P v∷ fieldTerm v∷ [])
          ; .snd .term →
            R.def (quote derivePropHelper) (srecTerm v∷ erecTerm v∷ fs v∷ P v∷ fieldTerm v∷ prop v∷ [])
          }
      in
      liftTC (p ∷_) (parseFields fs)

    parseFields t = R.typeError (R.strErr "Malformed autoRecord specification (1): " ∷ R.termErr t ∷ [])

  parseSpec t = R.typeError (R.strErr "Malformed autoRecord specification (2): " ∷ R.termErr t ∷ [])

-- Build a proof of univalence from an InternalSpec
module _ (spec : InternalSpec ℕ) where
  open InternalSpec spec
  private

    fwdDatum : Vec R.Term 4 → R.Term → InternalDatumField × ℕ → R.Term
    fwdDatum (A ∷ B ∷ e ∷ streq ∷ _) i (dat , n) =
      R.def (quote equivFun)
        (tApply (v n) (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ [])
          v∷ R.def (dat .efield) (streq v∷ [])
          v∷ i
          v∷ [])

    fwdProperty : Vec R.Term 4 → R.Term → R.Term → InternalPropField × ℕ → R.Term
    fwdProperty (A ∷ B ∷ e ∷ streq ∷ _) i prevPath prop =
      R.def (quote fst) (v (prop .snd) v∷ A v∷ B v∷ e v∷ prevPath v∷ i v∷ [])

    bwdClause : Vec R.Term 4 → InternalDatumField × ℕ → R.Clause
    bwdClause (A ∷ B ∷ e ∷ q ∷ _) (dat , n) =
      R.clause [] (R.proj (dat .efield) v∷ [])
        (R.def (quote invEq)
          (tApply
            (v n)
            (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ [])
            v∷ R.def (quote pathMap) (R.def (dat .sfield) [] v∷ q v∷ [])
            v∷ []))

    fwdBwdDatum : Vec R.Term 4 → R.Term → R.Term → InternalDatumField × ℕ → R.Term
    fwdBwdDatum (A ∷ B ∷ e ∷ q ∷ _) j i (dat , n) =
      R.def (quote retEq)
        (tApply
          (v n)
          (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ [])
          v∷ R.def (quote pathMap) (R.def (dat .sfield) [] v∷ q v∷ [])
          v∷ j v∷ i
          v∷ [])

    fwdBwdProperty : Vec R.Term 4 → (j i prevPath : R.Term) → InternalPropField × ℕ → R.Term
    fwdBwdProperty (A ∷ B ∷ e ∷ q ∷ _) j i prevPath prop =
      R.def (quote snd) (v (prop .snd) v∷ A v∷ B v∷ e v∷ q v∷ prevPath v∷ j v∷ i v∷ [])

    bwdFwdClause : Vec R.Term 4 → R.Term → InternalDatumField × ℕ → R.Clause
    bwdFwdClause (A ∷ B ∷ e ∷ streq ∷ _) j (dat , n) =
      R.clause [] (R.proj (dat .efield) v∷ [])
        (R.def (quote secEq)
          (tApply
            (v n)
            (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ [])
            v∷ R.def (dat .efield) (streq v∷ [])
            v∷ j
            v∷ []))

    makeVarsFrom : {n : ℕ} → ℕ → Vec R.Term n
    makeVarsFrom {zero} k = []
    makeVarsFrom {suc n} k = v (n + k) ∷ (makeVarsFrom k)

    fwd : R.Term
    fwd =
      vlam "A" (vlam "B" (vlam "e" (vlam "streq" (vlam "i" (R.pat-lam body [])))))
      where
      -- input list is in reverse order
      fwdClauses : ℕ → List (InternalField × ℕ) → List (R.Name × R.Term)
      fwdClauses k [] = []
      fwdClauses k ((inl f , n) ∷ fs) =
        fwdClauses k fs
        ∷ʳ (f .sfield , fwdDatum (makeVarsFrom k) (v 0) (map-snd (4 + k +_) (f , n)))
      fwdClauses k ((inr p , n) ∷ fs) =
        fwdClauses k fs
        ∷ʳ (p .sfield , fwdProperty (makeVarsFrom k) (v 0) prevPath (map-snd (4 + k +_) (p , n)))
        where
        prevPath =
          vlam "i"
            (List.foldl
              (λ t (_ , t') → R.con (quote _,_) (t v∷ t' v∷ []))
              (R.con (quote tt) [])
              (fwdClauses (suc k) fs))

      body =
        List.map (λ (n , t) → R.clause [] [ varg (R.proj n) ] t) (fwdClauses 1 fields)

    bwd : R.Term
    bwd =
      vlam "A" (vlam "B" (vlam "e" (vlam "q" (R.pat-lam (bwdClauses fields) []))))
      where
      -- input is in reverse order
      bwdClauses : List (InternalField × ℕ) → List R.Clause
      bwdClauses [] = []
      bwdClauses ((inl f , n) ∷ fs) =
        bwdClauses fs
        ∷ʳ bwdClause (makeVarsFrom 0) (map-snd (4 +_) (f , n))
      bwdClauses ((inr p , n) ∷ fs) = bwdClauses fs

    fwdBwd : R.Term
    fwdBwd =
      vlam "A" (vlam "B" (vlam "e" (vlam "q" (vlam "j" (vlam "i" (R.pat-lam body []))))))
      where
      -- input is in reverse order
      fwdBwdClauses : ℕ →  List (InternalField × ℕ) → List (R.Name × R.Term)
      fwdBwdClauses k [] = []
      fwdBwdClauses k ((inl f , n) ∷ fs) =
        fwdBwdClauses k fs
        ∷ʳ (f .sfield , fwdBwdDatum (makeVarsFrom k) (v 1) (v 0) (map-snd (4 + k +_) (f , n)))
      fwdBwdClauses k ((inr p , n) ∷ fs) =
        fwdBwdClauses k fs
        ∷ʳ ((p .sfield , fwdBwdProperty (makeVarsFrom k) (v 1) (v 0) prevPath (map-snd (4 + k +_) (p , n))))
        where
        prevPath =
          vlam "j"
            (vlam "i"
              (List.foldl
                (λ t (_ , t') → R.con (quote _,_) (t v∷ t' v∷ []))
                (R.con (quote tt) [])
                (fwdBwdClauses (2 + k) fs)))

      body = List.map (λ (n , t) → R.clause [] [ varg (R.proj n) ] t) (fwdBwdClauses 2 fields)

    bwdFwd : R.Term
    bwdFwd =
      vlam "A" (vlam "B" (vlam "e" (vlam "streq" (vlam "j" (R.pat-lam (bwdFwdClauses fields) [])))))
      where
      bwdFwdClauses : List (InternalField × ℕ) → List R.Clause
      bwdFwdClauses [] = []
      bwdFwdClauses ((inl f , n) ∷ fs) =
        bwdFwdClauses fs
        ∷ʳ bwdFwdClause (makeVarsFrom 1) (v 0) (map-snd (5 +_) (f , n))
      bwdFwdClauses ((inr _ , n) ∷ fs) = bwdFwdClauses fs

  univalentRecord : R.Term
  univalentRecord =
    R.def (quote explicitUnivalentStr)
      (R.unknown v∷ R.unknown v∷ fwd v∷ bwd v∷ fwdBwd v∷ bwdFwd v∷ [])

macro
  autoFieldEquiv : R.Term → R.Term → R.Term → R.Term → R.TC Unit
  autoFieldEquiv spec A B hole =
    (R.reduce spec >>= parseFieldSpec) >>= λ (ℓ , ℓ₂ , S , f) →
    buildDesc FUEL ℓ ℓ₂ S >>= λ d →
    R.unify hole (R.def (quote M.MacroEquivStr) (d v∷ tStrMap A f v∷ tStrMap B f v∷ []))

  autoUnivalentRecord : R.Term → R.Term → R.TC Unit
  autoUnivalentRecord t hole =
    (R.reduce t >>= parseSpec) >>= λ spec →
    -- R.typeError (R.strErr "WOW: " ∷ R.termErr (main spec) ∷ [])
    R.unify (main spec) hole
    where
    module _ (spec : InternalSpec TypedTerm) where
      open InternalSpec spec

      mapUp : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → (ℕ → A → B) → ℕ → List A → List B
      mapUp f _ [] = []
      mapUp f n (x ∷ xs) = f n x ∷ mapUp f (suc n) xs

      closureSpec : InternalSpec ℕ
      closureSpec .InternalSpec.srec = srec
      closureSpec .InternalSpec.erec = erec
      closureSpec .InternalSpec.fields = mapUp (λ n → map-snd (λ _ → n)) 0 fields

      closure : R.Term
      closure =
        iter (List.length fields) (vlam "") (univalentRecord closureSpec)

      env : List (R.Arg R.Term)
      env = List.map (varg ∘ term ∘ snd) (List.rev fields)

      closureTy : R.Term
      closureTy =
        List.foldr
          (λ ty cod → R.def (quote Fun) (ty v∷ cod v∷ []))
          (R.def (quote ExplicitUnivalentStr) (srec v∷ erec v∷ []))
          (List.map (type ∘ snd) (List.rev fields))

      main : R.Term
      main = R.def (quote idfun) (closureTy v∷ closure v∷ env)


-- 2010-10-04
-- termination checker no longer counts stripping off a record constructor
-- as decrease
module Issue334 where

data Unit : Set where
  unit : Unit

record E : Set where
  inductive
  constructor mkE
  field
    fromE : E
    spam  : Unit

f : E -> Set
f (mkE e unit) = f e
-- the record pattern translation does not apply to f
-- still, should not termination check, because
--   f (mkE e u) = f e
-- also does not!


-- {-# OPTIONS -v tc.cover.splittree:10 -v tc.cc:30 #-}
module Issue829 where

record ⊤ : Set where
  constructor tt

data ⊥ : Set where

postulate
  P : ⊥ → Set

data D : (A : Set) → A → Set where
  c : ⊥ → (x : ⊤) → D ⊤ x

f : {A : Set} {x : A} → D A x → ⊥
f (c () .tt)

g : (x : ⊥) → P x
g ()

h : (A : Set) (x : A) (d : D A x) → P (f d)
h .⊤ tt (c x .tt) = g x

-- Bug.agda:21,21-24
-- Incomplete pattern matching when applying Bug.f
-- when checking that the expression g x has type P (f (c x tt))

-- Agda 2.3.2 gives the following more reasonable error message:
--
-- Bug.agda:21,21-24
-- x != f (c x tt) of type ⊥
-- when checking that the expression g x has type P (f (c x tt))

-- This regression is caused by the patch "Fixed  issue 827 : incomplete
-- case tree caused by record pattern translation".


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

module Data.ByteString where

import Data.ByteString.Primitive as Prim
import Data.ByteString.Utf8 as Utf8

open import Data.Word8 using (Word8)
open import Data.Nat using (ℕ)
open import Data.Colist using (Colist)
open import Data.List using (List)
open import Data.String using (String)
open import Data.Bool using (Bool; true; false)
open import Data.Product using (_×_)
open import Data.Tuple using (Pair→×)

open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)
open import Relation.Binary.PropositionalEquality.TrustMe using (trustMe)

data ByteStringKind : Set where
  Lazy Strict : ByteStringKind

ByteString : ByteStringKind → Set
ByteString Lazy = Prim.ByteStringLazy
ByteString Strict = Prim.ByteStringStrict

empty : ∀ {k} → ByteString k
empty {Lazy} = Prim.emptyLazy
empty {Strict} = Prim.emptyStrict

null : ∀ {k} → ByteString k → Bool
null {Lazy} = Prim.nullLazy
null {Strict} = Prim.nullStrict

length : ∀ {k} → ByteString k → ℕ
length {Lazy} bs = Prim.int64Toℕ (Prim.lengthLazy bs)
length {Strict} bs = Prim.IntToℕ (Prim.lengthStrict bs)

unsafeHead : ∀ {k} → ByteString k → Word8
unsafeHead {Lazy} = Prim.headLazy
unsafeHead {Strict} = Prim.headStrict

unsafeTail : ∀ {k} → ByteString k → ByteString k
unsafeTail {Lazy} = Prim.tailLazy
unsafeTail {Strict} = Prim.tailStrict

unsafeIndex : ∀ {k} → ByteString k → ℕ → Word8
unsafeIndex {Lazy} bs ix = Prim.indexLazy bs (Prim.ℕToInt64 ix)
unsafeIndex {Strict} bs ix = Prim.indexStrict bs (Prim.ℕToInt ix)

unsafeSplitAt : ∀ {k} → ℕ → ByteString k → (ByteString k) × (ByteString k)
unsafeSplitAt {Lazy} ix bs = Pair→× (Prim.splitAtLazy (Prim.ℕToInt64 ix) bs)
unsafeSplitAt {Strict} ix bs = Pair→× (Prim.splitAtStrict (Prim.ℕToInt ix) bs)

ByteStringRep : ByteStringKind → Set
ByteStringRep Lazy = Colist Word8
ByteStringRep Strict = List Word8

unpack : ∀ {k} → ByteString k → ByteStringRep k
unpack {Lazy} = Prim.Colist←Lazy
unpack {Strict} = Prim.List←Strict

pack : ∀ {k} → ByteStringRep k → ByteString k
pack {Lazy} = Prim.Colist→Lazy
pack {Strict} = Prim.List→Strict

infix 4 _≟_

_≟_ : ∀ {k} → Decidable {A = ByteString k} _≡_
_≟_ {Lazy} s₁ s₂ with Prim.lazy≟lazy s₁ s₂
... | true  = yes trustMe
... | false = no whatever
  where postulate whatever : _
_≟_ {Strict} s₁ s₂ with Prim.strict≟strict s₁ s₂
... | true  = yes trustMe
... | false = no whatever
  where postulate whatever : _

-- behind _==_ is the same idea as in Data.String
infix 4 _==_

_==_ : ∀ {k} → ByteString k → ByteString k → Bool
_==_ {k} s₁ s₂ = ⌊ s₁ ≟ s₂ ⌋

_++_ : ByteString Lazy → ByteString Lazy → ByteString Lazy
_++_ = Prim.appendLazy

fromChunks : List (ByteString Strict) → ByteString Lazy
fromChunks = Prim.fromChunks

toChunks : ByteString Lazy → List (ByteString Strict)
toChunks = Prim.toChunks

toLazy : ByteString Strict → ByteString Lazy
toLazy = Prim.toLazy

toStrict : ByteString Lazy → ByteString Strict
toStrict = Prim.toStrict


{-# OPTIONS --two-level --no-sized-types --no-guardedness #-}
module Issue2487.e where

postulate admit : {A : Set} -> A


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

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
{-# OPTIONS --allow-unsolved-metas #-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Hash
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS

open import LibraBFT.Abstract.Types

open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle sha256 sha256-cr

open import LibraBFT.Concrete.System.Parameters

open import LibraBFT.Yasm.Base
open import LibraBFT.Yasm.AvailableEpochs using (AvailableEpochs ; lookup'; lookup'')
open import LibraBFT.Yasm.System     ConcSysParms
open import LibraBFT.Yasm.Properties ConcSysParms

-- This module defines an abstract system state given a reachable
-- concrete system state.

-- An implementation must prove that, if one of its handlers sends a
-- message that contains a vote and is signed by a public key pk, then
-- either the vote's author is the peer executing the handler, the
-- epochId is in range, the peer is a member of the epoch, and its key
-- in that epoch is pk; or, a message with the same signature has been
-- sent before.  This is represented by StepPeerState-AllValidParts.
module LibraBFT.Concrete.System (sps-corr : StepPeerState-AllValidParts) where

 -- Bring in 'unwind', 'ext-unforgeability' and friends
 open Structural sps-corr

 -- TODO-1: refactor this somewhere else?  Maybe something like
 -- LibraBFT.Impl.Consensus.Types.Properties?
 sameHonestSig⇒sameVoteData : ∀ {v1 v2 : Vote} {pk}
                            → Meta-Honest-PK pk
                            → WithVerSig pk v1
                            → WithVerSig pk v2
                            → v1 ^∙ vSignature ≡ v2 ^∙ vSignature
                            → NonInjective-≡ sha256 ⊎ v2 ^∙ vVoteData ≡ v1 ^∙ vVoteData
 sameHonestSig⇒sameVoteData {v1} {v2} hpk wvs1 wvs2 refl
    with verify-bs-inj (verified wvs1) (verified wvs2)
      -- The signable fields of the votes must be the same (we do not model signature collisions)
 ...| bs≡
      -- Therefore the LedgerInfo is the same for the new vote as for the previous vote
      = sym <⊎$> (hashVote-inj1 {v1} {v2} (sameBS⇒sameHash bs≡))

 honestVoteProps : ∀ {e st} → ReachableSystemState {e} st → ∀ {pk nm v sender}
                    → Meta-Honest-PK pk
                    → v ⊂Msg nm
                    → (sender , nm) ∈ msgPool st
                    → WithVerSig pk v
                    → NonInjective-≡ sha256 ⊎ v ^∙ vEpoch < e
 honestVoteProps r hpk v⊂m m∈pool ver
   with honestPartValid r hpk v⊂m m∈pool ver
 ...| msg , valid
   =  ⊎-map id (λ { refl → vp-epoch valid })
               (sameHonestSig⇒sameVoteData hpk ver (msgSigned msg)
                                           (sym (msgSameSig msg)))

 -- We are now ready to define an 'AbsSystemState' view for a concrete
 -- reachable state.  We will do so by fixing an epoch that exists in
 -- the system, which will enable us to define the abstract
 -- properties. The culminaton of this 'PerEpoch' module is seen in
 -- the 'ConcSysState' "function" at the bottom, which probably the
 -- best place to start uynderstanding this.  Longer term, we will
 -- also need higher-level, cross-epoch properties.
 module PerState {e}(st : SystemState e)(r : ReachableSystemState st) where

  -- TODO-3: Remove this postulate when we are satisfied with the
  -- "hash-collision-tracking" solution. For example, when proving voo
  -- (in LibraBFT.LibraBFT.Concrete.Properties.VotesOnce), we
  -- currently use this postulate to eliminate the possibility of two
  -- votes that have the same signature but different VoteData
  -- whenever we use sameHonestSig⇒sameVoteData.  To eliminate the
  -- postulate, we need to refine the properties we prove to enable
  -- the possibility of a hash collision, in which case the required
  -- property might not hold.  However, it is not sufficient to simply
  -- prove that a hash collision *exists* (which is obvious,
  -- regardless of the LibraBFT implementation).  Rather, we
  -- ultimately need to produce a specific hash collision and relate
  -- it to the data in the system, so that we can prove that the
  -- desired properties hold *unless* an actual hash collision is
  -- found by the implementation given the data in the system.  In
  -- the meantime, we simply require that the collision identifies a
  -- reachable state; later "collision tracking" will require proof
  -- that the colliding values actually exist in that state.
  postulate  -- temporary
    meta-sha256-cr : ¬ (NonInjective-≡ sha256)

  module PerEpoch (eid : Fin e) where

   open import LibraBFT.Yasm.AvailableEpochs

   𝓔 : EpochConfig
   𝓔 = lookup' (availEpochs st) eid
   open EpochConfig

   open import LibraBFT.Abstract.System 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔)
   open import LibraBFT.Concrete.Records 𝓔
   import LibraBFT.Abstract.Records 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔) as Abs

   -- * Auxiliary definitions;
   -- TODO-1: simplify and cleanup
   record QcPair  (q : Abs.QC) : Set where
     constructor mkQcPair
     field
       cqc    : QuorumCert
       isv    : IsValidQC 𝓔 cqc
       q≡αcqc : q ≡ α-QC (cqc , isv)
   open QcPair

   qc-α-Sent⇒ : ∀ {st q} → (Abs.Q q) α-Sent st
             → QcPair q
   qc-α-Sent⇒ (ws _ _ (qc∈NM {cqc} isv _ q≡)) = mkQcPair cqc isv q≡

   record ConcBits {q α} (va∈q : α Abs.∈QC q) (qcp : QcPair q) : Set where
     constructor mkConcBits
     field
       as     : Author × Signature
       as∈cqc : as ∈ qcVotes (cqc qcp)
       αVote≡ : Any-lookup va∈q ≡ α-Vote (cqc qcp) (isv qcp) as∈cqc
   open ConcBits

   qcp⇒concBits : ∀ {q α}
            → (qcp : QcPair q)
            → (va∈q : α Abs.∈QC q)
            → ConcBits va∈q qcp
   qcp⇒concBits qcp va∈q
     with All-reduce⁻ {vdq = Any-lookup va∈q} (α-Vote (cqc qcp) (isv qcp)) All-self
                       (subst (Any-lookup va∈q ∈_) (cong Abs.qVotes (q≡αcqc qcp)) (Any-lookup-correctP va∈q))
   ...| as , as∈cqc , α≡ = mkConcBits as as∈cqc α≡

   -- This record is highly duplicated; but it does provide a simple way to access
   -- all the properties from an /honest vote/
   record Vote∈QcProps {q} (qcp : QcPair q) {α} (α∈q : α Abs.∈QC q) : Set₁ where
     constructor mkV∈QcP
     field
       ev    : ConcreteVoteEvidence 𝓔 (Abs.∈QC-Vote q α∈q)
       as    : Author × Signature
       as∈qc : as ∈ qcVotes (cqc qcp)
       rbld  : ₋cveVote ev ≈Vote rebuildVote (cqc qcp) as

   vote∈QcProps : ∀ {q α st} → (αSent : Abs.Q q α-Sent st) → (α∈q : α Abs.∈QC q)
                → Vote∈QcProps {q} (qc-α-Sent⇒ αSent) α∈q
   vote∈QcProps {q} {α} αSent va∈q
      with  All-lookup (Abs.qVotes-C5 q)  (Abs.∈QC-Vote-correct q va∈q)
   ...| ev
      with qc-α-Sent⇒ αSent
   ...| qcp
      with qcp⇒concBits qcp va∈q
   ...| mkConcBits as' as∈cqc αVote≡'
               = mkV∈QcP ev as' as∈cqc
                    (voteInEvidence≈rebuiltVote {valid = isv qcp} as∈cqc ev αVote≡')

   -- Here we capture the idea that there exists a vote message that
   -- witnesses the existence of a given Abs.Vote
   record ∃VoteMsgFor (v : Abs.Vote) : Set where
     constructor mk∃VoteMsgFor
     field
       -- A message that was actually sent
       nm            : NetworkMsg
       cv            : Vote
       cv∈nm         : cv ⊂Msg nm
       -- And contained a valid vote that, once abstracted, yeilds v.
       vmsgMember    : Member 𝓔
       vmsgSigned    : WithVerSig (getPubKey 𝓔 vmsgMember) cv
       vmsg≈v        : α-ValidVote 𝓔 cv vmsgMember ≡ v
       vmsgEpoch     : cv ^∙ vEpoch ≡ epochId 𝓔
   open ∃VoteMsgFor public

   record ∃VoteMsgSentFor (sm : SentMessages)(v : Abs.Vote) : Set where
     constructor mk∃VoteMsgSentFor
     field
       vmFor        : ∃VoteMsgFor v
       vmSender     : NodeId
       nmSentByAuth : (vmSender , (nm vmFor)) ∈ sm
   open ∃VoteMsgSentFor public

   ∃VoteMsgSentFor-stable : ∀ {e e'} {pre : SystemState e} {post : SystemState e'} {v}
                          → Step pre post
                          → ∃VoteMsgSentFor (msgPool pre) v
                          → ∃VoteMsgSentFor (msgPool post) v
   ∃VoteMsgSentFor-stable theStep (mk∃VoteMsgSentFor sndr vmFor sba) =
                                   mk∃VoteMsgSentFor sndr vmFor (msgs-stable theStep sba)

   record ∃VoteMsgInFor (outs : List NetworkMsg)(v : Abs.Vote) : Set where
     constructor mk∃VoteMsgInFor
     field
       vmFor    : ∃VoteMsgFor v
       nmInOuts : nm vmFor ∈ outs
   open ∃VoteMsgInFor public

   ∈QC⇒sent : ∀{e} {st : SystemState e} {q α}
            → Abs.Q q α-Sent (msgPool st)
            → Meta-Honest-Member 𝓔 α
            → (vα : α Abs.∈QC q)
            → ∃VoteMsgSentFor (msgPool st) (Abs.∈QC-Vote q vα)

   ∈QC⇒sent {e} {st} {α = α} vsent@(ws {sender} {nm} e≡ nm∈st (qc∈NM {cqc} {q} .{nm} valid cqc∈nm cqc≡)) ha va
      with vote∈QcProps vsent va
   ...| mkV∈QcP ev _ as∈qc rbld
      with vote∈qc as∈qc rbld cqc∈nm
   ...| v∈nm = mk∃VoteMsgSentFor
                 (mk∃VoteMsgFor nm (₋cveVote ev) v∈nm
                                (₋ivvMember (₋cveIsValidVote ev))
                                (₋ivvSigned (₋cveIsValidVote ev)) (₋cveIsAbs ev)
                                (₋ivvEpoch (₋cveIsValidVote ev)))
                 sender
                 nm∈st

   -- Finally, we can define the abstract system state corresponding to the concrete state st
   ConcSystemState : AbsSystemState ℓ0
   ConcSystemState = record
     { InSys           = λ { r → r α-Sent (msgPool st) }
     ; HasBeenSent     = λ { v → ∃VoteMsgSentFor (msgPool st) v }
     ; ∈QC⇒HasBeenSent = ∈QC⇒sent {st = st}
     }


{-# OPTIONS --no-positivity-check #-}
open import Prelude hiding (id; Bool; _∷_; [])

module Examples.Bad where

data TC : Set where
  tc-int : TC
  tc-bool : TC
  tc-char : TC

_tc≟_ : (a b : TC) → Dec (a ≡ b)
tc-int tc≟ tc-int = yes refl
tc-int tc≟ tc-bool = no (λ ())
tc-bool tc≟ tc-int = no (λ ())
tc-bool tc≟ tc-bool = yes refl
tc-int tc≟ tc-char = no (λ ())
tc-bool tc≟ tc-char = no (λ ())
tc-char tc≟ tc-int = no (λ ())
tc-char tc≟ tc-bool = no (λ ())
tc-char tc≟ tc-char = yes refl

open import Implicits.Oliveira.Types TC _tc≟_
open import Implicits.Oliveira.Terms TC _tc≟_
open import Implicits.Oliveira.Contexts TC _tc≟_
open import Implicits.Oliveira.WellTyped TC _tc≟_
open import Implicits.Oliveira.Substitutions TC _tc≟_
open import Implicits.Oliveira.Types.Unification TC _tc≟_
open import Implicits.Improved.Undecidable.Resolution TC _tc≟_
open import Data.Maybe
open import Data.List
open import Extensions.ListFirst

Bool : ∀ {n} → Type n
Bool = simpl (tc tc-bool)

Int : ∀ {n} → Type n
Int = simpl (tc tc-int)

Char : ∀ {n} → Type n
Char = simpl (tc tc-char)

module Ex₀ where

  data Bad : Set where
    bad : ¬ Bad → Bad

  getFun : Bad → ¬ Bad
  getFun (bad x) = x

  omega : Bad → ⊥
  omega b = getFun b b

  loop : ⊥
  loop = omega (bad omega)

module Ex₁ where

  Δ : ICtx zero
  Δ = Bool ⇒ Bool ∷ Bool ∷ []

  Bad : Set
  Bad = Δ ⊢ (Bool ⇒ Bool ) ↓ (tc tc-bool)

  getFun : Bad → ¬ Bad
  getFun (i-iabs (r-simp (here p ._)) x₁) = {!!}
  getFun (i-iabs (r-simp (there ._ f x)) y) = f

  omega : Bad → ⊥
  omega b = getFun b b

  bad : ¬ Bad → Bad
  bad ¬x = i-iabs (r-simp (there _ ¬x (here (i-simp (tc tc-bool)) []))) (i-simp (tc tc-bool))

  loop : ⊥
  loop = omega (bad omega)


module Sessions.Semantics.Communication {E : Set} (delay : E) where

open import Prelude
open import Data.List.Relation.Ternary.Interleaving
open import Data.List.Relation.Ternary.Interleaving.Propositional
open import Data.List.Relation.Equality.Propositional
open import Data.List.Properties
import Data.List as L

open import Relation.Unary hiding (Empty; _∈_)
open import Relation.Unary.PredicateTransformer using (Pt)
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.Monad
open import Relation.Ternary.Separation.Monad.Error
open import Relation.Ternary.Separation.Monad.State

open import Sessions.Syntax.Types
open import Sessions.Syntax.Values
open import Sessions.Syntax.Expr
open import Sessions.Semantics.Commands
open import Sessions.Semantics.Runtime delay

{- A specification of the update we are performing -}
_≔_ : ∀ {x} {ys} {zs} → [ endp x ] ⊎ ys ≣ zs → SType → RCtx
_≔_ {zs = x ∷ zs}         (to-right s) α  = x ∷ s ≔ α
_≔_ {zs = chan l r ∷ zs}  (divide lr s) α = chan α r ∷ zs
_≔_ {zs = chan l r ∷ zs}  (divide rl s) α = chan l α ∷ zs
_≔_ {zs = .(endp _) ∷ zs} (to-left s) α   = endp α ∷ zs

{- Type of actions on a link -}
private
  Action : ∀ (from to : SType) → Pt RCtx 0ℓ
  Action from to P Φ = ∀ {τ} → (end : End from τ) → (Channel τ ─✴ Except E (P ✴ Channel (end ≔ₑ to))) Φ

module _ where
  open ExceptMonad {A = RCtx} E
  open Monads.Monad except-monad
  open Monads using (str)

  {- Takes an endpointer and the channel list and updates it using a link action -}
  act : ∀ {P α xs ds} →
        (ptr : [ endp α ] ⊎ ds ≣ xs) →
        ∀[ Action α β P
           ⇒ Channels' xs
           ─✴ Except E (Empty ([ endp β ] ⊎ ds ≣ (ptr ≔ β)) ✴ P ✴ Channels' (ptr ≔ β)) ]

  -- the pointer points to a channel where one end is already closed
  app (act {xs = x ∷ xs} (to-left ptr) f) (ch :⟨ τ ⟩: chs) σ with ⊎-unassoc σ τ
  ... | _ , τ₁ , τ₂ = do
    px ×⟨ τ₄ ⟩ (ch' ×⟨ τ₅ ⟩ chs) ← mapM (app (f (-, to-left [])) ch τ₁ &⟨ τ₂ ⟩ chs) ✴-assocᵣ
    return (emp (to-left ptr) ×⟨ ⊎-idˡ ⟩ px ×⟨ τ₄ ⟩ cons (ch' ×⟨ τ₅ ⟩ chs))

  -- the pointer points to the left side of a channel in the state
  app (act {xs = x ∷ xs} (divide lr ptr) f) (ch :⟨ τ ⟩: chs) σ with ⊎-unassoc σ τ
  ... | _ , τ₂ , τ₃ = do
    px ×⟨ τ₄ ⟩ chs ← mapM (app (f (ending lr)) ch τ₂ &⟨ τ₃ ⟩ chs) ✴-assocᵣ
    return (emp (divide lr ptr) ×⟨ ⊎-idˡ ⟩ px ×⟨ τ₄ ⟩ cons chs)

  -- the pointer points to the right side of a channel in the state
  app (act {xs = x ∷ xs} (divide rl ptr) f) (ch :⟨ τ ⟩: chs) σ with ⊎-unassoc σ τ
  ... | _ , τ₂ , τ₃ = do
    px ×⟨ τ₄ ⟩ (ch' ×⟨ τ₅ ⟩ chs) ← mapM (app (f (ending rl)) ch τ₂ &⟨ τ₃ ⟩ chs) ✴-assocᵣ
    return (emp (divide rl ptr) ×⟨ ⊎-idˡ ⟩ px ×⟨ τ₄ ⟩ cons (ch' ×⟨ τ₅ ⟩ chs))

  -- the pointer points to some channel further down the list
  app (act {xs = x ∷ xs} (to-right ptr) f) (ch :⟨ τ ⟩: chs) σ with ⊎-unassoc σ (⊎-comm τ)
  ... | _ , τ₁ , τ₂ = do
    emp ptr ×⟨ τ₃ ⟩ rhs ← mapM (app (act ptr f) chs τ₁ &⟨ τ₂ ⟩ ch) ✴-assocᵣ
    let px ×⟨ τ₄ ⟩ chs' = ✴-assocᵣ rhs
    return (emp (to-right ptr) ×⟨ τ₃ ⟩ (px ×⟨ τ₄ ⟩ cons (✴-swap chs')))

module _ where
  open StateWithErr {C = RCtx} E
  open Monads.Monad {{...}}

  {- Updating a single link based on a pointer to one of its endpoints -}
  operate : ∀ {P} → ∀[ Action α β P ⇒ Endptr α ─✴ State? Channels (P ✴ Endptr β) ]
  app (app (operate f) refl σ₁) (lift chs k) (offerᵣ σ₂) with ⊎-assoc σ₂ k
  ... | _ , σ₃ , σ₄ with ⊎-assoc (⊎-comm σ₁) σ₃
  ... | _ , σ₅ , σ₆ with ⊎-unassoc σ₆ (⊎-comm σ₄)
  ... | _ , σ₇ , σ₈ with app (act σ₅ f) chs σ₇
  ... | error _ = error delay
  ... | partial (inj₂ (emp ptr' ×⟨ σ ⟩ (px ×⟨ τ ⟩ chs'))) with ⊎-id⁻ˡ σ
  ... | refl with ⊎-unassoc ptr' σ₈
  ... | _ , τ₁ , τ₂ with ⊎-unassoc τ₁ τ
  ... | _ , τ₃ , τ₄ with ⊎-assoc (⊎-comm τ₄) τ₂
  ... | _ , τ₅ , eureka =
    partial (inj₂ (inj (px ×⟨ ⊎-comm τ₃ ⟩ refl) ×⟨ offerᵣ eureka ⟩ lift chs' (⊎-comm τ₅)))

  {- Getting a value from a ready-to-receive endpoint -}
  receive? : ∀[ Endptr (a ¿ β) ⇒ State? Channels (Val a ✴ Endptr β) ]
  receive? ptr = app (operate (λ end → wandit (chan-receive end))) ptr ⊎-idˡ

  {- Putting a value in a ready-to-send endpoint -}
  send! : ∀[ Endptr (a ! β) ⇒ Val a ─✴ State? Channels (Endptr β) ]
  app (send! {a = a} ptr) v σ = do
    empty ×⟨ σ ⟩ ptr ← app (operate sender) ptr (⊎-comm σ)
    case ⊎-id⁻ˡ σ of λ where
      refl → return ptr
    where
      sender : Action (a ! γ) γ Emp _
      app (sender e) ch σ =
        let ch' = app (chan-send e ch) v (⊎-comm σ)
        in ✓ (empty ×⟨ ⊎-idˡ ⟩ ch')

  newChan : ε[ State? Channels (Endptr α ✴ Endptr (α ⁻¹)) ]
  app newChan (lift chs k) σ with ⊎-id⁻ˡ σ
  ... | refl = ✓ (
   (inj (refl ×⟨ divide lr ⊎-idˡ ⟩ refl))
      ×⟨ offerᵣ ⊎-∙ ⟩
   lift (cons (emptyChannel ×⟨ ⊎-idˡ ⟩ chs)) (⊎-∙ₗ k))

  closeChan : ∀[ Endptr end ⇒ State? Channels Emp ]
  app (closeChan refl) (lift chs k) (offerᵣ σ) =
    let
      _ , σ₂ , σ₃ = ⊎-assoc σ k
      chs' = close'em σ₂ chs
    in ✓ (inj empty ×⟨ ⊎-idˡ ⟩ lift chs' σ₃)
    where
      -- This is really cool:
      -- The pointer, in the form of the splitting of the store, contains all the necessary information
      -- for the shape of the underlying buffer.
      -- Depending on the shape of the splitting, we know, just by dependent pattern matching,
      -- whether the channel is two- or onesided
      close'em : ∀ {ds xs} → (ptr : [ endp end ] ⊎ ds ≣ xs) → ∀[ Channels' xs ⇒ Channels' ds ]

      close'em (divide lr ptr) (twosided (link refl (emp ×⟨ τ ⟩ bᵣ)) :⟨ σ ⟩: chs) with ⊎-id⁻ˡ ptr | ⊎-id⁻ˡ τ
      ... | refl | refl = cons (onesided bᵣ ×⟨ σ ⟩ chs)

      close'em (divide rl ptr) (twosided (link eq (bₗ ×⟨ τ ⟩ emp)) :⟨ σ ⟩: chs) with ⊎-id⁻ˡ ptr | ⊎-id⁻ʳ τ
      ... | refl | refl with dual-end (sym eq)
      ... | refl = cons (onesided bₗ ×⟨ σ ⟩ chs)

      close'em (to-left ptr) (cons (onesided emp ×⟨ σ ⟩ chs)) with ⊎-id⁻ˡ ptr | ⊎-id⁻ˡ σ
      ... | refl | refl = chs

      close'em (to-right ptr)  (ch :⟨ σ ⟩: chs) =
        let chs' = close'em ptr chs
        in cons (ch ×⟨ σ ⟩ chs')


module Lang.Vars.Structure.Operator where

import Lvl
open import Data
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Function.Domain
open import Structure.Operator.Properties
open import Structure.Operator
open import Type

-- TODO: These are to make the generalized variables work when they depend on each other. Are there any better ways?
module Select where
  module _ {ℓ ℓₑ} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
    select-invol : ∀(f : T → T) → Involution(f) → Type{Lvl.𝟎}
    select-invol _ _ = Data.Unit

  module _ {ℓ ℓₑ} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ {_▫_ : T → T → T} where
    select-id : ∀(id) → Identity(_▫_)(id) → Type{Lvl.𝟎}
    select-id _ _ = Data.Unit

    select-idₗ : ∀(id) → Identityₗ(_▫_)(id) → Type{Lvl.𝟎}
    select-idₗ _ _ = Data.Unit

    select-idᵣ : ∀(id) → Identityᵣ(_▫_)(id) → Type{Lvl.𝟎}
    select-idᵣ _ _ = Data.Unit

    select-inv : ∀(id)(ident)(inv) → InverseFunction(_▫_) ⦃ [∃]-intro(id) ⦃ ident ⦄ ⦄ (inv) → Type{Lvl.𝟎}
    select-inv _ _ _ _ = Data.Unit

    select-invₗ : ∀(id)(ident)(inv) → InverseFunctionₗ(_▫_) ⦃ [∃]-intro(id) ⦃ ident ⦄ ⦄ (inv) → Type{Lvl.𝟎}
    select-invₗ _ _ _ _ = Data.Unit

    select-invᵣ : ∀(id)(ident)(inv) → InverseFunctionᵣ(_▫_) ⦃ [∃]-intro(id) ⦃ ident ⦄ ⦄ (inv) → Type{Lvl.𝟎}
    select-invᵣ _ _ _ _ = Data.Unit

    select-invPropₗ : ∀(inv) → InversePropertyₗ(_▫_)(inv) → Type{Lvl.𝟎}
    select-invPropₗ _ _ = Data.Unit

    select-invPropᵣ : ∀(inv) → InversePropertyᵣ(_▫_)(inv) → Type{Lvl.𝟎}
    select-invPropᵣ _ _ = Data.Unit

    select-abs : ∀(id) → Absorber(_▫_)(id) → Type{Lvl.𝟎}
    select-abs _ _ = Data.Unit

    select-absₗ : ∀(id) → Absorberₗ(_▫_)(id) → Type{Lvl.𝟎}
    select-absₗ _ _ = Data.Unit

    select-absᵣ : ∀(id) → Absorberᵣ(_▫_)(id) → Type{Lvl.𝟎}
    select-absᵣ _ _ = Data.Unit

module One {ℓ ℓₑ} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ {_▫_ : T → T → T} where
  variable {id idₗ idᵣ ab abₗ abᵣ} : T
  variable {inv invₗ invᵣ} : T → T
  variable ⦃ op ⦄ : BinaryOperator ⦃ equiv ⦄ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫_)
  variable ⦃ comm ⦄ : Commutativity ⦃ equiv ⦄ (_▫_)
  variable ⦃ cancₗ ⦄ : Cancellationₗ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫_)
  variable ⦃ cancᵣ ⦄ : Cancellationᵣ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫_)
  variable ⦃ assoc ⦄ : Associativity ⦃ equiv ⦄ (_▫_)
  variable ⦃ ident  ⦄ : Identity ⦃ equiv ⦄ (_▫_)(id)
  variable ⦃ identₗ ⦄ : Identityₗ ⦃ equiv ⦄ (_▫_)(id)
  variable ⦃ identᵣ ⦄ : Identityᵣ ⦃ equiv ⦄ (_▫_)(id)
  variable ⦃ inver  ⦄ : InverseFunction ⦃ equiv ⦄ (_▫_) ⦃ [∃]-intro(id) ⦃ ident ⦄ ⦄ (inv)
  variable ⦃ inverₗ ⦄ : InverseFunctionₗ ⦃ equiv ⦄ (_▫_) ⦃ [∃]-intro(idₗ) ⦃ identₗ ⦄ ⦄ (invₗ)
  variable ⦃ inverᵣ ⦄ : InverseFunctionᵣ ⦃ equiv ⦄ (_▫_) ⦃ [∃]-intro(idᵣ) ⦃ identᵣ ⦄ ⦄ (invᵣ)
  variable ⦃ inverPropₗ ⦄ : InversePropertyₗ ⦃ equiv ⦄ (_▫_) (invₗ)
  variable ⦃ inverPropᵣ ⦄ : InversePropertyᵣ ⦃ equiv ⦄ (_▫_) (invᵣ)
  variable ⦃ invol ⦄ : Involution ⦃ equiv ⦄ (inv)
  variable ⦃ absorb  ⦄ : Absorber ⦃ equiv ⦄ (_▫_)(ab)
  variable ⦃ absorbₗ ⦄ : Absorberₗ ⦃ equiv ⦄ (_▫_)(ab)
  variable ⦃ absorbᵣ ⦄ : Absorberᵣ ⦃ equiv ⦄ (_▫_)(ab)

module OneTypeTwoOp {ℓ ℓₑ} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ {_▫₁_ _▫₂_ : T → T → T} where
  variable {id} : T
  variable {inv} : T → T

  variable ⦃ op₁ ⦄ : BinaryOperator ⦃ equiv ⦄ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₁_)
  variable ⦃ comm₁ ⦄ : Commutativity ⦃ equiv ⦄ (_▫₁_)
  variable ⦃ cancₗ₁ ⦄ : Cancellationₗ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₁_)
  variable ⦃ cancᵣ₁ ⦄ : Cancellationᵣ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₁_)
  variable ⦃ assoc₁ ⦄ : Associativity ⦃ equiv ⦄ (_▫₁_)
  variable ⦃ ident₁  ⦄ : Identity ⦃ equiv ⦄ (_▫₁_)(id)
  variable ⦃ identₗ₁ ⦄ : Identityₗ ⦃ equiv ⦄ (_▫₁_)(id)
  variable ⦃ identᵣ₁ ⦄ : Identityᵣ ⦃ equiv ⦄ (_▫₁_)(id)
  variable ⦃ inver₁  ⦄ : InverseFunction ⦃ equiv ⦄ (_▫₁_) ⦃ [∃]-intro(id) ⦃ ident₁ ⦄ ⦄ (inv)
  variable ⦃ inverₗ₁ ⦄ : InverseFunctionₗ ⦃ equiv ⦄ (_▫₁_) ⦃ [∃]-intro(id) ⦃ identₗ₁ ⦄ ⦄ (inv)
  variable ⦃ inverᵣ₁ ⦄ : InverseFunctionᵣ ⦃ equiv ⦄ (_▫₁_) ⦃ [∃]-intro(id) ⦃ identᵣ₁ ⦄ ⦄ (inv)
  variable ⦃ absorbₗ₁ ⦄ : Absorberₗ ⦃ equiv ⦄ (_▫₁_)(id)
  variable ⦃ absorbᵣ₁ ⦄ : Absorberᵣ ⦃ equiv ⦄ (_▫₁_)(id)

  variable ⦃ op₂ ⦄ : BinaryOperator ⦃ equiv ⦄ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₂_)
  variable ⦃ comm₂ ⦄ : Commutativity ⦃ equiv ⦄ (_▫₂_)
  variable ⦃ cancₗ₂ ⦄ : Cancellationₗ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₂_)
  variable ⦃ cancᵣ₂ ⦄ : Cancellationᵣ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₂_)
  variable ⦃ assoc₂ ⦄ : Associativity ⦃ equiv ⦄ (_▫₂_)
  variable ⦃ ident₂  ⦄ : Identity ⦃ equiv ⦄ (_▫₂_)(id)
  variable ⦃ identₗ₂ ⦄ : Identityₗ ⦃ equiv ⦄ (_▫₂_)(id)
  variable ⦃ identᵣ₂ ⦄ : Identityᵣ ⦃ equiv ⦄ (_▫₂_)(id)
  variable ⦃ inver₂  ⦄ : InverseFunction ⦃ equiv ⦄ (_▫₂_) ⦃ [∃]-intro(id) ⦃ ident₂ ⦄ ⦄ (inv)
  variable ⦃ inverₗ₂ ⦄ : InverseFunctionₗ ⦃ equiv ⦄ (_▫₂_) ⦃ [∃]-intro(id) ⦃ identₗ₂ ⦄ ⦄ (inv)
  variable ⦃ inverᵣ₂ ⦄ : InverseFunctionᵣ ⦃ equiv ⦄ (_▫₂_) ⦃ [∃]-intro(id) ⦃ identᵣ₂ ⦄ ⦄ (inv)
  variable ⦃ absorbₗ₂ ⦄ : Absorberₗ ⦃ equiv ⦄ (_▫₂_)(id)
  variable ⦃ absorbᵣ₂ ⦄ : Absorberᵣ ⦃ equiv ⦄ (_▫₂_)(id)

  variable ⦃ distriₗ ⦄ : Distributivityₗ ⦃ equiv ⦄ (_▫₁_)(_▫₂_)
  variable ⦃ distriᵣ ⦄ : Distributivityᵣ ⦃ equiv ⦄ (_▫₁_)(_▫₂_)
  variable ⦃ absorpₗ ⦄ : Absorptionₗ ⦃ equiv ⦄ (_▫₁_)(_▫₂_)
  variable ⦃ absorpᵣ ⦄ : Absorptionᵣ ⦃ equiv ⦄ (_▫₁_)(_▫₂_)
  variable ⦃ inverOpₗ ⦄ : InverseOperatorₗ ⦃ equiv ⦄ (_▫₁_)(_▫₂_)
  variable ⦃ inverOpᵣ ⦄ : InverseOperatorᵣ ⦃ equiv ⦄ (_▫₁_)(_▫₂_)

module Two {ℓ₁ ℓ₂ ℓₑ₁ ℓₑ₂} {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ {_▫₁_ : A → A → A} {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ {_▫₂_ : B → B → B} where
  variable {id₁} : A
  variable {inv₁} : A → A
  variable {id₂} : B
  variable {inv₂} : B → B

  variable ⦃ op₁ ⦄ : BinaryOperator ⦃ equiv-A ⦄ ⦃ equiv-A ⦄ ⦃ equiv-A ⦄ (_▫₁_)
  variable ⦃ comm₁ ⦄ : Commutativity ⦃ equiv-A ⦄ (_▫₁_)
  variable ⦃ cancₗ₁ ⦄ : Cancellationₗ ⦃ equiv-A ⦄ ⦃ equiv-A ⦄ (_▫₁_)
  variable ⦃ cancᵣ₁ ⦄ : Cancellationᵣ ⦃ equiv-A ⦄ ⦃ equiv-A ⦄ (_▫₁_)
  variable ⦃ assoc₁ ⦄ : Associativity ⦃ equiv-A ⦄ (_▫₁_)
  variable ⦃ ident₁  ⦄ : Identity ⦃ equiv-A ⦄ (_▫₁_)(id₁)
  variable ⦃ identₗ₁ ⦄ : Identityₗ ⦃ equiv-A ⦄ (_▫₁_)(id₁)
  variable ⦃ identᵣ₁ ⦄ : Identityᵣ ⦃ equiv-A ⦄ (_▫₁_)(id₁)
  variable ⦃ inver₁  ⦄ : InverseFunction ⦃ equiv-A ⦄ (_▫₁_) ⦃ [∃]-intro(id₁) ⦃ ident₁ ⦄ ⦄ (inv₁)
  variable ⦃ inverₗ₁ ⦄ : InverseFunctionₗ ⦃ equiv-A ⦄ (_▫₁_) ⦃ [∃]-intro(id₁) ⦃ identₗ₁ ⦄ ⦄ (inv₁)
  variable ⦃ inverᵣ₁ ⦄ : InverseFunctionᵣ ⦃ equiv-A ⦄ (_▫₁_) ⦃ [∃]-intro(id₁) ⦃ identᵣ₁ ⦄ ⦄ (inv₁)

  variable ⦃ op₂ ⦄ : BinaryOperator ⦃ equiv-B ⦄ ⦃ equiv-B ⦄ ⦃ equiv-B ⦄ (_▫₂_)
  variable ⦃ comm₂ ⦄ : Commutativity ⦃ equiv-B ⦄ (_▫₂_)
  variable ⦃ cancₗ₂ ⦄ : Cancellationₗ ⦃ equiv-B ⦄ ⦃ equiv-B ⦄ (_▫₂_)
  variable ⦃ cancᵣ₂ ⦄ : Cancellationᵣ ⦃ equiv-B ⦄ ⦃ equiv-B ⦄ (_▫₂_)
  variable ⦃ assoc₂ ⦄ : Associativity ⦃ equiv-B ⦄ (_▫₂_)
  variable ⦃ ident₂  ⦄ : Identity ⦃ equiv-B ⦄ (_▫₂_)(id₂)
  variable ⦃ identₗ₂ ⦄ : Identityₗ ⦃ equiv-B ⦄ (_▫₂_)(id₂)
  variable ⦃ identᵣ₂ ⦄ : Identityᵣ ⦃ equiv-B ⦄ (_▫₂_)(id₂)
  variable ⦃ inver₂  ⦄ : InverseFunction ⦃ equiv-B ⦄ (_▫₂_) ⦃ [∃]-intro(id₂) ⦃ ident₂ ⦄ ⦄ (inv₂)
  variable ⦃ inverₗ₂ ⦄ : InverseFunctionₗ ⦃ equiv-B ⦄ (_▫₂_) ⦃ [∃]-intro(id₂) ⦃ identₗ₂ ⦄ ⦄ (inv₂)
  variable ⦃ inverᵣ₂ ⦄ : InverseFunctionᵣ ⦃ equiv-B ⦄ (_▫₂_) ⦃ [∃]-intro(id₂) ⦃ identᵣ₂ ⦄ ⦄ (inv₂)


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

open import Base
open import Homotopy.Pushout
open import Homotopy.VanKampen.Guide

module Homotopy.VanKampen.Code {i} (d : pushout-diag i)
  (l : legend i (pushout-diag.C d)) where

  open pushout-diag d
  open legend l

  open import Homotopy.Truncation
  open import Homotopy.PathTruncation

  -- Code from A.
  import Homotopy.VanKampen.SplitCode d l as SC
  import Homotopy.VanKampen.Code.LemmaPackA d l as C
  -- Code from B. Code flipped.
  import Homotopy.VanKampen.SplitCode (pushout-diag-flip d) l as SCF
  import Homotopy.VanKampen.Code.LemmaPackA (pushout-diag-flip d) l as CF

  P : Set i
  P = pushout d

  module _ where
    -- Things that can be directly re-exported
    -- FIXME Ideally, this should be ‵SC'.
    -- Somehow that doesn′t work.
    open import Homotopy.VanKampen.SplitCode d l
      public using () renaming
        ( code            to a-code
        ; code-a          to a-code-a
        ; code-b          to a-code-b
        ; code-rec        to a-code-rec
        ; code-rec-nondep to a-code-rec-nondep
        ; code-is-set     to a-code-is-set
        ; code-a-is-set   to a-code-a-is-set
        ; code-b-is-set   to a-code-b-is-set
        )
    module _ {a₁ : A} where
      open import Homotopy.VanKampen.SplitCode d l a₁
        public using () renaming
          ( code-a-refl-refl  to a-code-a-refl-refl
          ; code-b-refl-refl  to a-code-b-refl-refl
          ; code-ab-swap      to a-code-ab-swap
          ; trans-a           to trans-a-code-a
          ; trans-ba          to trans-a-code-ba
          ; trans-ab          to trans-a-code-ab
          ; a⇒b               to aa⇒ab
          ; b⇒a               to ab⇒aa
          )

    a-a : ∀ {a₁} {a₂} → a₁ ≡₀ a₂ → a-code-a a₁ a₂
    a-a = SC.a _

    infixl 6 a-a
    syntax a-a co = ⟧a co

    a-ba : ∀ {a₁} {a₂} n → a-code-b a₁ (g $ loc n) → f (loc n) ≡₀ a₂ → a-code-a a₁ a₂
    a-ba = SC.ba _

    infixl 6 a-ba
    syntax a-ba n co p = co ab⟦ n ⟧a p

    a-ab : ∀ {a₁} {b₂} n → a-code-a a₁ (f $ loc n) → g (loc n) ≡₀ b₂ → a-code-b a₁ b₂
    a-ab = SC.ab _

    infixl 6 a-ab
    syntax a-ab n co p = co aa⟦ n ⟧b p

  module _ where
    -- Things that can be directly re-exported
    open import Homotopy.VanKampen.SplitCode (pushout-diag-flip d) l
      public using () renaming
        ( code-a          to b-code-b
        ; code-b          to b-code-a
        ; code-rec        to b-code-rec
        ; code-rec-nondep to b-code-rec-nondep
        ; code-a-is-set   to b-code-b-is-set
        ; code-b-is-set   to b-code-a-is-set
        )

    b-code : B → P → Set i
    b-code b = SCF.code b ◯ pushout-flip

    module _ {b₁ : B} where
      open import Homotopy.VanKampen.SplitCode (pushout-diag-flip d) l b₁
        public using () renaming
          ( code-a-refl-refl  to b-code-b-refl-refl
          ; code-b-refl-refl  to b-code-a-refl-refl
          ; code-ab-swap      to b-code-ba-swap
          ; trans-a           to trans-b-code-b
          ; trans-ba          to trans-b-code-ab
          ; trans-ab          to trans-b-code-ba
          ; a⇒b               to bb⇒ba
          ; b⇒a               to ba⇒bb
          )

    b-b : ∀ {b₁} {b₂} → b₁ ≡₀ b₂ → b-code-b b₁ b₂
    b-b = SCF.a _

    infixl 6 b-b
    syntax b-b co = ⟧b co

    b-ab : ∀ {b₁} {b₂} n → b-code-a b₁ (f $ loc n) → g (loc n) ≡₀ b₂ → b-code-b b₁ b₂
    b-ab = SCF.ba _

    infixl 6 b-ab
    syntax b-ab c co p = co ba⟦ c ⟧b p

    b-ba : ∀ {b₁} {a₂} n → b-code-b b₁ (g $ loc n) → f (loc n) ≡₀ a₂ → b-code-a b₁ a₂
    b-ba = SCF.ab _

    infixl 6 b-ba
    syntax b-ba c co p = co bb⟦ c ⟧a p

    b-code-is-set : ∀ b₁ p₂ → is-set (b-code b₁ p₂)
    b-code-is-set b₁ = SCF.code-is-set b₁ ◯ pushout-flip

  -- Tail flipping
  open import Homotopy.VanKampen.Code.LemmaPackA d l public
    using () renaming
      ( aa⇒ba to aa⇒ba
      ; ab⇒bb to ab⇒bb
      ; ap⇒bp to ap⇒bp
      )
  open import Homotopy.VanKampen.Code.LemmaPackA (pushout-diag-flip d) l public
    using () renaming
      ( aa⇒ba to bb⇒ab
      ; ab⇒bb to ba⇒aa
      )

  -- Tail drifting
  open import Homotopy.VanKampen.Code.LemmaPackB d l public
    using () renaming
      ( trans-q-code-a  to trans-q-a-code-a
      ; trans-!q-code-a to trans-!q-a-code-a
      ; trans-q-code-ba to trans-q-a-code-ba
      ; trans-q-code-ab to trans-q-a-code-ab
      )
  open import Homotopy.VanKampen.Code.LemmaPackB (pushout-diag-flip d) l public
    using () renaming
      ( trans-q-code-a  to trans-q-b-code-b
      ; trans-!q-code-a to trans-!q-b-code-b
      ; trans-q-code-ba to trans-q-b-code-ab
      ; trans-q-code-ab to trans-q-b-code-ba
      )

  bp⇒ap : ∀ n {p} → b-code (g $ loc n) p → a-code (f $ loc n) p
  bp⇒ap n {p} = transport
    (λ x → b-code (g $ loc n) p → a-code (f $ loc n) x)
    (pushout-flip-flip p)
    (CF.ap⇒bp n {pushout-flip p})

  private
    Laba : name → P → Set i
    Laba = λ n p → ∀ (co : a-code (f $ loc n) p) → bp⇒ap n {p} (ap⇒bp n {p} co) ≡ co
  private
    aba-glue-code : ∀ c {p} → Laba c p
  abstract
    aba-glue-code n {p} = pushout-rec (Laba n)
      (λ _ → C.aba-glue-code-a n)
      (λ _ → C.aba-glue-code-b n)
      (λ _ → funext λ _ → prop-has-all-paths (a-code-b-is-set (f $ loc n) _ _ _) _ _)
      p

  private
    Lbab : name → P → Set i
    Lbab = λ n p → ∀ (co : b-code (g $ loc n) p) → ap⇒bp n {p} (bp⇒ap n {p} co) ≡ co
  private
    bab-glue-code : ∀ n {p} → Lbab n p
  abstract
    bab-glue-code n {p} = pushout-rec (Lbab n)
      (λ _ → CF.aba-glue-code-b n)
      (λ _ → CF.aba-glue-code-a n)
      (λ _ → funext λ _ → prop-has-all-paths (b-code-b-is-set (g $ loc n) _ _ _) _ _)
      p

  private
    glue-code-loc : ∀ n p → a-code (f $ loc n) p ≃ b-code (g $ loc n) p
    glue-code-loc n p = ap⇒bp n {p} , iso-is-eq
      (ap⇒bp n {p}) (bp⇒ap n {p}) (bab-glue-code n {p}) (aba-glue-code n {p})

  private
    TapbpTa : ∀ n₁ n₂ (r : loc n₁ ≡ loc n₂) {a}
      → a-code-a (f $ loc n₂) a → Set i
    TapbpTa n₁ n₂ r {a} co =
        transport (λ x → b-code-a x a) (ap g r)
          (aa⇒ba n₁ {a} $ transport (λ x → a-code-a x a) (! $ ap f r) co)
      ≡ aa⇒ba n₂ {a} co

    TapbpTb : ∀ n₁ n₂ (r : loc n₁ ≡ loc n₂) {b}
      → a-code-b (f $ loc n₂) b → Set i
    TapbpTb n₁ n₂ r {b} co =
        transport (λ x → b-code-b x b) (ap g r)
          (ab⇒bb n₁ {b} $ transport (λ x → a-code-b x b) (! $ ap f r) co)
      ≡ ab⇒bb n₂ {b} co

    TapbpTp : ∀ n₁ n₂ (r : loc n₁ ≡ loc n₂) {p}
      → a-code (f $ loc n₂) p → Set i
    TapbpTp n₁ n₂ r {p} co =
        transport (λ x → b-code x p) (ap g r)
          (ap⇒bp n₁ {p} $ transport (λ x → a-code x p) (! $ ap f r) co)
      ≡ ap⇒bp n₂ {p} co

  private
    ap⇒bp-shift-split : ∀ n₁ n₂ r
      → (∀ {a₂} co → TapbpTa n₁ n₂ r {a₂} co)
      × (∀ {b₂} co → TapbpTb n₁ n₂ r {b₂} co)
  abstract
    ap⇒bp-shift-split n₁ n₂ r = a-code-rec (f $ loc n₂)
      (TapbpTa n₁ n₂ r)
      ⦃ λ _ → ≡-is-set $ b-code-a-is-set _ _ ⦄
      (TapbpTb n₁ n₂ r)
      ⦃ λ _ → ≡-is-set $ b-code-b-is-set _ _ ⦄
      (λ {a} p →
        transport (λ x → b-code-a x a) (ap g r)
          (aa⇒ba n₁ {a} $ transport (λ x → a-code-a x a) (! $ ap f r) $ ⟧a p)
            ≡⟨ ap (transport (λ x → b-code-a x a) (ap g r) ◯ aa⇒ba n₁ {a})
                  $ trans-!q-a-code-a (ap f r) p ⟩
        transport (λ x → b-code-a x a) (ap g r)
          (⟧b refl₀ bb⟦ n₁ ⟧a proj (ap f r) ∘₀ p)
            ≡⟨ trans-q-b-code-ba (ap g r) _ _ _ ⟩
        transport (λ x → b-code-b x (g $ loc n₁)) (ap g r) (⟧b refl₀)
          bb⟦ n₁ ⟧a proj (ap f r) ∘₀ p
            ≡⟨ ap (λ x → x bb⟦ n₁ ⟧a proj (ap f r) ∘₀ p) $ trans-q-b-code-b (ap g r) _ ⟩
        ⟧b proj (! (ap g r)) ∘₀ refl₀ bb⟦ n₁ ⟧a proj (ap f r) ∘₀ p
            ≡⟨ ap (λ x → ⟧b x bb⟦ n₁ ⟧a proj (ap f r) ∘₀ p) $ refl₀-right-unit _ ⟩
        ⟧b proj (! (ap g r)) bb⟦ n₁ ⟧a proj (ap f r) ∘₀ p
            ≡⟨ ! $ SCF.code-a-shift (g $ loc n₂) n₁ (proj (! (ap g r))) n₂ (proj r) p ⟩
        ⟧b proj (! (ap g r) ∘ ap g r) bb⟦ n₂ ⟧a p
            ≡⟨ ap (λ x → ⟧b proj x bb⟦ n₂ ⟧a p) $ opposite-left-inverse $ ap g r ⟩∎
        aa⇒ba n₂ {a} (⟧a p)
            ∎)
      (λ {a} n {co} pco p →
        transport (λ x → b-code-a x a) (ap g r)
          (aa⇒ba n₁ {a} $ transport (λ x → a-code-a x a) (! $ ap f r) $ co ab⟦ n ⟧a p)
            ≡⟨ ap (transport (λ x → b-code-a x a) (ap g r) ◯ aa⇒ba n₁ {a})
                  $ trans-q-a-code-ba (! $ ap f r) n co p ⟩
        transport (λ x → b-code-a x a) (ap g r)
          (ab⇒bb n₁ {g $ loc n} (transport (λ x → a-code-b x (g $ loc n)) (! $ ap f r) co) bb⟦ n ⟧a p)
            ≡⟨ trans-q-b-code-ba (ap g r) _ _ _ ⟩
        transport (λ x → b-code-b x (g $ loc n)) (ap g r)
          (ab⇒bb n₁ {g $ loc n} (transport (λ x → a-code-b x (g $ loc n)) (! $ ap f r) co)) bb⟦ n ⟧a p
            ≡⟨ ap (λ x → x bb⟦ n ⟧a p) pco ⟩∎
        ab⇒bb n₂ {g $ loc n} co bb⟦ n ⟧a p
            ∎)
      (λ {b} n {co} pco p →
        transport (λ x → b-code-b x b) (ap g r)
          (ab⇒bb n₁ {b} $ transport (λ x → a-code-b x b) (! $ ap f r) $ co aa⟦ n ⟧b p)
            ≡⟨ ap (transport (λ x → b-code-b x b) (ap g r) ◯ ab⇒bb n₁ {b})
                  $ trans-q-a-code-ab (! $ ap f r) n co p ⟩
        transport (λ x → b-code-b x b) (ap g r)
          (aa⇒ba n₁ {f $ loc n} (transport (λ x → a-code-a x (f $ loc n)) (! $ ap f r) co) ba⟦ n ⟧b p)
            ≡⟨ trans-q-b-code-ab (ap g r) _ _ _ ⟩
        transport (λ x → b-code-a x (f $ loc n)) (ap g r)
          (aa⇒ba n₁ {f $ loc n} (transport (λ x → a-code-a x (f $ loc n)) (! $ ap f r) co)) ba⟦ n ⟧b p
            ≡⟨ ap (λ x → x ba⟦ n ⟧b p) pco ⟩∎
        aa⇒ba n₂ {f $ loc n} co ba⟦ n ⟧b p
            ∎)
      (λ _ _ → prop-has-all-paths (b-code-a-is-set _ _ _ _) _ _)
      (λ _ _ → prop-has-all-paths (b-code-b-is-set _ _ _ _) _ _)
      (λ _ _ _ _ → prop-has-all-paths (b-code-a-is-set _ _ _ _) _ _)

  private
    ap⇒bp-shift : ∀ n₁ n₂ r {p} co → TapbpTp n₁ n₂ r {p} co
  abstract
    ap⇒bp-shift n₁ n₂ r {p} co =
      pushout-rec
        (λ p → ∀ co → TapbpTp n₁ n₂ r {p} co)
        (λ a → π₁ (ap⇒bp-shift-split n₁ n₂ r) {a})
        (λ b → π₂ (ap⇒bp-shift-split n₁ n₂ r) {b})
        (λ c → funext λ _ → prop-has-all-paths (b-code-is-set (g $ loc n₂) (right $ g c) _ _) _ _)
        p co

  glue-code-eq-route : ∀ p n₁ n₂ (r : loc n₁ ≡ loc n₂)
    → transport (λ c → a-code (f c) p ≃ b-code (g c) p) r (glue-code-loc n₁ p)
    ≡ glue-code-loc n₂ p
  abstract
    glue-code-eq-route p n₁ n₂ r = equiv-eq $ funext λ co →
      π₁ (transport (λ c → a-code (f c) p ≃ b-code (g c) p) r (glue-code-loc n₁ p)) co
        ≡⟨ ap (λ x → x co) $ app-trans
            (λ c → a-code (f c) p ≃ b-code (g c) p)
            (λ c → a-code (f c) p → b-code (g c) p)
            (λ _ → π₁)
            r
            (glue-code-loc n₁ p) ⟩
      transport (λ c → a-code (f c) p → b-code (g c) p) r (ap⇒bp n₁ {p}) co
        ≡⟨ trans-→ (λ c → a-code (f c) p) (λ c → b-code (g c) p) r (ap⇒bp n₁ {p}) co ⟩
      transport (λ c → b-code (g c) p) r (ap⇒bp n₁ {p} $ transport (λ c → a-code (f c) p) (! r) co)
        ≡⟨ ap (transport (λ c → b-code (g c) p) r ◯ ap⇒bp n₁ {p}) $ ! $ trans-ap (λ x → a-code x p) f (! r) co ⟩
      transport (λ c → b-code (g c) p) r (ap⇒bp n₁ {p} $ transport (λ x → a-code x p) (ap f (! r)) co)
        ≡⟨ ap (λ x → transport (λ c → b-code (g c) p) r $ ap⇒bp n₁ {p}
                    $ transport (λ x → a-code x p) x co)
              $ ap-opposite f r ⟩
      transport (λ c → b-code (g c) p) r (ap⇒bp n₁ {p} $ transport (λ x → a-code x p) (! $ ap f r) co)
        ≡⟨ ! $ trans-ap (λ x → b-code x p) g r _ ⟩
      transport (λ x → b-code x p) (ap g r) (ap⇒bp n₁ {p} $ transport (λ x → a-code x p) (! $ ap f r) co)
        ≡⟨ ap⇒bp-shift n₁ n₂ r {p} co ⟩∎
      ap⇒bp n₂ {p} co
        ∎

  glue-code-eq : ∀ c p → a-code (f c) p ≃ b-code (g c) p
  glue-code-eq c p = visit-fiber-rec l (λ c → a-code (f c) p ≃ b-code (g c) p)
    ⦃ λ c → ≃-is-set (a-code-is-set (f c) p) (b-code-is-set (g c) p) ⦄
    (λ n → glue-code-loc n p)
    (glue-code-eq-route p)
    c

  code : P → P → Set i
  code = pushout-rec-nondep (P → Set i) a-code b-code
    (λ c → funext λ p → eq-to-path $ glue-code-eq c p)

  open import HLevelBis
  abstract
    code-is-set : ∀ p₁ p₂ → is-set (code p₁ p₂)
    code-is-set = pushout-rec
      (λ p₁ → ∀ p₂ → is-set $ code p₁ p₂)
      a-code-is-set
      b-code-is-set
      (λ _ → prop-has-all-paths (Π-is-prop λ _ → is-set-is-prop) _ _)

  -- Useful lemma
  module _ {a₁ : A} where
    open import Homotopy.VanKampen.SplitCode d l a₁
      public using () renaming
        ( trans-code-glue-loc   to trans-a-code-glue-loc
        ; trans-code-!glue-loc  to trans-a-code-!glue-loc
        )

  abstract
    trans-b-code-glue-loc : ∀ {b₁} n₂ co → transport (b-code b₁) (glue $ loc n₂) co ≡ ba⇒bb n₂ co
    trans-b-code-glue-loc {b₁} n₂ co =
      transport (b-code b₁) (glue $ loc n₂) co
          ≡⟨ ! $ trans-ap (SCF.code b₁) pushout-flip (glue $ loc n₂) co ⟩
      transport (SCF.code b₁) (ap pushout-flip (glue $ loc n₂)) co
          ≡⟨ ap (λ x → transport (SCF.code b₁) x co)
                $ pushout-β-glue-nondep _ right left (! ◯ glue) (loc n₂) ⟩
      transport (SCF.code b₁) (! (glue $ loc n₂)) co
          ≡⟨ SCF.trans-code-!glue-loc b₁ n₂ co ⟩∎
      ba⇒bb n₂ co
          ∎

  abstract
    trans-b-code-!glue-loc : ∀ {b₁} n₂ co → transport (b-code b₁) (! (glue $ loc n₂)) co ≡ bb⇒ba n₂ co
    trans-b-code-!glue-loc {b₁} n₂ co =
      transport (b-code b₁) (! (glue $ loc n₂)) co
          ≡⟨ ! $ trans-ap (SCF.code b₁) pushout-flip (! (glue $ loc n₂)) co ⟩
      transport (SCF.code b₁) (ap pushout-flip (! (glue $ loc n₂))) co
          ≡⟨ ap (λ x → transport (SCF.code b₁) x co)
                $ pushout-β-!glue-nondep _ right left (! ◯ glue) (loc n₂) ⟩
      transport (SCF.code b₁) (! (! (glue $ loc n₂))) co
          ≡⟨ ap (λ x → transport (SCF.code b₁) x co)
                $ opposite-opposite $ glue $ loc n₂ ⟩
      transport (SCF.code b₁) (glue $ loc n₂) co
          ≡⟨ SCF.trans-code-glue-loc b₁ n₂ co ⟩∎
      bb⇒ba n₂ co
          ∎

  abstract
    trans-glue-code-loc : ∀ n {p} (co : a-code (f $ loc n) p)
      → transport (λ x → code x p) (glue $ loc n) co
      ≡ ap⇒bp n {p} co
    trans-glue-code-loc n {p} co =
        transport (λ x → code x p) (glue $ loc n) co
            ≡⟨ ! $ trans-ap (λ f → f p) code (glue $ loc n) co ⟩
        transport (λ f → f p) (ap code (glue $ loc n)) co
            ≡⟨ ap (λ x →  transport (λ f → f p) x co)
                $ pushout-β-glue-nondep (P → Set i) a-code b-code
                  (λ c → funext λ p → eq-to-path $ glue-code-eq c p)
                $ loc n ⟩
        transport (λ f → f p) (funext λ p → eq-to-path $ glue-code-eq (loc n) p) co
            ≡⟨ ! $ trans-ap (λ X → X) (λ f → f p)
                    (funext λ p → eq-to-path $ glue-code-eq (loc n) p) co ⟩
        transport (λ X → X) (happly (funext λ p → eq-to-path $ glue-code-eq (loc n) p) p) co
            ≡⟨ ap (λ x → transport (λ X → X) (x p) co)
                  $ happly-funext (λ p → eq-to-path $ glue-code-eq (loc n) p) ⟩
        transport (λ X → X) (eq-to-path $ glue-code-eq (loc n) p) co
            ≡⟨ trans-id-eq-to-path (glue-code-eq (loc n) p) co ⟩
        π₁ (glue-code-eq (loc n) p) co
            ≡⟨ ap (λ x → π₁ x co) $
                visit-fiber-β-loc l
                (λ c → a-code (f c) p ≃ b-code (g c) p)
                ⦃ λ c → ≃-is-set (a-code-is-set (f c) p) (b-code-is-set (g c) p) ⦄
                (λ n → glue-code-loc n p)
                (glue-code-eq-route p)
                n ⟩∎
        ap⇒bp n {p} co
            ∎

  abstract
    trans-!glue-code-loc : ∀ n {p} (co : b-code (g $ loc n) p)
      → transport (λ x → code x p) (! $ glue $ loc n) co
      ≡ bp⇒ap n {p} co
    trans-!glue-code-loc n {p} co =
      move!-transp-right (λ x → code x p) (glue $ loc n) co (bp⇒ap n {p} co)
        $ ! $
          transport (λ x → code x p) (glue $ loc n) (bp⇒ap n {p} co)
            ≡⟨ trans-glue-code-loc n {p} (bp⇒ap n {p} co) ⟩
          ap⇒bp n {p} (bp⇒ap n {p} co)
            ≡⟨ bab-glue-code n {p} co ⟩∎
          co
            ∎


{-# OPTIONS --instance-search-depth=10 #-}
data ⊥ : Set where

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

postulate Eq : Set → Set

instance
  postulate weaken : Eq ⊥ → Eq _

loop : Eq ⊥
loop = it


module Issue847 where

data ⊥ : Set where

bad : ⊥
bad = bad′
  where
  abstract
    bad′ : ⊥
    bad′ = bad


module View where

open import Data.Unit
open import Data.Char
open import Data.Maybe
open import Data.Container.Indexed

open import Signature
open import Model
open import IO.Primitive

------------------------------------------------------------------------

postulate
  view : Model → IO ⊤

data VtyEvent : Set where
  key   : Char → VtyEvent
  enter : VtyEvent

vtyToCmd : VtyEvent → (m : Mode) → Maybe (Command Hårss m)
vtyToCmd (key 'j')  cmd            = just (moveP down)
vtyToCmd (key 'k')  cmd            = just (moveP up)
vtyToCmd (key 'a')  cmd            = just (promptP addFeed)
vtyToCmd (key '\t') cmd            = just (promptP search)
vtyToCmd (key 'R')  cmd            = just fetchP
vtyToCmd _          cmd            = nothing
vtyToCmd enter      (input p)      = just doneP
vtyToCmd (key '\t') (input search) = just searchNextP
vtyToCmd (key c)    (input p)      = just (putCharP c)


{- 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.ImplShared.Consensus.Types
open import Util.Encode
open import Util.PKCS                           as PKCS hiding (sign; verify)
open import Util.Prelude

module LibraBFT.Impl.OBM.Crypto where

------------------------------------------------------------------------------
-- keys

postulate -- TODO-1 : makePK
  makePK : SK → PK

------------------------------------------------------------------------------

postulate -- TODO-1: implement obmHashVersion
  obmHashVersion : Version → HashValue

------------------------------------------------------------------------------
-- sign and verify

record CryptoHash (A : Set) : Set where
  field
    sign        : SK → A → Signature
    verify      : {-Text-} PK → Signature → A → Either ErrLog Unit
    ⦃ encodeA ⦄ : Encoder A

open CryptoHash ⦃ ... ⦄ public

instance
  CryptoHashBlockData : CryptoHash BlockData
  CryptoHashBlockData = record
    { sign   = λ sk bd     → PKCS.sign-raw  (encode bd)     sk
    ; verify = λ pk sig bd → if PKCS.verify (encode bd) sig pk
                             then Right unit
                             else Left fakeErr }

instance
  CryptoHashLedgerInfo : CryptoHash LedgerInfo
  CryptoHashLedgerInfo = record
    { sign   = λ sk li     → PKCS.sign-raw  (encode li)     sk
    ; verify = λ pk sig li → if PKCS.verify (encode li) sig pk
                             then Right unit
                             else Left fakeErr }

instance
  CryptoHashTimeout : CryptoHash Timeout
  CryptoHashTimeout = record
    { sign   = λ sk to     → PKCS.sign-raw  (encode to)     sk
    ; verify = λ pk sig to → if PKCS.verify (encode to) sig pk
                             then Right unit
                             else Left fakeErr }


open import Prelude

module Implicits.Resolution.Finite.Decidable where

open import Coinduction
open import Data.Fin.Substitution
open import Data.List.Any
open Membership-≡
open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Implicits.Resolution.Finite.Resolution
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Function.Equality hiding (cong)
open import Data.List.Any.Properties using (Any↔)

module M = MetaTypeMetaSubst

mutual
  {-# NO_TERMINATION_CHECK #-}
  match' : ∀ {m ν} (Δ : ICtx ν) s r∈Δ τ → (r : MetaType m ν) →
          Dec (∃ λ u → Δ & s , r∈Δ ⊢ from-meta (r M./ u) ↓ τ)
  match' Δ s r∈Δ τ (simpl x) with mgu (simpl x) τ
  match' Δ s r∈Δ τ (simpl x) | just (u , p) =
    yes (
      (asub u) ,
      subst (λ a → Δ & s , r∈Δ  ⊢ a ↓ τ) (sym $ mgu-unifies (simpl x) τ (u , p)) (i-simp τ)
    )
  match' Δ s r∈Δ τ (simpl x) | nothing = no (λ{ (proj₁ , proj₂) → {!!} })

  match' Δ s r∈Δ τ (a ⇒ b) with match' Δ s r∈Δ τ b
  match' Δ s r∈Δ τ (a ⇒ b) | no ¬p = no {!!}
  match' Δ s r∈Δ τ (a ⇒ b) | yes (u , b/u↓τ) with
    all (λ x → (r∈Δ , (from-meta (a M./ u))) ?⊬dom x) s
  match' Δ s r∈Δ τ (a ⇒ b) | yes (u , b/u↓τ) | yes p
    -- The following with clause fails to satisfy termination checking
    with let a' = from-meta (a M./ u) in resolve' Δ ((r∈Δ , a') List.∷ s) a'
  match' Δ s r∈Δ τ (a ⇒ b) | yes (u , b/u↓τ) | yes p | yes ⊢ᵣa = yes (u , i-iabs p ⊢ᵣa b/u↓τ)
  match' Δ s r∈Δ τ (a ⇒ b) | yes (u , b/u↓τ) | yes p | no ¬⊢ᵣa =
    no (λ{ (u' , i-iabs x ⊢ᵣa a⇒b↓τ) → {!¬⊢ᵣa ⊢ᵣa!} })
  match' Δ s r∈Δ τ (a ⇒ b) | yes (u , b/u↓τ) | no ¬p = no {!!}

  -- The following with clause fails to satisfy termination checking
  match' Δ s r∈Δ τ (∀' a) with match' Δ s r∈Δ τ (open-meta a)
  match' Δ s r∈Δ τ (∀' a) | yes p = yes $ lem p
    where
      lem : (∃ λ u → Δ & s , r∈Δ ⊢ (from-meta ((open-meta a) M./ u)) ↓ τ) →
          ∃ λ u' → Δ & s , r∈Δ ⊢ (from-meta (∀' a M./ u')) ↓ τ
      lem (u ∷ us , p) = us , (i-tabs (from-meta u) (subst (λ v → Δ & s , r∈Δ ⊢ v ↓ τ) (begin
            from-meta (M._/_ (open-meta a) (u ∷ us))
              ≡⟨ cong (λ v → from-meta (M._/_ (open-meta a) v)) (sym $ us↑-⊙-sub-u≡u∷us u us) ⟩
            from-meta ((open-meta a) M./ (us M.↑ M.⊙ (M.sub u)))
              ≡⟨ cong from-meta (/-⊙ (open-meta a)) ⟩
            from-meta ((open-meta a) M./ us M.↑ M./ (M.sub u))
              ≡⟨ lem' a u us ⟩
            from-meta (M._/_ a (us M.↑tp)) tp[/tp from-meta u ] ∎) p))
          where open MetaTypeMetaLemmas hiding (subst)
  match' Δ s r∈Δ τ (∀' r) | no ¬p = no {!!}

  -- match defers to match', which concerns itself with MetaTypes.
  -- If match' finds a match, we can use the fact that we have zero unification variables open here
  -- to show that we found the right thing.
  match : ∀ {ν} (Δ : ICtx ν) s r∈Δ → ∀ r τ → Dec (Δ & s , r∈Δ ⊢ r ↓ τ)
  match Δ s r∈Δ a τ with match' Δ s r∈Δ τ (to-meta {zero} a)
  match Δ s r∈Δ a τ | yes x = yes (lem x)
    where
      eq : ∀ {ν} {a : Type ν} {s} → from-meta (to-meta {zero} a M./ s) ≡ a
      eq {a = a} {s = []} = begin
          from-meta (M._/_ (to-meta {zero} a) [])
          ≡⟨ cong (λ q → from-meta q) (MetaTypeMetaLemmas.id-vanishes (to-meta {zero} a)) ⟩
          from-meta (to-meta {zero} a)
          ≡⟨ to-meta-zero-vanishes ⟩
          a ∎
      lem : ∃ (λ u → Δ & s , r∈Δ ⊢ from-meta (to-meta {zero} a M./ u) ↓ τ) →
                Δ & s , r∈Δ ⊢ a ↓ τ
      lem ([] , proj₂) = subst (λ u → Δ & s , r∈Δ ⊢ u ↓ τ) eq proj₂
  match Δ s r∈Δ a τ | no ¬p = no {!!}

  match1st : ∀ {ν} (Δ : ICtx ν) s τ  → Dec (Any (λ r → Δ & s , r ⊢ r ↓ τ) Δ)
  match1st Δ s τ = match1st' Δ Δ s τ -- any (λ r → match Δ r τ)
    where
      match1st' : ∀ {ν} (Δ ρs : ICtx ν) s → (τ : SimpleType ν) →
                  Dec (Any (λ r → Δ & s , r ⊢ r ↓ τ) ρs)
      match1st' Δ List.[] s τ = no {!!}
      match1st' Δ (x List.∷ xs) s τ with match Δ s x x τ
      match1st' Δ (x List.∷ xs) s τ | yes px = yes (here px)
      match1st' Δ (x List.∷ xs) s τ | no ¬p with match1st' Δ xs s τ
      match1st' Δ (x List.∷ xs) s τ | no ¬p | yes y = yes (there y)
      match1st' Δ (x List.∷ xs) s τ | no ¬p | no ¬q = no {!!}

  resolve' : ∀ {ν} (Δ : ICtx ν) s r → (Dec (Δ & s ⊢ᵣ r))
  resolve' Δ s (simpl x) with match1st Δ s x
  resolve' Δ s (simpl x) | yes p =
    let r , r∈Δ , r↓x = (Inverse.from Any↔) Π.⟨$⟩ p in yes (r-simp r∈Δ r↓x)
  resolve' Δ s (simpl x) | no ¬p =
    no (λ{ (r-simp x₁ x₂) → ¬p (_⟨$⟩_ (Inverse.to Any↔) (_ , (x₁ , x₂))) })
  resolve' Δ s (a ⇒ b) with resolve' (a List.∷ Δ) s b
  resolve' Δ s (a ⇒ b) | yes p = yes (r-iabs p)
  resolve' Δ s (a ⇒ b) | no ¬p = no (λ{ (r-iabs x) → ¬p x })
  resolve' Δ s (∀' r) with resolve' (ictx-weaken Δ) (stack-weaken s) r
  resolve' Δ s (∀' r) | yes p = yes (r-tabs p)
  resolve' Δ s (∀' r) | no ¬p = no λ{ (r-tabs x) → ¬p x }

  resolve : ∀ {ν} (Δ : ICtx ν) r → (Dec (Δ & List.[] ⊢ᵣ r))
  resolve Δ r = resolve' Δ List.[] r


-- Andreas, 2015-03-16
-- Andreas, 2020-10-26 removed loop during injectivity check

open import Agda.Builtin.Size

-- Note: the assumption of pred is absurd,
-- but still should not make Agda loop.

module _ (pred : ∀ i → Size< i) where

data ⊥ : Set where

data SizeLt (i : Size) : Set where
  wrap : (j : Size< i) → SizeLt i

loop : (d : ∀ i → SizeLt i) → ∀ i → SizeLt i → ⊥
loop d i (wrap j) = loop d j (d j)

-- -- Loops during injectivity check:
-- loop : ∀ i → SizeLt i → ⊥
-- loop i (wrap j) = loop j (wrap (pred j))

d : ∀ i → SizeLt i
d i = wrap (pred i)

absurd : ⊥
absurd = loop d ∞ (d ∞)

_ = FIXME

-- Testcase temporarily mutilated, original error:
--
-- -Issue1428a.agda:..
-- -Functions may not return sizes, thus, function type
-- -(i : Size) → Size< i is illegal
-- -when checking that the expression ∀ i → Size< i is a type
--
-- +Issue1428a.agda:...
-- +Not in scope:
-- +  FIXME at Issue1428a.agda:...
-- +when scope checking FIXME


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

open import Data.Product
open import Data.List hiding (null; [_])
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Unary
open import Relation.Unary.PredicateTransformer using (Pt)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Monad.Possibly
open import Relation.Ternary.Monad.Weakening
open import Relation.Ternary.Data.ReflexiveTransitive

open import CF.Syntax as Src
open import CF.Contexts.Lexical

open import CF.Transform.Hoist
open import CF.Transform.UnCo
open import CF.Transform.Compile.Expressions
open import CF.Transform.Compile.Statements
open import CF.Transform.Compile.ToJVM

open import JVM.Builtins
open import JVM.Types
open import JVM.Contexts
open import JVM.Syntax.Values
open import JVM.Syntax.Instructions
open import JVM.Transform.Noooops
open import JVM.Compiler

module _ {T : Set} where
  open import JVM.Model T public

compile : ∀ {r} → Src.Block r [] → ∃ λ Γ → ε[ ⟪ Γ ∣ [] ↝ [] ⟫ ]
compile bl₁                       with hoist bl₁
... | _ , Possibly.possibly (intros r refl) bl₂  -- The grading of the possibility modality
                                                 -- proves that only the lexical context has been extended
          with unco bl₂
... | bl₃ with execCompiler (compiler [] bl₃)
... | bl₄ with noooop bl₄
... | bl₅ = -, bl₅