{- 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
-}
{-# OPTIONS --allow-unsolved-metas #-}

-- This module proves the two "VotesOnce" proof obligations for our fake handler

open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS

import      LibraBFT.Concrete.Properties.VotesOnce as VO
open import LibraBFT.Impl.Base.Types

open import LibraBFT.Impl.Consensus.Types hiding (EpochConfigFor)
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Consensus.ChainedBFT.EventProcessor.Properties  sha256 sha256-cr
open import LibraBFT.Impl.Handle                                          sha256 sha256-cr
open import LibraBFT.Impl.Handle.Properties                               sha256 sha256-cr
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Properties.Aux
open import LibraBFT.Impl.Util.Util
open import LibraBFT.Concrete.System impl-sps-avp
open import LibraBFT.Concrete.System.Parameters
open        EpochConfig
open import LibraBFT.Yasm.Yasm (ℓ+1 0ℓ) EpochConfig epochId authorsN ConcSysParms NodeId-PK-OK
open        Structural impl-sps-avp

-- In this module, we prove the two implementation obligations for the VotesOnce rule.  Note
-- that it is not yet 100% clear that the obligations are the best definitions to use.  See comments
-- in Concrete.VotesOnce.  We will want to prove these obligations for the fake/simple
-- implementation (or some variant on it) and streamline the proof before we proceed to tackle more
-- ambitious properties.

module LibraBFT.Impl.Properties.VotesOnce where

  -- TODO-1: It seems that vo₂ should be proved via a couple of invocations of this property;
  -- the proofs are quite similar.
  newVoteSameEpochGreaterRound : ∀ {e}{pre : SystemState e}{pid initd' s' outs v m pk}
                               → ReachableSystemState pre
                               → StepPeerState {e} pid (availEpochs pre) (msgPool pre) (initialised pre) (peerStates pre pid) initd' (s' , outs)
                               → v  ⊂Msg m → m ∈ outs → (sig : WithVerSig pk v)
                               → ¬ MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
                               → (v ^∙ vEpoch) ≡ (₋epEC (peerStates pre pid)) ^∙ epEpoch
                               × suc ((₋epEC (peerStates pre pid)) ^∙ epLastVotedRound) ≡ (v ^∙ vRound)  -- New vote for higher round than last voted
                               × (v ^∙ vRound) ≡ ((₋epEC s') ^∙ epLastVotedRound)     -- Last voted round is round of new vote
  newVoteSameEpochGreaterRound _ (step-init _) v⊂m m∈outs sig = ⊥-elim (¬Any[] m∈outs)
  newVoteSameEpochGreaterRound {pre = pre} {pid} {m = m} r (step-msg {(_ , nm)} msg∈pool pinit) v⊂m m∈outs sig vnew
     rewrite pinit
     with nm
  ...| P msg
    with msgsToSendWereSent {pid} {0} {P msg} {m} {peerStates pre pid} m∈outs
  ...| vm , refl , vmSent
    with msgsToSendWereSent1 {pid} {0} {msg} {vm} {peerStates pre pid} vmSent
  ...| _ , v∈outs
     rewrite SendVote-inj-v  (Any-singleton⁻ v∈outs)
           | SendVote-inj-si (Any-singleton⁻ v∈outs)
    with v⊂m
       -- Rebuilding keeps the same signature, and the SyncInfo included with the
       -- VoteMsg sent comprises QCs from the peer's state.  Votes represented in
       -- those QCS have signatures that have been sent before, contradicting the
       -- assumption that v's signature has not been sent before.
  ...| vote∈qc {vs = vs} {qc} vs∈qc v≈rbld (inV qc∈m)
                  rewrite cong ₋vSignature v≈rbld
                        | procPMCerts≡ {0} {msg} {peerStates pre pid} {vm} v∈outs
     = ⊥-elim (vnew (qcVotesSentB4 r pinit refl qc∈m refl vs∈qc))
  ...| vote∈vm {si} = refl , refl , refl

  -- Always true, so far, as no epoch changes.
  noEpochChangeYet : ∀ {e}{pre : SystemState e}{pid}{initd' ppre ppost msgs}
                   → ReachableSystemState pre
                   → ppre ≡ peerStates pre pid
                   → StepPeerState pid (availEpochs pre) (msgPool pre) (initialised pre) ppre initd' (ppost , msgs)
                   → (₋epEC ppre) ^∙ epEpoch ≡ (₋epEC ppost) ^∙ epEpoch
  noEpochChangeYet _ ppre≡ (step-init ix) = {!!}
  noEpochChangeYet _ ppre≡ (step-msg {(_ , m)} _ _)
     with m
  ...| P p = refl
  ...| V v = refl
  ...| C c = refl

  -- We resist the temptation to combine this with the noEpochChangeYet because in future there will be epoch changes
  lastVoteRound-mono : ∀ {e}{pre : SystemState e}{pid}{initd' ppre ppost msgs}
                     → ReachableSystemState pre
                     → ppre ≡ peerStates pre pid
                     → StepPeerState pid (availEpochs pre) (msgPool pre) (initialised pre) ppre initd' (ppost , msgs)
                     → (₋epEC ppre) ^∙ epEpoch ≡ (₋epEC ppost) ^∙ epEpoch
                     → (₋epEC ppre) ^∙ epLastVotedRound ≤ (₋epEC ppost) ^∙ epLastVotedRound
  lastVoteRound-mono _ ppre≡ (step-init ix) _ = {!!}
  lastVoteRound-mono _ ppre≡ (step-msg {(_ , m)} _ _)
     with m
  ...| P p = const (≤-step (≤-reflexive refl))
  ...| V v = const (≤-reflexive refl)
  ...| C c = const (≤-reflexive refl)

  -- This is the information we can establish about the state after the first time a signature is
  -- sent, and that we can carry forward to subsequent states, so we can use it to prove
  -- VO.ImplObligation₁.
  LvrProp : CarrierProp
  LvrProp v ep = (  v ^∙ vEpoch ≢ (₋epEC ep) ^∙ epEpoch
                 ⊎ (v ^∙ vEpoch ≡ (₋epEC ep) ^∙ epEpoch × v ^∙ vRound ≤ (₋epEC ep) ^∙ epLastVotedRound))

  LvrCarrier = PropCarrier LvrProp

  firstSendEstablishes : ∀ {e} → Vote → PK → (origSt : SystemState e) → SystemStateRel Step
  firstSendEstablishes _ _ _ (step-epoch _)               = Lift (ℓ+1 0ℓ) ⊥
  firstSendEstablishes _ _ _ (step-peer (step-cheat _ _)) = Lift (ℓ+1 0ℓ) ⊥
  firstSendEstablishes {e} v' pk origSt sysStep@(step-peer {e'} {pid'} {pre = pre} pstep@(step-honest _)) =
                         ( ReachableSystemState pre
                         × ¬ MsgWithSig∈ pk (signature v' unit) (msgPool pre)
                         × LvrCarrier pk (₋vSignature v') (StepPeer-post pstep)
                         )

  isValidNewPart⇒fSE : ∀ {e e' pk v'}{pre : SystemState e} {post : SystemState e'} {theStep : Step pre post}
                     → Meta-Honest-PK pk
                     → (ivnp : IsValidNewPart (₋vSignature v') pk theStep)
                     → firstSendEstablishes v' pk pre theStep
  isValidNewPart⇒fSE {pre = pre} {theStep = step-peer {pid = β} {outs = outs} pstep} hpk (_ , ¬sentb4 , mws , _)
     with Any-++⁻ (List-map (β ,_) outs) (msg∈pool mws)
     -- TODO-1 : Much of this proof is not specific to the particular property being proved, and could be
     -- refactored into Yasm.Properties.  See proof of unwind and refactor to avoid redundancy?
  ...| inj₂ furtherBack = ⊥-elim (¬sentb4 (MsgWithSig∈-transp mws furtherBack))
  ...| inj₁ thisStep
     with pstep
  ...| step-cheat fm isCheat
     with thisStep
  ...| here refl
     with isCheat (msg⊆ mws) (msgSigned mws)
  ...| inj₁ dis = ⊥-elim (hpk dis)
  ...| inj₂ sentb4 rewrite msgSameSig mws = ⊥-elim (¬sentb4 sentb4)

  isValidNewPart⇒fSE {e}{pk = pk}{pre = pre}{theStep = step-peer {.e} {β} {postst} {outs} {.pre} pstep} hpk (r , ¬sentb4 , mws , vpk)
     | inj₁ thisStep
     | step-honest {.β} {postst} {outs} {init'} hstep
     with Any-satisfied-∈ (Any-map⁻ thisStep)
  ...| nm , refl , nm∈outs
     with hstep
  ...| step-init _ = ⊥-elim (¬Any[] nm∈outs)
  ...| step-msg {m} m∈pool _
     with impl-sps-avp {m = msgWhole mws} r hpk hstep nm∈outs (msg⊆ mws) (msgSigned mws)
  ...| inj₂ sentb4 rewrite msgSameSig mws = ⊥-elim (¬sentb4 sentb4)
  ...| inj₁ (vpk' , _)
     with sameEpoch⇒sameEC vpk vpk' refl
  ...| refl
     with newVoteSameEpochGreaterRound r hstep (msg⊆ mws) nm∈outs (msgSigned mws)
                                       (subst (λ sig → ¬ MsgWithSig∈ pk sig (msgPool pre))
                                              (sym (msgSameSig mws))
                                              ¬sentb4)
  ...| refl , refl , newlvr
     with noEpochChangeYet {ppre = peerStates pre β} r refl hstep
  ...| eids≡
     with StepPeer-post-lemma pstep
  ...| post≡ = r , ¬sentb4 , mkCarrier (step-s r (step-peer pstep)) mws vpk
                                       (inj₂ ( trans  eids≡ (auxEid post≡)
                                             , ≤-reflexive (trans newlvr (auxLvr post≡))))
                                       where auxEid = cong (_^∙ epEpoch ∘ ₋epEC)
                                             auxLvr = cong (_^∙ epLastVotedRound ∘ ₋epEC)

  ImplPreservesLvr : PeerStepPreserves LvrProp
  -- We don't have a real model for the initial peer state, so we can't prove this case yet.
  -- Eventually, we'll prove something like a peer doesn't initialize to an epoch for which
  -- it has already sent votes.
  ImplPreservesLvr r _ (step-init ix) = {!!}
  ImplPreservesLvr {pre = pre} r prop (step-msg {m} m∈pool inited)
     with carrProp prop
  ...| preprop
     with noEpochChangeYet r refl (step-msg m∈pool inited)
  ...| stepDNMepoch
     with preprop
  ...| inj₁ diffEpoch = inj₁ λ x → diffEpoch (trans x (sym stepDNMepoch))
  ...| inj₂ (sameEpoch , rnd≤ppre)
     with (msgPart (carrSent prop)) ^∙ vEpoch ≟ (₋epEC (peerStates pre (msgSender (carrSent prop)))) ^∙ epEpoch
  ...| no neq = ⊥-elim (neq sameEpoch)
  ...| yes refl
     with lastVoteRound-mono r refl (step-msg m∈pool inited)
  ...| es≡⇒lvr≤
     = inj₂ (stepDNMepoch , ≤-trans rnd≤ppre (es≡⇒lvr≤ stepDNMepoch))

  LvrCarrier-transp* : ∀ {e e' pk sig} {start : SystemState e}{final : SystemState e'}
                     → LvrCarrier pk sig start
                     → (step* : Step* start final)
                     → LvrCarrier pk sig final
  LvrCarrier-transp* lvrc step-0 = lvrc
  LvrCarrier-transp* lvrc (step-s s* s) = Carrier-transp LvrProp ImplPreservesLvr s (LvrCarrier-transp* lvrc s*)

  fSE⇒rnd≤lvr : ∀ {v' pk e'}
              → {final : SystemState e'}
              → Meta-Honest-PK pk
              → ∀ {d d'}{pre : SystemState d}{post : SystemState d'}{theStep : Step pre post}
              → firstSendEstablishes v' pk post theStep
              → Step* post final
              → LvrCarrier pk (signature v' unit) final
  fSE⇒rnd≤lvr _ {theStep = step-epoch _} ()
  fSE⇒rnd≤lvr hpk {theStep = step-peer (step-honest _)} (_ , _ , lvrc) step* = LvrCarrier-transp* lvrc step*

  vo₁ : VO.ImplObligation₁
  -- Initialization doesn't send any messages at all so far.  In future it may send messages, but
  -- probably not containing Votes?
  vo₁ r (step-init _) _ _ m∈outs = ⊥-elim (¬Any[] m∈outs)
  vo₁ {e} {pid} {pk = pk} {pre = pre} r (step-msg m∈pool ps≡)
      {v' = v'} hpk v⊂m m∈outs sig ¬sentb4 vpb v'⊂m' m'∈pool sig' refl rnds≡
     with newVoteSameEpochGreaterRound {e} {pre} {pid = pid} r
                                       (step-msg m∈pool ps≡) v⊂m m∈outs sig ¬sentb4
  ...| eIds≡' , suclvr≡v'rnd , _
     -- Use unwind to find the step that first sent the signature for v', then Any-Step-elim to
     -- prove that going from the poststate of that step to pre results in a state in which the
     -- round of v' is at most the last voted round recorded in the peerState of the peer that
     -- sent v'
     with Any-Step-elim {Q = LvrCarrier pk (₋vSignature v') pre}
                        (fSE⇒rnd≤lvr {v'} hpk)
                        (Any-Step-⇒ (λ _ ivnp → isValidNewPart⇒fSE {v' = v'} hpk ivnp)
                                    (unwind r hpk v'⊂m' m'∈pool sig'))
  ...| mkCarrier r' mws vpf' preprop
     -- The fake/trivial handler always sends a vote for its current epoch, but for a
     -- round greater than its last voted round
     with sameHonestSig⇒sameVoteData hpk (msgSigned mws) sig' (msgSameSig mws)
  ...| inj₁ hb = ⊥-elim (PerState.meta-sha256-cr pre r hb)
  ...| inj₂ refl
     -- Both votes have the same epochID, therefore same EpochConfig
     with sameEpoch⇒sameEC vpb vpf' refl
                    -- Both peers are allowed to sign for the same PK, so they are the same peer
  ...| refl rewrite NodeId-PK-OK-injective (vp-ec vpb) (vp-sender-ok vpb) (vp-sender-ok vpf')
     with noEpochChangeYet r' refl (step-msg m∈pool ps≡)
  ...| stepDNMepoch
     with preprop
  ...| inj₁ diffEpoch = ⊥-elim (diffEpoch eIds≡')
  ...| inj₂ (sameEpoch , v'rnd≤lvr)
                    -- So we have proved both that the round of v' is ≤ the lastVotedRound of
                    -- the peer's state and that the round of v' is one greater than that value,
                    -- which leads to a contradiction
                    = ⊥-elim (1+n≰n (≤-trans (≤-reflexive suclvr≡v'rnd)
                                             (≤-trans (≤-reflexive rnds≡) v'rnd≤lvr)))

  -- TODO-1: This proof should be refactored to reduce redundant reasoning about the two votes.  The
  -- newVoteSameEpochGreaterRound property uses similar reasoning.
  vo₂ : VO.ImplObligation₂
  vo₂ _ (step-init _) _ _ m∈outs _ _ _ _ _ _ _ _ = ⊥-elim (¬Any[] m∈outs)
  vo₂ {pid = pid} {pre = pre} r (step-msg {_ , nm} _ pinit) {m = m} {m' = m'}
      hpk v⊂m m∈outs sig vnew vpk v'⊂m' m'∈outs sig' v'new vpk' es≡ rnds≡
    with nm
  ...| P msg
    with msgsToSendWereSent {pid} {0} {P msg} {m} {peerStates pre pid} m∈outs
  ...| vm , refl , vmSent
    with msgsToSendWereSent1 {pid} {0} {msg} {vm} {peerStates pre pid} vmSent
  ...| _ , v∈outs
    with v⊂m
       -- Rebuilding keeps the same signature, and the SyncInfo included with the
       -- VoteMsg sent comprises QCs from the peer's state.  Votes represented in
       -- those QCS have signatures that have been sent before, contradicting the
       -- assumption that v's signature has not been sent before.
  ...| vote∈qc {vs = vs} {qc} vs∈qc v≈rbld (inV qc∈m)
                  rewrite cong ₋vSignature v≈rbld
                        | procPMCerts≡ {0} {msg} {peerStates pre pid} {vm} v∈outs
                        | SendVote-inj-v (Any-singleton⁻ v∈outs)
     = ⊥-elim (vnew (qcVotesSentB4 r pinit refl qc∈m refl vs∈qc))
  ...| vote∈vm {si}
     with m'
  ...| P _ = ⊥-elim (P≢V (Any-singleton⁻ m'∈outs))
  ...| C _ = ⊥-elim (C≢V (Any-singleton⁻ m'∈outs))
  ...| V vm'
       -- Because the handler sends only one message, the two VoteMsgs vm and vm' are the same
     rewrite V-inj (trans (Any-singleton⁻ m'∈outs) (sym (Any-singleton⁻ m∈outs)))
     with v'⊂m'
       -- Both votes are the vote in the (single) VoteMsg, so their biIds must be the same
  ...| vote∈vm = refl
       -- Here we use the same reasoning as above to show that v' is not new
  ...| vote∈qc vs∈qc v≈rbld (inV qc∈m)
                  rewrite cong ₋vSignature v≈rbld
                        | procPMCerts≡ {0} {msg} {peerStates pre pid} {vm} v∈outs
     = ⊥-elim (v'new (qcVotesSentB4 r pinit refl qc∈m refl vs∈qc))


------------------------------------------------------------------------
-- Parsers containing non-terminals, and grammars using such parsers
------------------------------------------------------------------------

module StructurallyRecursiveDescentParsing.Grammar where

open import Data.Bool
open import Data.Empty
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Codata.Musical.Notation
open import Level

open import StructurallyRecursiveDescentParsing.Index
import StructurallyRecursiveDescentParsing.Simplified as Simplified
open Simplified hiding (Parser; module Parser; ⟦_⟧)

infixl 10 _!>>=_ _?>>=_
infixl  5 _∣_

-- The parsers are parameterised on a type of nonterminals.

data Parser (NT : NonTerminalType) (Tok : Set) : NonTerminalType where
  return : ∀ {R} (x : R) → Parser NT Tok (true ◇ ε) R

  fail   : ∀ {R} → Parser NT Tok (false ◇ ε) R

  token  : Parser NT Tok (false ◇ ε) Tok

  _∣_    : ∀ {e₁ e₂ c₁ c₂ R}
           (p₁ : Parser NT Tok (e₁      ◇ c₁     ) R)
           (p₂ : Parser NT Tok (     e₂ ◇      c₂) R) →
                 Parser NT Tok (e₁ ∨ e₂ ◇ c₁ ∪ c₂) R

  _?>>=_ : ∀ {e₂ c₁ c₂ R₁ R₂}
           (p₁ :      Parser NT Tok (true ◇ c₁     ) R₁)
           (p₂ : R₁ → Parser NT Tok (e₂   ◇      c₂) R₂) →
                      Parser NT Tok (e₂   ◇ c₁ ∪ c₂) R₂

  _!>>=_ : ∀ {c₁ R₁ R₂} {i₂ : R₁ → Index}
           (p₁ :               Parser NT Tok (false ◇ c₁) R₁)
           (p₂ : (x : R₁) → ∞ (Parser NT Tok (i₂ x)       R₂)) →
                               Parser NT Tok (false ◇ c₁) R₂

  !      : ∀ {e c R} (nt : NT (e ◇ c) R) → Parser NT Tok (e ◇ c ∪ ε) R

-- Grammars.

Grammar : NonTerminalType → Set → Set1
Grammar NT Tok = ∀ {i R} → NT i R → Parser NT Tok i R

-- An empty non-terminal type.

EmptyNT : NonTerminalType
EmptyNT _ _ = Lift _ ⊥

-- An empty grammar.

emptyGrammar : ∀ {Tok} → Grammar EmptyNT Tok
emptyGrammar (lift ())

-- The semantics of grammar-based parsers is defined in terms of their
-- translation into "plain" parsers. The translation instantiates all
-- non-terminals corecursively.

⟦_⟧ : ∀ {Tok NT e c R} →
      Parser NT Tok (e ◇ c) R → Grammar NT Tok →
      Simplified.Parser Tok e R
⟦ return x   ⟧ g = return x
⟦ fail       ⟧ g = fail
⟦ token      ⟧ g = token
⟦ p₁ ∣ p₂    ⟧ g = ⟦ p₁ ⟧ g ∣ ⟦ p₂ ⟧ g
⟦ p₁ ?>>= p₂ ⟧ g = ⟦ p₁ ⟧ g ?>>= λ x →   ⟦    p₂ x  ⟧ g
⟦ p₁ !>>= p₂ ⟧ g = ⟦ p₁ ⟧ g !>>= λ x → ♯ ⟦ ♭ (p₂ x) ⟧ g
⟦ ! nt       ⟧ g = ⟦ g nt ⟧ g

-- Note that some "plain" parsers cannot be directly rewritten using
-- the parser type in this module (although there may be /equivalent/
-- parsers):

private

  only-plain : Simplified.Parser Bool false Bool
  only-plain = return true ?>>= λ x →
               if x then token else token ∣ token

  -- The following code does not type-check.

  -- doesnt-work : Parser EmptyNT Bool (false ◇ _) Bool
  -- doesnt-work = return true ?>>= λ x →
  --               if x then token else token ∣ token

-- A map function which can be useful when combining grammars.

mapNT : ∀ {NT₁ NT₂ Tok i R} →
        (∀ {i R} → NT₁ i R → NT₂ i R) →
        Parser NT₁ Tok i R → Parser NT₂ Tok i R
mapNT f (return x)   = return x
mapNT f fail         = fail
mapNT f token        = token
mapNT f (p₁ ∣ p₂)    = mapNT f p₁ ∣ mapNT f p₂
mapNT f (p₁ ?>>= p₂) = mapNT f p₁ ?>>= λ x →   mapNT f    (p₂ x)
mapNT f (p₁ !>>= p₂) = mapNT f p₁ !>>= λ x → ♯ mapNT f (♭ (p₂ x))
mapNT f (! nt)       = ! (f nt)


module _ where

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

infix 0 case_of_
case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = f x

blockOnFresh : TC ⊤
blockOnFresh =
  checkType unknown unknown >>= λ
  { (meta m _) → blockOnMeta m
  ; _ → typeError (strErr "impossible" ∷ []) }

macro
  shouldNotCrash : Tactic
  shouldNotCrash hole = blockOnFresh

-- Should leave some yellow and a constraint 'unquote shouldNotCrash : Nat'
n : Nat
n = shouldNotCrash


module Everything where

import Generics.Prelude
import Generics.Telescope
import Generics.Telescope.Equality
import Generics.Desc
import Generics.All
import Generics.HasDesc
import Generics.Accessibility
import Generics.Helpers
import Generics.Reflection

import Generics.Mu
import Generics.Mu.All
import Generics.Mu.Elim
import Generics.Mu.Fold
import Generics.Mu.Conversion

import Generics.Constructions.Case
import Generics.Constructions.Cong
import Generics.Constructions.DecEq
import Generics.Constructions.Elim
import Generics.Constructions.Fold
import Generics.Constructions.Mu
import Generics.Constructions.Recursion
import Generics.Constructions.Show

import Generics

-- Work In Progress
---------------------------------

-- import Generics.Mu.NoConfusion
-- import Generics.Constructions.Injective


module GUIgeneric.GUIFeaturesPart3 where

open import GUIgeneric.Prelude renaming (addButton to addButton')

open import GUIgeneric.GUIDefinitions renaming (add to add'; add' to add)
open import GUIgeneric.GUI
open import GUIgeneric.GUIExampleLib
open import StateSizedIO.GUI.WxGraphicsLibLevel3 renaming (addButton to addButton')
open import GUIgeneric.GUIFeatures
open import GUIgeneric.GUIFeaturesPart2 hiding ( main )
open import GUIgeneric.GUIExample hiding (main )

open import Data.Product
open import Data.Fin

liftResultˢ : (S S' : Set) (s2GUI : (s : S') → Frame)
             (ss' : S → S')
             (s : S)
             (m : methodsG (s2GUI (ss' s)))
             (r : Resultˢ (handlerGUIInterfₛ S (s2GUI ∘ ss')) s m)
            → Resultˢ (handlerGUIInterfₛ S' s2GUI) (ss' s) m
liftResultˢ S S' s2GUI ss' s m noChange = noChange
liftResultˢ S S' s2GUI ss' s m (changedState snew) = changedState (ss' snew)

extendHandlerGuiInterfₛ :  (i : Size)
                           (S S' : Set) (s2GUI : (s : S') → Frame)
                           (ss' : S → S')
                           (s : S)
                           (obj : handlerGUIObjectₛ i S (s2GUI ∘ ss') s)
                           → handlerGUIObjectₛ i S' s2GUI (ss' s)
method (extendHandlerGuiInterfₛ i S S' s2GUI ss' s obj) m =
                    x >>= (λ r → return (liftResultˢ S S' s2GUI ss' s m r))
              where
                      x : IO GuiLev1Interface ∞  (Resultˢ (handlerGUIInterfₛ S (s2GUI ∘ ss')) s m)
                      x = method obj m

lift⊎3  : {A B C : Set} → A ⊎ B → A ⊎ B ⊎ C
lift⊎3 (inj₁ x) = inj₁ x
lift⊎3 (inj₂ y) = inj₂ (inj₁ y)

mapReturnTypeₛ : {A B : Set}(f : A → B) (a : ReturnTypeₛ A) → ReturnTypeₛ  B
mapReturnTypeₛ f noChange = noChange
mapReturnTypeₛ f (changedState snew) = changedState (f snew)

mapStateMachineHandl : {S S' : Set}(f : S → S')
                       (p : IO GuiLev1Interface ∞ (ReturnTypeₛ S))
                       → IO GuiLev1Interface ∞ (ReturnTypeₛ S')
mapStateMachineHandl f p = mapIO (mapReturnTypeₛ f) p

mapSMachineState : {S S' : Set}(f : S → S')(s : S)(sm : SMachineState S s)
                    → SMachineState S' (f s)
mapSMachineState f s sm .fSM = sm .fSM
mapSMachineState f s sm .propSM = sm .propSM
mapSMachineState f s sm .handlSM m = mapStateMachineHandl f (sm .handlSM m)

mapFMachineHandle : {A B C : Set}
                          (a : A ⊎ B)(sm : SMachineState (A ⊎ B) a)
                          → SMachineState (A ⊎ B ⊎ C) (lift⊎3 a)
mapFMachineHandle a sm = mapSMachineState lift⊎3 a sm

mapIOFeatureM : {A B C : Set}
            → IO GuiLev1Interface ∞ (ReturnTypeₛ (A ⊎ B))
            → IO GuiLev1Interface ∞ (ReturnTypeₛ (A ⊎ B ⊎ C))
mapIOFeatureM p = mapIO (mapReturnTypeₛ lift⊎3) p

Cancel : FMachine StateV → FMachine StateV
Cancel vm .Features = vm .Features × FeatureCancel
Cancel vm .AddStateF  = vm .AddStateF ⊎ ⊤
Cancel vm .GUIF (f , yesCancel) (inj₁ s1) =
      addBtn2StateMachine (mapFMachineHandle (inj₁ s1) (vm .GUIF f (inj₁ s1)))
                          "Cancel" ((inj₂ (inj₂ _)))
Cancel vm .GUIF (f , _) (inj₁ s) = mapFMachineHandle (inj₁ s) (vm .GUIF f (inj₁ s))
Cancel vm .GUIF (f , _) (inj₂ (inj₁ x)) = mapFMachineHandle (inj₂ x) (vm .GUIF f (inj₂ x))
Cancel vm .GUIF (f , _) (inj₂ (inj₂ _)) = simpleSMState "Intermediate" (inj₁ s0)

Tea : FMachine StateV → FMachine StateV
Tea vm .Features = vm .Features × FeatureTea
Tea vm .AddStateF  = vm .AddStateF ⊎ ⊤
Tea vm .GUIF (f , yeTea) (inj₁ s2) =
      addBtn2StateMachine (mapFMachineHandle (inj₁ s2) (vm .GUIF f (inj₁ s2)))
                          "Tea" ((inj₂ (inj₂ _)))
Tea vm .GUIF (f , _) (inj₁ s) = mapFMachineHandle (inj₁ s) (vm .GUIF f (inj₁ s))
Tea vm .GUIF (f , _) (inj₂ (inj₁ x)) = mapFMachineHandle (inj₂ x) (vm .GUIF f (inj₂ x))
Tea vm .GUIF (f , _) (inj₂ (inj₂ _)) = simpleSMState "Get Your Tea" (inj₁ s0)

cancelBase : FMachine StateV
cancelBase = Cancel baseF

teaCancelBase : FMachine StateV
teaCancelBase = Tea cancelBase

main : NativeIO Unit
main = compileFeatureVM teaCancelBase ((_ , yesCancel) , yesTea) (inj₁ s0) --


-- Compiled things must be a postulate

module CompiledMustBePostulate where

postulate
  A : Set

foo : Set
foo = A

{-# COMPILED foo bar #-}


module calculus where

open import utility

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
  using (Canθₛ ; Canθₛₕ ; [S]-env)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; sig ; []env ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Variable.Signal as Signal
  using (Signal)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)
open import Esterel.Context.Properties

open import Relation.Nullary
  using (¬_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl)
open import Data.Empty
  using (⊥ ; ⊥-elim)
import Data.FiniteMap
open import Data.List
  using (List ; _∷_ ; [] ; _++_)
open import Data.List.All as All
  using (All ; _∷_ ; [])
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; proj₁ ; proj₂ ; _×_ ; _,′_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Relation.Binary.PropositionalEquality

open import sn-calculus

open _≐_⟦_⟧e
open _≐_⟦_⟧c

open EvaluationContext1
open Context1

infix 4 _⟶₁_
infix 4 _⟶_
infix 4 _⟶*_

data _⟶₁_ : Term → Term → Set where
  [par-swap] : ∀{p q} →
    (p ∥ q) ⟶₁ (q ∥ p)

  [par-nothing] : ∀ {q} ->
    done q ->
    (nothin ∥ q) ⟶₁ q

  [par-1exit] : ∀ {q} -> ∀ n ->
    (pausedq : paused q) ->
    (exit n ∥ q) ⟶₁ exit n

  [par-2exit] : ∀ n m ->
    (exit n ∥ exit m) ⟶₁ exit (n ⊔ℕ m)

  [is-present] : ∀{θ r p q E A} → ∀ S ->
    (S∈ : (Env.isSig∈ S θ)) →
    (θ[S]≡present : Env.sig-stats{S} θ S∈ ≡ Signal.present) →
    (de : r ≐ E ⟦ present S ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ p ⟧e)

  [is-absent] : ∀{θ r p q E A} → ∀ S ->
    (S∈ : (Env.isSig∈ S θ)) →
    (θ[S]≡absent : Env.sig-stats{S} θ S∈ ≡ Signal.absent) →
    (de : r ≐ E ⟦ present S ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ q ⟧e)

  [emit] : ∀{θ r S E} →
    (S∈ : (Env.isSig∈ S θ)) →
    (¬S≡a : ¬ (Env.sig-stats{S} θ S∈) ≡ Signal.absent) →
    (de : r ≐ E ⟦ emit S ⟧e) →
    (ρ⟨ θ , GO ⟩· r) ⟶₁
    (ρ⟨ (Env.set-sig{S} θ S∈ Signal.present) , GO ⟩·
      E ⟦ nothin ⟧e)

  [loop-unroll] : ∀{p} →
    (loop p)
    ⟶₁
    (loopˢ p p)

  [seq-done] : ∀{q} →
    (nothin >> q) ⟶₁ q

  [seq-exit] : ∀{q n} →
    (exit n >> q) ⟶₁ (exit n)

  [loopˢ-exit] : ∀{q n} →
    (loopˢ (exit n) q) ⟶₁ (exit n)

  [suspend-done] : ∀{p S} →
    (haltedp : halted p) →
    (suspend p S) ⟶₁ p

  -- traps
  [trap-done] : ∀{p} →
    (haltedp : halted p) →
    (trap p) ⟶₁ (↓ haltedp)

  -- lifting signals
  [raise-signal] : ∀{p S} →
    (signl S p) ⟶₁
    (ρ⟨ (Θ SigMap.[ S ↦ Signal.unknown ] ShrMap.empty VarMap.empty) , WAIT ⟩·
      p)

  -- shared state
  [raise-shared] : ∀{θ r s e p E A} →
    (all-readyeθ : all-ready e θ) →
    (de : r ≐ E ⟦ shared s ≔ e in: p ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁
    (ρ⟨ θ , A ⟩· E ⟦ (ρ⟨ [s,δe]-env s (δ all-readyeθ) , WAIT ⟩· p) ⟧e)

  [set-shared-value-old] : ∀{θ r s e E} →
    (e' : all-ready e θ) →
    (s∈ : (Env.isShr∈ s θ)) →
    (θ[s]≡old : Env.shr-stats{s} θ s∈ ≡ SharedVar.old) →
    (de : r ≐ E ⟦ s ⇐ e ⟧e) →
    (ρ⟨ θ , GO ⟩· r) ⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.new) (δ e')) , GO ⟩·
      E ⟦ nothin ⟧e)

  [set-shared-value-new] : ∀{θ r s e E} →
    (e' : all-ready e θ) →
    (s∈ : (Env.isShr∈ s θ)) →
    (θ[s]≡n : Env.shr-stats{s} θ s∈ ≡ SharedVar.new) →
    (de : r ≐ E ⟦ s ⇐ e ⟧e) →
    (ρ⟨ θ , GO ⟩· r) ⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.new) (Env.shr-vals{s} θ s∈ + δ e')) , GO ⟩·
      E ⟦ nothin ⟧e)

  -- unshared state
  [raise-var] : ∀{θ r x p e E A} →
    (all-readyeθ : all-ready e θ) →
    (de : r ≐ E ⟦ var x ≔ e in: p ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁
    (ρ⟨ θ , A ⟩·
      E ⟦ (ρ⟨ [x,δe]-env x (δ all-readyeθ) , WAIT ⟩· p) ⟧e)

  [set-var] : ∀{θ r x e E A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (all-readyeθ : all-ready e θ) →
    (de : r ≐ E ⟦ x ≔ e ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁
    (ρ⟨ (Env.set-var{x} θ x∈ (δ all-readyeθ)) , A ⟩·
      E ⟦ nothin ⟧e)

  -- if
  [if-false] : ∀{θ r p q x E A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (θ[x]≡z : Env.var-vals{x} θ x∈ ≡ zero) →
    (de : r ≐ E ⟦ if x ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ q ⟧e)

  [if-true] : ∀{θ r p q x E n A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (θ[x]≡s : Env.var-vals{x} θ x∈ ≡ suc n) →
    (de : r ≐ E ⟦ if x ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ p ⟧e)

  -- progression
  [absence] : ∀{θ p A} -> ∀ S →
    (S∈ : (Env.isSig∈ S θ)) →
    (θ[S]≡unknown : Env.sig-stats{S} θ S∈ ≡ Signal.unknown) →
    (S∉Canθₛ : (Signal.unwrap S) ∉ Canθₛ (sig θ) 0 p []env) →
    (ρ⟨ θ , A ⟩· p) ⟶₁
    (ρ⟨ (Env.set-sig{S} θ S∈ (Signal.absent)) , A ⟩·
      p)

  [readyness] : ∀{θ p A} -> ∀ s →
    (s∈ : (Env.isShr∈ s θ)) →
    (θ[s]≡old⊎θ[s]≡new : (Env.shr-stats{s} θ s∈ ≡ SharedVar.old) ⊎
                         (Env.shr-stats{s} θ s∈ ≡ SharedVar.new)) →
    (s∉Canθₛₕ : (SharedVar.unwrap s) ∉ Canθₛₕ (sig θ) 0 p []env) →
    (ρ⟨ θ , A ⟩· p) ⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.ready) (Env.shr-vals{s} θ s∈)) , A ⟩·
      p)

  [merge] : ∀{θ₁ θ₂ r p E A₁ A₂} →
    (de : r ≐ E ⟦ ρ⟨ θ₂ , A₂ ⟩· p ⟧e) →
    (ρ⟨ θ₁ , A₁ ⟩· r) ⟶₁ (ρ⟨ (θ₁ ← θ₂) , (A-max A₁ A₂) ⟩· E ⟦ p ⟧e)

-- The compatible closure of _⟶₁_.
data _⟶_ : Term → Term → Set where
  [context] : ∀{r p p'} →
    (C : Context) →
    (dc : r ≐ C ⟦ p ⟧c) →
    (p⟶₁p' : p ⟶₁ p') →
    r ⟶ (C ⟦ p' ⟧c)

-- The reflexive transitive closure of ⟶
data _⟶*_ : Term → Term → Set where
  [refl] : ∀{p} → (p ⟶* p)
  [step] : ∀{p q r} → (p⟶q : p ⟶ q) → (q⟶*r : q ⟶* r) → (p ⟶* r)

data _≡ₑ_#_ : Term -> Term -> List Context1 -> Set where

  ≡ₑrefl : ∀ {p C} ->

    ------------
     p ≡ₑ p # C

  ≡ₑtran : ∀ {p r q C} ->

     (p≡ₑr#C : p ≡ₑ r # C) ->
     (r≡ₑq#C : r ≡ₑ q # C) ->
    -----------------------
      p ≡ₑ q # C

  ≡ₑsymm : ∀ {p q C BVq FVq} ->

     (CBq : CorrectBinding (C ⟦ q ⟧c) BVq FVq) ->
     (q≡ₑp : q ≡ₑ p # C) ->
    -------------------------------------------
      p ≡ₑ q # C

  ≡ₑctxt : ∀ {C C′ p q C′⟦p⟧ C′⟦q⟧ } ->

     (C′⟦p⟧≐C′⟦p⟧c : C′⟦p⟧ ≐ C′ ⟦ p ⟧c) ->
     (C′⟦q⟧≐C′⟦q⟧c : C′⟦q⟧ ≐ C′ ⟦ q ⟧c) ->
     (p≡ₑq : p ≡ₑ q # (C ++ C′)) ->
    -----------------------------------
     C′⟦p⟧ ≡ₑ C′⟦q⟧ # C

  ≡ₑstep : ∀ {C p q} ->

     (p⟶₁q : p ⟶₁ q) ->
    --------------------
     p ≡ₑ q # C


open import Data.String using ( String )
open import Data.List.Primitive using ( #List )
open import Data.Maybe.Primitive using ( #Maybe )
open import Web.URI.Port.Primitive using ( Port? )
open import Web.URI.Scheme.Primitive using ( Scheme? )

module Web.URI.Primitive where
{-# IMPORT Data.Maybe #-}
{-# IMPORT Web.URI.AgdaFFI #-}

data #URI : Set where
  #abs : Scheme? → String → Port? → (#List String) → (#Maybe String) → #URI
  #rel : (#List String) → (#Maybe String) → #URI
{-# COMPILED_DATA #URI Web.URI.AgdaFFI.URI Web.URI.AgdaFFI.Abs Web.URI.AgdaFFI.Rel #-}

postulate #toString : #URI → String
{-# COMPILED #toString Web.URI.AgdaFFI.toString #-}

postulate #fromString : String → (#Maybe #URI)
{-# COMPILED #fromString Web.URI.AgdaFFI.fromString #-}


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness --sized-types #-}

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.List using ([]; _∷_; _∷ʳ_; _++_)
open import Data.List.Properties using (∷-injective)

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_; _∉_; _⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; subst; subst₂; cong)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε; _◅_)

open import Function.Base using (case_of_)

open import Common

module Discriminator {ℙ : Set} (message : Message ℙ)
  where

open import Trace message
open import SessionType message
open import HasTrace message
open import TraceSet message
open import Transitions message
open import Subtyping message
open import Divergence message
open import Session message
open import Semantics message

make-diverge-backward :
  ∀{T S α}
  (tα : T HasTrace (α ∷ []))
  (sα : S HasTrace (α ∷ [])) ->
  T ↑ S ->
  after tα ↑ after sα ->
  DivergeBackward tα sα
make-diverge-backward tα sα divε divα none = divε
make-diverge-backward tα sα divε divα (some none) =
  subst₂ (λ u v -> after u ↑ after v) (sym (⊑-has-trace-after tα)) (sym (⊑-has-trace-after sα)) divα

has-trace-after-split :
  ∀{T φ ψ} ->
  (tφ : T HasTrace φ)
  (tφψ : T HasTrace (φ ++ ψ)) ->
  has-trace-after tφ (split-trace tφ tφψ) ≡ tφψ
has-trace-after-split (_ , tdef , refl) tφψ = refl
has-trace-after-split (_ , tdef , step inp tr) (_ , sdef , step inp sr)
  rewrite has-trace-after-split (_ , tdef , tr) (_ , sdef , sr) = refl
has-trace-after-split (T , tdef , step (out fx) tr) (S , sdef , step (out gx) sr)
  rewrite has-trace-after-split (_ , tdef , tr) (_ , sdef , sr) =
  cong (S ,_) (cong (sdef ,_) (cong (λ z -> step z sr) (cong out (Defined-eq (transitions+defined->defined sr sdef) gx))))

disc-set-has-outputs :
  ∀{T S φ x} ->
  T <: S ->
  φ ∈ DiscSet T S ->
  T HasTrace (φ ∷ʳ O x) ->
  S HasTrace φ ->
  φ ∷ʳ O x ∈ DiscSet T S
disc-set-has-outputs {_} {S} {φ} {x} sub (inc tφ sφ div←φ) tφx _ with S HasTrace? (φ ∷ʳ O x)
... | yes sφx =
  let tφ/x = split-trace tφ tφx in
  let sφ/x = split-trace sφ sφx in
  let divφ = subst₂ (λ u v -> after u ↑ after v) (⊑-has-trace-after tφ) (⊑-has-trace-after sφ) (div←φ (⊑-refl φ)) in
  let divx = _↑_.divergence divφ {[]} {x} none tφ/x sφ/x in
  let divφ←x = make-diverge-backward tφ/x sφ/x divφ divx in
  let div←φx = subst₂ DivergeBackward (has-trace-after-split tφ tφx) (has-trace-after-split sφ sφx) (append-diverge-backward tφ sφ tφ/x sφ/x div←φ divφ←x) in
  inc tφx sφx div←φx
... | no nsφx = exc refl tφ sφ tφx nsφx div←φ
disc-set-has-outputs sub (exc eq tψ sψ tφ nsφ div←ψ) tφx sφ = ⊥-elim (nsφ sφ)

defined-becomes-nil :
  ∀{T φ S} ->
  Defined T ->
  ¬ Defined S ->
  Transitions T φ S ->
  ∃[ ψ ] ∃[ x ] (φ ≡ ψ ∷ʳ I x × T HasTrace ψ × ¬ T HasTrace φ)
defined-becomes-nil def ndef refl = ⊥-elim (ndef def)
defined-becomes-nil def ndef (step (inp {_} {x}) refl) =
  [] , x , refl , (_ , inp , refl) , inp-has-no-trace λ { (_ , def , refl) → ⊥-elim (ndef def) }
defined-becomes-nil def ndef (step inp tr@(step t _)) with defined-becomes-nil (transition->defined t) ndef tr
... | ψ , x , eq , tψ , ntφ =
  I _ ∷ ψ , x , cong (I _ ∷_) eq , inp-has-trace tψ , inp-has-no-trace ntφ
defined-becomes-nil def ndef (step (out fx) tr) with defined-becomes-nil fx ndef tr
... | ψ , x , refl , tψ , ntφ =
  O _ ∷ ψ , x , refl , out-has-trace tψ , out-has-no-trace ntφ

sub+diverge->defined : ∀{T S} -> T <: S -> T ↑ S -> Defined T × Defined S
sub+diverge->defined nil<:any div with _↑_.with-trace div
... | _ , def , tr = ⊥-elim (contraposition (transitions+defined->defined tr) (λ ()) def)
sub+diverge->defined (end<:def (inp _) def) _ = inp , def
sub+diverge->defined (end<:def (out _) def) _ = out , def
sub+diverge->defined (inp<:inp _ _) _ = inp , inp
sub+diverge->defined (out<:out _ _ _) _ = out , out

sub+diverge->has-empty-trace : ∀{T S} -> T <: S -> T ↑ S -> DiscSet T S []
sub+diverge->has-empty-trace nil<:any div with _↑_.with-trace div
... | tφ = ⊥-elim (nil-has-no-trace tφ)
sub+diverge->has-empty-trace (end<:def e def) div with _↑_.with-trace div | _↑_.without-trace div
... | tφ | nsφ rewrite end-has-empty-trace e tφ = ⊥-elim (nsφ (defined->has-empty-trace def))
sub+diverge->has-empty-trace (inp<:inp _ _) div = inc (_ , inp , refl) (_ , inp , refl) λ { none → div }
sub+diverge->has-empty-trace (out<:out _ _ _) div = inc (_ , out , refl) (_ , out , refl) λ { none → div }

discriminator : SessionType -> SessionType -> SessionType
discriminator T S = decode (co-semantics (disc-set->semantics T S)) .force

discriminator-disc-set-sub : (T S : SessionType) -> CoSet ⟦ discriminator T S ⟧ ⊆ DiscSet T S
discriminator-disc-set-sub T S rφ =
  co-inversion {DiscSet T S} (decode-sub (co-semantics (disc-set->semantics T S)) rφ)

discriminator-disc-set-sup : (T S : SessionType) -> DiscSet T S ⊆ CoSet ⟦ discriminator T S ⟧
discriminator-disc-set-sup T S dφ =
  decode-sup (co-semantics (disc-set->semantics T S)) (co-definition {DiscSet T S} dφ)

sub+diverge->discriminator-defined : ∀{T S} -> T <: S -> T ↑ S -> Defined (discriminator T S)
sub+diverge->discriminator-defined {T} {S} sub div =
  has-trace->defined (co-set-right->left {DiscSet T S} {⟦ discriminator T S ⟧} (discriminator-disc-set-sup T S) (co-definition {DiscSet T S} {[]} (sub+diverge->has-empty-trace sub div)))

input-does-not-win :
  ∀{T S φ x} (tφ : T HasTrace φ) -> Transitions T (φ ∷ʳ I x) S -> ¬ Win (after tφ)
input-does-not-win (_ , _ , refl) (step inp _) ()
input-does-not-win (_ , def , step inp tr) (step inp sr) w = input-does-not-win (_ , def , tr) sr w
input-does-not-win (_ , def , step (out _) tr) (step (out _) sr) w = input-does-not-win (_ , def , tr) sr w

ends-with-output->has-trace : ∀{T S φ x} -> Transitions T (φ ∷ʳ O x) S -> T HasTrace (φ ∷ʳ O x)
ends-with-output->has-trace tr = _ , output-transitions->defined tr , tr

co-trace-swap : ∀{φ ψ} -> co-trace φ ≡ ψ -> φ ≡ co-trace ψ
co-trace-swap {φ} eq rewrite sym eq rewrite co-trace-involution φ = refl

co-trace-swap-⊑ : ∀{φ ψ} -> co-trace φ ⊑ ψ -> φ ⊑ co-trace ψ
co-trace-swap-⊑ {[]} none = none
co-trace-swap-⊑ {α ∷ _} (some le) rewrite co-action-involution α = some (co-trace-swap-⊑ le)

co-maximal : ∀{X φ} -> φ ∈ Maximal X -> co-trace φ ∈ Maximal (CoSet X)
co-maximal {X} (maximal xφ F) =
  maximal (co-definition {X} xφ) λ le xψ -> let le' = co-trace-swap-⊑ le in
                                             let eq = F le' xψ in
                                             co-trace-swap eq

co-maximal-2 : ∀{X φ} -> co-trace φ ∈ Maximal (CoSet X) -> φ ∈ Maximal X
co-maximal-2 {X} (maximal wit F) =
  maximal (co-inversion {X} wit) λ le xψ -> let le' = ⊑-co-trace le in
                                             let eq = F le' (co-definition {X} xψ) in
                                             co-trace-injective eq

co-trace->co-set : ∀{X φ} -> co-trace φ ∈ Maximal X -> φ ∈ Maximal (CoSet X)
co-trace->co-set {_} {φ} cxφ with co-maximal cxφ
... | res rewrite co-trace-involution φ = res

discriminator-after-sync->defined :
  ∀{R T S T' φ} ->
  T <: S ->
  (rdef : Defined (discriminator T S))
  (rr : Transitions (discriminator T S) (co-trace φ) R)
  (tr : Transitions T φ T') ->
  Defined R
discriminator-after-sync->defined {R} {T} {S} sub rdef rr tr with Defined? R
... | yes rdef' = rdef'
... | no nrdef' with defined-becomes-nil rdef nrdef' rr
... | ψ , x , eq , rψ , nrφ rewrite eq with input-does-not-win rψ rr
... | nwin with contraposition (decode+maximal->win (co-semantics (disc-set->semantics T S)) rψ) nwin
... | ncψ with decode-sub (co-semantics (disc-set->semantics T S)) rψ
... | dsψ with contraposition (disc-set-maximal-1 dsψ) (contraposition co-trace->co-set ncψ)
... | nnsψ with has-trace-double-negation nnsψ
... | sψ with (let tr' = subst (λ z -> Transitions _ z _) (co-trace-swap eq) tr in
              let tr'' = subst (λ z -> Transitions _ z _) (co-trace-++ ψ (I x ∷ [])) tr' in
              ends-with-output->has-trace tr'')
... | tψ with disc-set-has-outputs sub dsψ tψ sψ
... | dsφ with decode-sup (co-semantics (disc-set->semantics T S)) (co-definition {DiscSet T S} dsφ)
... | rφ = let rφ' = subst (_ HasTrace_) (co-trace-++ (co-trace ψ) (O x ∷ [])) rφ in
           let rφ'' = subst (λ z -> _ HasTrace (z ++ _)) (co-trace-involution ψ) rφ' in
           ⊥-elim (nrφ rφ'')

after-trace-defined : ∀{T T' φ} -> T HasTrace φ -> Transitions T φ T' -> Defined T'
after-trace-defined (_ , def , refl) refl = def
after-trace-defined (_ , def , step inp tr) (step inp sr) = after-trace-defined (_ , def , tr) sr
after-trace-defined (_ , def , step (out _) tr) (step (out _) sr) = after-trace-defined (_ , def , tr) sr

after-trace-defined-2 : ∀{T φ} (tφ : T HasTrace φ) -> Defined (after tφ)
after-trace-defined-2 (_ , def , _) = def

⊑-after : ∀{φ ψ} -> φ ⊑ ψ -> Trace
⊑-after {_} {ψ} none = ψ
⊑-after (some le) = ⊑-after le

⊑-after-co-trace : ∀{φ ψ} (le : φ ⊑ ψ) -> ⊑-after (⊑-co-trace le) ≡ co-trace (⊑-after le)
⊑-after-co-trace none = refl
⊑-after-co-trace (some le) = ⊑-after-co-trace le

extend-transitions :
  ∀{T S φ ψ}
  (le : φ ⊑ ψ)
  (tr : Transitions T φ S)
  (tψ : T HasTrace ψ) ->
  Transitions S (⊑-after le) (after tψ)
extend-transitions none refl (_ , _ , sr) = sr
extend-transitions (some le) (step inp tr) (_ , sdef , step inp sr) = extend-transitions le tr (_ , sdef , sr)
extend-transitions (some le) (step (out _) tr) (_ , sdef , step (out _) sr) = extend-transitions le tr (_ , sdef , sr)

discriminator-compliant : ∀{T S} -> T <: S -> T ↑ S -> FairComplianceS (discriminator T S # T)
discriminator-compliant {T} {S} sub div {R' # T'} reds with unzip-red* reds
... | φ , rr , tr with sub+diverge->discriminator-defined sub div | sub+diverge->defined sub div
... | rdef | tdef , sdef with discriminator-after-sync->defined sub rdef rr tr
... | rdef' with decode-sub (co-semantics (disc-set->semantics T S)) (_ , rdef' , rr)
... | dsφ rewrite co-trace-involution φ =
  case completion sub dsφ of
  λ { (inj₁ (ψ , lt , cψ@(maximal dsψ _))) ->
      let rψ = decode-sup (co-semantics (disc-set->semantics T S)) (co-definition {DiscSet T S} dsψ) in
      let tψ = disc-set-subset dsψ in
      let rr' = subst (λ z -> Transitions _ z _) (⊑-after-co-trace (⊏->⊑ lt)) (extend-transitions (⊑-co-trace (⊏->⊑ lt)) rr rψ) in
      let tr' = extend-transitions (⊏->⊑ lt) tr tψ in
      let winr = decode+maximal->win (co-semantics (disc-set->semantics T S)) rψ (co-maximal cψ) in
      let reds' = zip-red* rr' tr' in
      _ , reds' , win#def winr (after-trace-defined-2 tψ)
    ; (inj₂ (cφ , nsφ)) ->
      let winr = decode+maximal->win (co-semantics (disc-set->semantics T S)) (_ , rdef' , rr) (co-maximal cφ) in
      _ , ε , win#def winr (after-trace-defined (disc-set-subset dsφ) tr) }

discriminator-not-compliant : ∀{T S} -> T <: S -> T ↑ S -> ¬ FairComplianceS (discriminator T S # S)
discriminator-not-compliant {T} {S} sub div comp with comp ε
... | _ , reds , win#def w def with unzip-red* reds
... | φ , rr , sr with decode+win->maximal (co-semantics (disc-set->semantics T S)) (_ , win->defined w , rr) w
... | cφ with co-maximal-2 {DiscSet T S} cφ
... | csφ with disc-set-maximal-2 sub csφ
... | nsφ = nsφ (_ , def , sr)


{-# OPTIONS --safe #-}

module Definition.Conversion.Soundness where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Whnf
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.NeTypeEq

open import Tools.Product
import Tools.PropositionalEquality as PE

mutual
  -- Algorithmic equality of neutrals is well-formed.
  soundness~↑! : ∀ {k l A lA Γ} → Γ ⊢ k ~ l ↑! A ^ lA → Γ ⊢ k ≡ l ∷ A ^ [ ! , lA ]
  soundness~↑! (var-refl x x≡y) = PE.subst (λ y → _ ⊢ _ ≡ var y ∷ _ ^ _) x≡y (refl x)
  soundness~↑! (app-cong {rF = !} k~l x₁) = app-cong (soundness~↓! k~l) (soundnessConv↑Term x₁)
  soundness~↑! (app-cong {rF = %} k~l x₁) = app-cong (soundness~↓! k~l) (let _ , _ , y = soundness~↑% x₁ in y)
  soundness~↑! (natrec-cong x₁ x₂ x₃ k~l) =
    natrec-cong (soundnessConv↑ x₁) (soundnessConv↑Term x₂)
                (soundnessConv↑Term x₃) (soundness~↓! k~l)
  soundness~↑! (Emptyrec-cong x₁ k~l) = let ⊢k , ⊢l , _ = soundness~↑% k~l in
    Emptyrec-cong (soundnessConv↑ x₁) ⊢k ⊢l
  soundness~↑! (Id-cong X x x₁) = Id-cong (soundness~↓! X) (soundnessConv↑Term x) (soundnessConv↑Term x₁)
  soundness~↑! (Id-ℕ X x) = Id-cong (refl (ℕⱼ (wfEqTerm (soundness~↓! X)))) (soundness~↓! X) (soundnessConv↑Term x)
  soundness~↑! (Id-ℕ0 X) = let XX = soundness~↓! X in Id-cong (refl (ℕⱼ (wfEqTerm XX))) (refl (zeroⱼ (wfEqTerm XX))) XX
  soundness~↑! (Id-ℕS x X) = let XX = soundness~↓! X in Id-cong (refl (ℕⱼ (wfEqTerm XX))) (suc-cong (soundnessConv↑Term x)) XX
  soundness~↑! (Id-U X x) = Id-cong (refl (univ 0<1 (wfEqTerm (soundness~↓! X)))) (soundness~↓! X) (soundnessConv↑Term x)
  soundness~↑! (Id-Uℕ X) = let XX = soundness~↓! X in Id-cong (refl (univ 0<1 (wfEqTerm XX))) (refl (ℕⱼ (wfEqTerm XX))) XX
  soundness~↑! (Id-UΠ x X) = let XX = soundness~↓! X
                                 xx = soundnessConv↑Term x
                             in Id-cong (refl (univ 0<1 (wfEqTerm XX))) xx XX
  soundness~↑! (cast-cong X x x₁ x₂ x₃) = cast-cong (soundness~↓! X) (soundnessConv↑Term x) (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-ℕ X x x₁ x₂) = let XX = soundness~↓! X in cast-cong (refl (ℕⱼ (wfEqTerm XX))) XX (soundnessConv↑Term x) x₁ x₂
  soundness~↑! (cast-ℕℕ X x x₁) = let XX = soundness~↓! X in cast-cong (refl (ℕⱼ (wfEqTerm XX))) (refl (ℕⱼ (wfEqTerm XX))) XX x x₁
  soundness~↑! (cast-Π x X x₁ x₂ x₃) = cast-cong (soundnessConv↑Term x) (soundness~↓! X) (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-Πℕ x x₁ x₂ x₃) = let XX = (soundnessConv↑Term x) in cast-cong XX (refl (ℕⱼ (wfEqTerm XX))) (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-ℕΠ x x₁ x₂ x₃) = let XX = (soundnessConv↑Term x) in cast-cong (refl (ℕⱼ (wfEqTerm XX))) XX (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-ΠΠ%! x x₁ x₂ x₃ x₄) = cast-cong (soundnessConv↑Term x) (soundnessConv↑Term x₁) (soundnessConv↑Term x₂) x₃ x₄
  soundness~↑! (cast-ΠΠ!% x x₁ x₂ x₃ x₄) = cast-cong (soundnessConv↑Term x) (soundnessConv↑Term x₁) (soundnessConv↑Term x₂) x₃ x₄

  soundness~↑% : ∀ {k l A lA Γ} → Γ ⊢ k ~ l ↑% A ^ lA  →  Γ ⊢ k ∷ A ^ [ % , lA ] × Γ ⊢ l ∷ A ^ [ % , lA ] × Γ ⊢ k ≡ l ∷ A ^ [ % , lA ]
  soundness~↑% (%~↑ ⊢k ⊢l) =  ⊢k , ⊢l , proof-irrelevance ⊢k ⊢l

  soundness~↑ : ∀ {k l A rA lA Γ} → Γ ⊢ k ~ l ↑ A ^ [ rA , lA ] → Γ ⊢ k ≡ l ∷ A ^ [ rA , lA ]
  soundness~↑ (~↑! x) = soundness~↑! x
  soundness~↑ (~↑% x) = let _ , _ , y = soundness~↑% x in y

  -- Algorithmic equality of neutrals in WHNF is well-formed.
  soundness~↓! : ∀ {k l A lA Γ} → Γ ⊢ k ~ l ↓! A ^ lA → Γ ⊢ k ≡ l ∷ A ^ [ ! , lA ]
  soundness~↓! ([~] A₁ D whnfA k~l) = conv (soundness~↑! k~l) (subset* D)

  -- Algorithmic equality of types is well-formed.
  soundnessConv↑ : ∀ {A B rA Γ} → Γ ⊢ A [conv↑] B ^ rA → Γ ⊢ A ≡ B ^ rA
  soundnessConv↑ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    trans (subset* D) (trans (soundnessConv↓ A′<>B′) (sym (subset* D′)))

  -- Algorithmic equality of types in WHNF is well-formed.
  soundnessConv↓ : ∀ {A B rA Γ} → Γ ⊢ A [conv↓] B ^ rA → Γ ⊢ A ≡ B ^ rA
  soundnessConv↓ (U-refl PE.refl ⊢Γ) = refl (Uⱼ ⊢Γ)
  soundnessConv↓ (univ x₂) = univ (soundnessConv↓Term x₂)

  -- Algorithmic equality of terms is well-formed.
  soundnessConv↑Term : ∀ {a b A lA Γ} → Γ ⊢ a [conv↑] b ∷ A ^ lA → Γ ⊢ a ≡ b ∷ A ^ [ ! , lA ]
  soundnessConv↑Term ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    conv (trans (subset*Term d)
                (trans (soundnessConv↓Term t<>u)
                       (sym (subset*Term d′))))
         (sym (subset* D))

  -- Algorithmic equality of terms in WHNF is well-formed.
  soundnessConv↓Term : ∀ {a b A lA Γ} → Γ ⊢ a [conv↓] b ∷ A ^ lA → Γ ⊢ a ≡ b ∷ A ^ [ ! , lA ]
  soundnessConv↓Term (ne x) = soundness~↓! x
  soundnessConv↓Term (ℕ-refl ⊢Γ) = refl (ℕⱼ ⊢Γ)
  soundnessConv↓Term (Empty-refl PE.refl ⊢Γ) = refl (Emptyⱼ ⊢Γ)
  soundnessConv↓Term (Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' F c c₁) =
    Π-cong l< l<' F (soundnessConv↑Term c) (soundnessConv↑Term c₁)
  soundnessConv↓Term (∃-cong PE.refl F c c₁) =
    ∃-cong F (soundnessConv↑Term c) (soundnessConv↑Term c₁)
  soundnessConv↓Term (ℕ-ins x) = soundness~↓! x
  -- soundnessConv↓Term (Empty-ins x) = soundness~↓% x
  soundnessConv↓Term (ne-ins t u x x₁) =
    let whnfM , neA , neB = ne~↓! x₁
        X = soundness~↓! x₁
        _ , t∷M , _ = syntacticEqTerm X
        _ , M≡A' = neTypeEq neA t∷M t -- soundnessConv↑ M≡A
    in conv X M≡A'
  soundnessConv↓Term (zero-refl ⊢Γ) = refl (zeroⱼ ⊢Γ)
  soundnessConv↓Term (suc-cong c) = suc-cong (soundnessConv↑Term c)
  soundnessConv↓Term (η-eq l< l<' F x x₁ y y₁ c) = η-eq l< l<' F x x₁ (soundnessConv↑Term c)
  soundnessConv↓Term (U-refl PE.refl ⊢Γ) = refl (univ 0<1 ⊢Γ)

app-cong′ : ∀ {Γ k l t v F rF lF G lG lΠ}
          → Γ ⊢ k ~ l ↓! Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ ι lΠ
          → Γ ⊢ t [genconv↑] v ∷ F ^ [ rF , ι lF ]
          → Γ ⊢ k ∘ t ^ lΠ ~ l ∘ v ^ lΠ ↑ G [ t ] ^ [ ! , ι lG ]
app-cong′ k~l t=v = ~↑! (app-cong k~l t=v)

natrec-cong′ : ∀ {Γ k l h g a b F lF G}
             → Γ ∙ ℕ ^ [ ! , ι ⁰ ]  ⊢ F [conv↑] G ^ [ ! , ι lF ]
             → Γ ⊢ a [conv↑] b ∷ F [ zero ] ^ ι lF
             → Γ ⊢ h [conv↑] g ∷ Π ℕ ^ ! ° ⁰ ▹ (F ^ ! ° lF ▹▹ F [ suc (var 0) ]↑ ° lF ° lF) ° lF ° lF ^ ι lF
             → Γ ⊢ k ~ l ↓! ℕ ^ ι ⁰
             → Γ ⊢ natrec lF F a h k ~ natrec lF G b g l ↑ F [ k ] ^ [ ! , ι lF ]
natrec-cong′ F=G a=b h=g k~l = ~↑! (natrec-cong F=G a=b h=g k~l)

Emptyrec-cong′ : ∀ {Γ k l F lF lEmpty G}
               → Γ ⊢ F [conv↑] G ^ [ ! , ι lF ]
               → Γ ⊢ k ~ l ↑% Empty lEmpty ^ ι lEmpty
               → Γ ⊢ Emptyrec lF lEmpty F k ~ Emptyrec lF lEmpty G l ↑ F ^ [ ! , ι lF ]
Emptyrec-cong′ F=G k~l = ~↑! (Emptyrec-cong F=G k~l)


module Issue3545 where

open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Common.IO

createElem : Nat → Set
createElem n = Nat

{-# NOINLINE createElem #-}

{-# COMPILE JS createElem = function (x0) {
    return x0;
} #-}

-- WAS: silently accepted
-- WANT: `createElem` is going to be erased; don't do that!

map : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → List A → List B
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs

{-# COMPILE GHC map = \ _ _ _ _ -> Prelude.map #-}

-- `map` however is not erased so this should not raise a warning.

value : List Set
value = map (λ n → createElem n) (1 ∷ 1 ∷ [])


{- 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 LibraBFT.Prelude
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Concrete.System.Parameters

-- This module collects the implementation obligations for our (fake/simple, for now)
-- "implementation" into the structure required by Concrete.Properties.
open import LibraBFT.Impl.Properties.Aux
import      LibraBFT.Impl.Properties.VotesOnce   as VO
import      LibraBFT.Impl.Properties.LockedRound as LR
open import LibraBFT.Concrete.Obligations
open import LibraBFT.Concrete.System impl-sps-avp

module LibraBFT.Impl.Properties where
  theImplObligations : ImplObligations
  theImplObligations = record { sps-cor = impl-sps-avp
                              ; vo₁     = VO.vo₁
                              ; vo₂     = VO.vo₂
                              ; lr₁     = LR.lr₁ }


{-# OPTIONS --rewriting #-}

module Luau.RuntimeError where

open import Agda.Builtin.Equality using (_≡_)
open import Luau.Heap using (Heap; _[_])
open import FFI.Data.Maybe using (just; nothing)
open import FFI.Data.String using (String)
open import Luau.Syntax using (BinaryOperator; Block; Expr; nil; var; val; addr; block_is_end; _$_; local_←_; return; done; _∙_; number; string; binexp; +; -; *; /; <; >; <=; >=; ··)
open import Luau.RuntimeType using (RuntimeType; valueType; function; number; string)
open import Properties.Equality using (_≢_)

data BinOpError : BinaryOperator → RuntimeType → Set where
  + : ∀ {t} → (t ≢ number) → BinOpError + t
  - : ∀ {t} → (t ≢ number) → BinOpError - t
  * : ∀ {t} → (t ≢ number) → BinOpError * t
  / : ∀ {t} → (t ≢ number) → BinOpError / t
  < : ∀ {t} → (t ≢ number) → BinOpError < t
  > : ∀ {t} → (t ≢ number) → BinOpError > t
  <= : ∀ {t} → (t ≢ number) → BinOpError <= t
  >= : ∀ {t} → (t ≢ number) → BinOpError >= t
  ·· : ∀ {t} → (t ≢ string) → BinOpError ·· t

data RuntimeErrorᴮ {a} (H : Heap a) : Block a → Set
data RuntimeErrorᴱ {a} (H : Heap a) : Expr a → Set

data RuntimeErrorᴱ H where
  FunctionMismatch : ∀ v w → (valueType v ≢ function) → RuntimeErrorᴱ H (val v $ val w)
  BinOpMismatch₁ : ∀ v w {op} → (BinOpError op (valueType v)) → RuntimeErrorᴱ H (binexp (val v) op (val w))
  BinOpMismatch₂ : ∀ v w {op} → (BinOpError op (valueType w)) → RuntimeErrorᴱ H (binexp (val v) op (val w))
  UnboundVariable : ∀ {x} → RuntimeErrorᴱ H (var x)
  SEGV : ∀ {a} → (H [ a ] ≡ nothing) → RuntimeErrorᴱ H (val (addr a))
  app₁ : ∀ {M N} → RuntimeErrorᴱ H M → RuntimeErrorᴱ H (M $ N)
  app₂ : ∀ {M N} → RuntimeErrorᴱ H N → RuntimeErrorᴱ H (M $ N)
  block : ∀ {b B} → RuntimeErrorᴮ H B → RuntimeErrorᴱ H (block b is B end)
  bin₁ : ∀ {M N op} → RuntimeErrorᴱ H M → RuntimeErrorᴱ H (binexp M op N)
  bin₂ : ∀ {M N op} → RuntimeErrorᴱ H N → RuntimeErrorᴱ H (binexp M op N)

data RuntimeErrorᴮ H where
  local : ∀ {x M B} → RuntimeErrorᴱ H M → RuntimeErrorᴮ H (local x ← M ∙ B)
  return : ∀ {M B} → RuntimeErrorᴱ H M → RuntimeErrorᴮ H (return M ∙ B)


open import Coinduction using ( ∞ )
open import Data.ByteString using ( ByteString ; strict ; lazy )
open import Data.String using ( String )

module System.IO.Primitive where

infixl 1 _>>=_

-- The Unit type and its sole inhabitant

postulate
  Unit : Set
  unit : Unit

{-# COMPILED_TYPE Unit () #-}
{-# COMPILED unit () #-}

-- The IO type and its primitives
-- TODO: Make these universe-polymorphic once the compiler supports it

postulate
  IO : Set → Set
  return : {A : Set} → A → (IO A)
  _>>=_  : {A B : Set} → (IO A) → (A → (IO B)) → (IO B)
  inf : {A : Set} → ∞(IO A) → (IO A)

{-# BUILTIN IO IO #-}
{-# COMPILED_TYPE IO IO #-}
{-# COMPILED return (\ _ a -> return a) #-}
{-# COMPILED _>>=_ (\ _ _ a f -> a >>= f) #-}
-- {-# COMPILED inf (\ _ a -> a) #-}

-- The commitment primitives
postulate
  commit : IO Unit
  onCommit : (IO Unit) → (IO Unit)

{-# IMPORT System.IO.AgdaFFI #-}
{-# COMPILED commit System.IO.AgdaFFI.commit #-}
{-# COMPILED onCommit System.IO.AgdaFFI.onCommit #-}

-- The low-level binary handle primitives.
-- TODO: Should the string etc. functions be built on top of
-- the binary functions, or should we link directly to the Haskell
-- string functions?
-- TODO: Think about append and read-write modes.

postulate
  HandleR : Set
  stdin : HandleR
  hOpenR : String → (IO HandleR)
  hGetLazy : HandleR → (IO (ByteString lazy))
  hGetStrict : HandleR → (IO (ByteString strict))
  hCloseR : HandleR → (IO Unit)

{-# IMPORT System.IO #-}
{-# COMPILED_TYPE HandleR System.IO.Handle #-}
{-# COMPILED stdin System.IO.stdin #-}
{-# COMPILED hOpenR System.IO.AgdaFFI.hOpen System.IO.ReadMode #-}
{-# COMPILED hGetStrict System.IO.AgdaFFI.hGetStrict #-}
{-# COMPILED hGetLazy System.IO.AgdaFFI.hGetLazy #-}
{-# COMPILED hCloseR System.IO.AgdaFFI.hClose #-}

postulate
  HandleW : Set
  stdout : HandleW
  stderr : HandleW
  hOpenW : String → (IO HandleW)
  hPutLazy : HandleW → (ByteString lazy) → (IO Unit)
  hPutStrict : HandleW → (ByteString strict) → (IO Unit)
  hCloseW : HandleW → (IO Unit)

{-# COMPILED_TYPE HandleW System.IO.Handle #-}
{-# COMPILED stdout System.IO.stdout #-}
{-# COMPILED stderr System.IO.stderr #-}
{-# COMPILED hOpenW System.IO.AgdaFFI.hOpen System.IO.WriteMode #-}
{-# COMPILED hPutStrict System.IO.AgdaFFI.hPutStrict #-}
{-# COMPILED hPutLazy System.IO.AgdaFFI.hPutLazy #-}
{-# COMPILED hCloseW System.IO.AgdaFFI.hClose #-}


{-# OPTIONS --type-in-type --guardedness #-}

module IO.Instance where

open import Class.Monad using (Monad)
open import Class.Monad.IO
open import Class.Monoid
open import Data.Product
open import Data.Sum
open import IO
open import Monads.ExceptT
open import Monads.StateT
open import Monads.WriterT
open import Level

instance
  IO-Monad : Monad IO
  IO-Monad = record { _>>=_ = _>>=_ ; return = return }

  IO-MonadIO : MonadIO IO
  IO-MonadIO = record { liftIO = λ x -> x }

module _ {a} {M : Set a -> Set a} {{_ : Monad M}} {{_ : MonadIO M}} where

  ExceptT-MonadIO : ∀ {E} -> MonadIO (ExceptT M E) {{ExceptT-Monad}}
  ExceptT-MonadIO = record { liftIO = λ x -> liftIO (x >>= λ a -> return (inj₂ a)) }

  StateT-MonadIO : ∀ {S} -> MonadIO (StateT M S)
  StateT-MonadIO = record { liftIO = λ x -> λ s -> liftIO (x >>= (λ a -> return (a , s))) }

  WriterT-MonadIO : ∀ {W} {{_ : Monoid W}} -> MonadIO (WriterT M W) {{WriterT-Monad}}
  WriterT-MonadIO = record { liftIO = λ x -> liftIO (x >>= λ a -> return (a , mzero)) }


------------------------------------------------------------------------
-- Canonically kinded hereditary substitutions in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Canonical.HereditarySubstitution where

open import Data.Fin using (Fin; zero; suc; raise; lift)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Typed
open import Data.Product as Prod using (∃; _,_; _×_; proj₁; proj₂)
open import Data.Vec as Vec using ([]; _∷_)
import Data.Vec.Properties as VecProps
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization
open import FOmegaInt.Kinding.Canonical as CanonicalKinding
open import FOmegaInt.Kinding.Simple    as SimpleKinding

open Syntax
open ElimCtx
open SimpleCtx          using (⌊_⌋Asc; kd; tp)
open ContextConversions using (⌊_⌋Ctx)
open Substitution       hiding (_↑; sub; subst)
open RenamingCommutes
open SimpHSubstLemmas
open SimpleKinding.Kinding using (_⊢_kds; kds-Π)
open CanonicalKinding.Kinding
open KindedHereditarySubstitution
  using (_⊢/⟨_⟩_∈_; ∈-hsub; ∈-H↑; kds-/⟨⟩; kds-[]-/⟨⟩-↑⋆)
open CanonicalKinding.KindedRenaming
  using (typedVarSubst; kd-/Var; ≃-/Var; <∷-/Var; kd-weaken; <∷-weaken)
module TV = TypedVarSubst typedVarSubst
open ContextNarrowing

----------------------------------------------------------------------
-- Ascription order: a wrapper judgment that combines subtyping and
-- subkinding.
--
-- NOTE. Subtyping instances are always trivial, i.e. they only
-- support (syntactic) reflexivity.

infix 4 _⊢_≤_

data _⊢_≤_ {n} (Γ : Ctx n) : ElimAsc n → ElimAsc n → Set where
  ≤-<∷   : ∀ {j k} → Γ ⊢ j <∷ k → Γ ⊢ k kd → Γ ⊢ kd j ≤ kd k
  ≤-refl : ∀ {a} → Γ ⊢ a ≤ a

-- Transitivity of the ascription order.

≤-trans : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢ a ≤ b → Γ ⊢ b ≤ c → Γ ⊢ a ≤ c
≤-trans (≤-<∷ j<∷k _)    (≤-<∷ k<∷l l-kd) = ≤-<∷ (<∷-trans j<∷k k<∷l) l-kd
≤-trans (≤-<∷ j<∷k k-kd) ≤-refl           = ≤-<∷ j<∷k k-kd
≤-trans ≤-refl           a≤c              = a≤c

-- Kinds in related ascriptions have the same shape.

≤-⌊⌋ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ kd j ≤ kd k → ⌊ j ⌋ ≡ ⌊ k ⌋
≤-⌊⌋ (≤-<∷ j<∷k _) = <∷-⌊⌋ j<∷k
≤-⌊⌋ ≤-refl        = refl

-- Renamings preserve the ascription order.

≤-/Var : ∀ {m n Γ Δ a b} {ρ : Sub Fin m n} →
         Γ ⊢ a ≤ b → Δ TV.⊢/Var ρ ∈ Γ → Δ ⊢ a ElimAsc/Var ρ ≤ b ElimAsc/Var ρ
≤-/Var (≤-<∷ j<∷k k-kd) ρ∈Γ = ≤-<∷ (<∷-/Var j<∷k ρ∈Γ) (kd-/Var k-kd ρ∈Γ)
≤-/Var ≤-refl           ρ∈Γ = ≤-refl

-- Admissible subsumption rules w.r.t. the ascription order.

Nf⇇-⇑-≤ : ∀ {n} {Γ : Ctx n} {a k j} →
          Γ ⊢Nf a ⇇ k → Γ ⊢ kd k ≤ kd j → Γ ⊢Nf a ⇇ j
Nf⇇-⇑-≤ a⇇k (≤-<∷ k<∷j j-kd) = Nf⇇-⇑ a⇇k k<∷j
Nf⇇-⇑-≤ a⇇k ≤-refl           = a⇇k

≃-⇑-≤ : ∀ {n} {Γ : Ctx n} {a b k j} →
        Γ ⊢ a ≃ b ⇇ k → Γ ⊢ kd k ≤ kd j → Γ ⊢ a ≃ b ⇇ j
≃-⇑-≤ a≃b⇇k (≤-<∷ k<∷j j-kd) = ≃-⇑ a≃b⇇k k<∷j j-kd
≃-⇑-≤ a≃b⇇k ≤-refl           = a≃b⇇k

-- An admissible variable rule based on the ascription order.

Var∈-⇑-≤  : ∀ {n} {Γ : Ctx n} {a k} x →
            Γ ctx → lookup Γ x ≡ a → Γ ⊢ a ≤ kd k → Γ ⊢Var x ∈ k
Var∈-⇑-≤ x Γ-ctx Γ[x]≡j (≤-<∷ j<∷k k-kd) = ⇇-⇑ (⇉-var x Γ-ctx Γ[x]≡j) j<∷k k-kd
Var∈-⇑-≤ x Γ-ctx Γ[x]≡k ≤-refl           = ⇉-var x Γ-ctx Γ[x]≡k

----------------------------------------------------------------------
-- Well-kinded hereditary substitutions (i.e. substitution lemmas) in
-- canonical types

infix 4 _⊢/⟨_⟩_⇇_ _⊢/⟨_⟩_≃_⇇_ _⊢?⟨_⟩_⇇_ _⊢?⟨_⟩_≃_⇇_

-- Well-kinded pointwise equality of hereditary substitutions and
-- their lookup results.

data _⊢/⟨_⟩_≃_⇇_ : ∀ {m n} →
                   Ctx n → SKind → SVSub m n → SVSub m n → Ctx m → Set where
  ≃-hsub : ∀ {n} {Γ : Ctx n} {k a b j} →
           Γ ⊢ a ≃ b ⇇ j → ⌊ j ⌋≡ k →
           Γ ⊢/⟨ k ⟩ sub a ≃ sub b ⇇ kd j ∷ Γ
  ≃-H↑   : ∀ {m n Δ k Γ} {σ τ : SVSub m n} {j l} →
           Δ ⊢ j ≅ l Kind/⟨ k ⟩ σ → Δ ⊢ j ≅ l Kind/⟨ k ⟩ τ →
           Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → kd j ∷ Δ ⊢/⟨ k ⟩ σ ↑ ≃ τ ↑ ⇇ kd l ∷ Γ

data _⊢?⟨_⟩_≃_⇇_ {n} (Γ : Ctx n) (k : SKind)
                 : SVRes n → SVRes n → ElimAsc n → Set where
  ≃-hit  : ∀ {a b j} →
           Γ ⊢ a ≃ b ⇇ j → ⌊ j ⌋≡ k → Γ ⊢?⟨ k ⟩ hit a ≃ hit b ⇇ kd j
  ≃-miss : ∀ y {a b} → Γ ctx → lookup Γ y ≡ a → Γ ⊢ a ≤ b →
           Γ ⊢?⟨ k ⟩ miss y ≃ miss y ⇇ b

-- Well-kinded suspended hereditary substations are just a degenerate
-- case of equal hereditary substitutions where the underlying
-- substitutions coincide (syntactically).

_⊢/⟨_⟩_⇇_ : ∀ {m n} → Ctx n → SKind → SVSub m n → Ctx m → Set
Δ ⊢/⟨ k ⟩ σ ⇇ Γ = Δ ⊢/⟨ k ⟩ σ ≃ σ ⇇ Γ

⇇-hsub : ∀ {n} {Γ : Ctx n} {k a j} →
         Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → ⌊ j ⌋≡ k →
         Γ ⊢/⟨ k ⟩ sub a ⇇ kd j ∷ Γ
⇇-hsub a⇇j j-kd ⌊j⌋≡k = ≃-hsub (≃-reflNf⇇ a⇇j j-kd) ⌊j⌋≡k

⇇-H↑ : ∀ {m n Δ k Γ} {σ : SVSub m n} {j l} →
       Δ ⊢ j ≅ l Kind/⟨ k ⟩ σ → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
       kd j ∷ Δ ⊢/⟨ k ⟩ σ ↑ ⇇ kd l ∷ Γ
⇇-H↑ j≅l/σ σ⇇Γ = ≃-H↑ j≅l/σ j≅l/σ σ⇇Γ

_⊢?⟨_⟩_⇇_ : ∀ {n} → Ctx n → SKind → SVRes n → ElimAsc n → Set
Δ ⊢?⟨ k ⟩ σ ⇇ Γ = Δ ⊢?⟨ k ⟩ σ ≃ σ ⇇ Γ

⇇-hit  : ∀ {n} {Γ : Ctx n} {k a j} →
         Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → ⌊ j ⌋≡ k → Γ ⊢?⟨ k ⟩ hit a ⇇ kd j
⇇-hit a⇇j j-kd ⌊j⌋≡k = ≃-hit (≃-reflNf⇇ a⇇j j-kd) ⌊j⌋≡k

⇇-miss = λ {n} {Γ} {k} → ≃-miss {n} {Γ} {k}

-- Renamings preserve equality of SV results.

?≃-/Var : ∀ {m n Γ k Δ r₁ r₂ a} {ρ : Sub Fin m n} →
          Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ a → Δ TV.⊢/Var ρ ∈ Γ →
          Δ ⊢?⟨ k ⟩ r₁ ?/Var ρ ≃ r₂ ?/Var ρ ⇇ a ElimAsc/Var ρ
?≃-/Var (≃-hit a≃b∈k ⌊j⌋≡k) ρ∈Γ =
  ≃-hit (≃-/Var a≃b∈k ρ∈Γ) (⌊⌋≡-/Var ⌊j⌋≡k)
?≃-/Var {Γ = Γ} {k} {Δ} {ρ = ρ} (≃-miss y {a} {b} _ Γ[x]≡a a≤b) ρ∈Γ =
  helper (cong (_ElimAsc/Var ρ) Γ[x]≡a) (TV.lookup ρ∈Γ y)
  where
    helper : ∀ {x c} → c ≡ a ElimAsc/Var ρ → Δ TV.⊢Var x ∈ c →
             Δ ⊢?⟨ k ⟩ miss x ≃ miss x ⇇ b ElimAsc/Var ρ
    helper Δ[x]≡a/ρ (TV.∈-var x Δ-ctx) =
      ≃-miss x (TV./∈-wf ρ∈Γ) Δ[x]≡a/ρ (≤-/Var a≤b ρ∈Γ)

?≃-weaken : ∀ {n} {Γ : Ctx n} {k r₁ r₂ a b} →
            Γ ⊢ a wf → Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ b →
            (a ∷ Γ) ⊢?⟨ k ⟩ weakenSVRes r₁ ≃ weakenSVRes r₂ ⇇ weakenElimAsc b
?≃-weaken a-wf r₁≃r₂⇇a = ?≃-/Var r₁≃r₂⇇a (TV.∈-wk a-wf)

-- Look up a variable in a pair of well-kinded pointwise equal
-- hereditary substitution.

lookup-/⟨⟩≃ : ∀ {m n Δ k Γ} {σ τ : SVSub m n} →
              Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → (x : Fin m) →
              Δ ⊢?⟨ k ⟩ lookupSV σ x ≃ lookupSV τ x ⇇ lookup Γ x Asc/⟨ k ⟩ σ
lookup-/⟨⟩≃ (≃-hsub {_} {Γ} {k} {a} {b} {j} a≃b⇇k ⌊j⌋≡k) zero =
  subst (Γ ⊢?⟨ k ⟩ hit a ≃ hit b ⇇_)
        (cong kd (sym (Kind/Var-wk-↑⋆-hsub-vanishes 0 j))) (≃-hit a≃b⇇k ⌊j⌋≡k)
lookup-/⟨⟩≃ (≃-hsub {Γ = Γ} {k} {a} {_} {j} a≃b⇇k ⌊j⌋≡k) (suc x) =
  subst (Γ ⊢?⟨ k ⟩ miss x ≃ miss x ⇇_) (begin
      lookup Γ x
    ≡˘⟨ Asc/Var-wk-↑⋆-hsub-vanishes 0 (lookup Γ x) ⟩
      weakenElimAsc (lookup Γ x) Asc/⟨ k ⟩ sub a
    ≡˘⟨ cong (_Asc/⟨ k ⟩ sub a) (VecProps.lookup-map x weakenElimAsc (toVec Γ)) ⟩
       lookup (kd j ∷ Γ) (suc x) Asc/⟨ k ⟩ sub a
    ∎) (≃-miss x (≃-ctx a≃b⇇k) refl ≤-refl)
lookup-/⟨⟩≃ (≃-H↑ {Δ = Δ} {k} {j = j} {l} j≅l/σ j≅l/τ σ≃τ⇇Γ) zero =
  let j-kd , l/σ-kd = ≅-valid j≅l/σ
      j-wf  = wf-kd j-kd
      j≤l/σ = ≤-<∷ (<∷-weaken j-wf (≅⇒<∷ j≅l/σ)) (kd-weaken j-wf l/σ-kd)
  in subst (kd j ∷ Δ ⊢?⟨ k ⟩ miss zero ≃ miss zero ⇇_)
           (sym (wk-Asc/⟨⟩-↑⋆ 0 (kd l)))
           (≃-miss zero (j-wf ∷ (kd-ctx j-kd)) refl j≤l/σ)
lookup-/⟨⟩≃ (≃-H↑ {k = k} {Γ} {σ} {_} {_} {l} j≅l/σ _ σ≃τ⇇Γ) (suc x) =
  subst (_ ⊢?⟨ k ⟩ _ ≃ _ ⇇_) (begin
      weakenElimAsc (lookup Γ x Asc/⟨ k ⟩ σ)
    ≡˘⟨ wk-Asc/⟨⟩-↑⋆ 0 (lookup Γ x) ⟩
      weakenElimAsc (lookup Γ x) Asc/⟨ k ⟩ σ ↑
    ≡˘⟨ cong (_Asc/⟨ k ⟩ σ ↑)
             (VecProps.lookup-map x weakenElimAsc (toVec Γ)) ⟩
      lookup (kd l ∷ Γ) (suc x) Asc/⟨ k ⟩ σ ↑
    ∎) (?≃-weaken (wf-kd (proj₁ (≅-valid j≅l/σ))) (lookup-/⟨⟩≃ σ≃τ⇇Γ x))

-- Equation and context validity lemmas for hereditary substitutions.

/⟨⟩≃-valid₁ : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
              Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ⊢/⟨ k ⟩ σ ⇇ Γ
/⟨⟩≃-valid₁ (≃-hsub a≃b⇇j ⌊j⌋≡k) =
  ⇇-hsub (proj₁ (≃-valid a≃b⇇j)) (≃-valid-kd a≃b⇇j) ⌊j⌋≡k
/⟨⟩≃-valid₁ (≃-H↑ a≅b/σ _ σ≃τ∈Γ) = ⇇-H↑ a≅b/σ (/⟨⟩≃-valid₁ σ≃τ∈Γ)

/⟨⟩≃-valid₂ : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
              Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ⊢/⟨ k ⟩ τ ⇇ Γ
/⟨⟩≃-valid₂ (≃-hsub a≃b⇇j ⌊j⌋≡k) =
  ⇇-hsub (proj₂ (≃-valid a≃b⇇j)) (≃-valid-kd a≃b⇇j) ⌊j⌋≡k
/⟨⟩≃-valid₂ (≃-H↑ _ a≅b/τ σ≃τ∈Γ) = ⇇-H↑ a≅b/τ (/⟨⟩≃-valid₂ σ≃τ∈Γ)

/⟨⟩≃-ctx : ∀ {k m n Γ Δ} {σ τ : SVSub m n} →
           Γ ctx → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ctx
/⟨⟩≃-ctx j∷Γ-ctx (≃-hsub a≃b⇇j ⌊j⌋≡k)     = wf-∷₂ j∷Γ-ctx
/⟨⟩≃-ctx l∷Γ-ctx (≃-H↑ j≅l/σ j≅l/τ σ≃τ⇇Γ) =
  let j-kd , _ = ≅-valid j≅l/σ
      Γ-ctx    = wf-∷₂ l∷Γ-ctx
  in (wf-kd j-kd) ∷ /⟨⟩≃-ctx Γ-ctx σ≃τ⇇Γ

-- Symmetry of hereditary substitution equality.

/⟨⟩≃-sym : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
           Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ⊢/⟨ k ⟩ τ ≃ σ ⇇ Γ
/⟨⟩≃-sym (≃-hsub a≃b⇇j ⌊j⌋≡k)     = ≃-hsub (≃-sym a≃b⇇j) ⌊j⌋≡k
/⟨⟩≃-sym (≃-H↑ a≅b/σ a≅b/τ σ≃τ∈Γ) = ≃-H↑ a≅b/τ a≅b/σ (/⟨⟩≃-sym σ≃τ∈Γ)

-- Simplification of kinded substitutions.
--
-- NOTE. The second substitution τ is ignored by the simplification.
-- It is tempting to rephrase the lemma in terms of _⊢/⟨_⟩_⇇_ instead
-- of _⊢/⟨_⟩_≃_⇇_ but that introduces extra constraints for the Agda
-- pattern matcher that require UIP (aka axiom K) to resolve.  Since
-- this assumption is unnecessary, we prove the more general version
-- instead. (See the Agda documentation about the --without-K option
-- for more info).

/⟨⟩⇇-/⟨⟩∈ : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
            Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → ⌊ Δ ⌋Ctx ⊢/⟨ k ⟩ σ ∈ ⌊ Γ ⌋Ctx
/⟨⟩⇇-/⟨⟩∈ (≃-hsub a≃b⇇j ⌊j⌋≡k) =
  subst (_ ⊢/⟨_⟩ _ ∈ _) (⌊⌋≡⇒⌊⌋-≡ ⌊j⌋≡k)
        (∈-hsub (Nf⇇-Nf∈ (proj₁ (≃-valid a≃b⇇j))))
/⟨⟩⇇-/⟨⟩∈ (≃-H↑ {Δ = Δ} {k} {Γ} {σ} {_} {j} {l} j≅l/σ _ σ≃σ∈Γ) =
  subst ((_⊢/⟨ k ⟩ σ ↑ ∈ ⌊ kd l ∷ Γ ⌋Ctx) ∘ (_∷ ⌊ Δ ⌋Ctx)) (begin
          ⌊ kd l ⌋Asc              ≡˘⟨ ⌊⌋-Asc/⟨⟩ (kd l) ⟩
          ⌊ kd l Asc/⟨ k ⟩ σ ⌋Asc  ≡˘⟨ cong kd (≅-⌊⌋ j≅l/σ) ⟩
          ⌊ kd j ⌋Asc              ∎)
        (∈-H↑ (/⟨⟩⇇-/⟨⟩∈ σ≃σ∈Γ))

-- TODO: explain why we need to track shapes explicitly.

module TrackSimpleKindsSubst where

  -- TODO: explain how/why preservation of (sub)kinding/subtyping
  -- under reducing applications, hereditary substitution and equal
  -- hereditary substitutions circularly depend on each other.

  mutual

    -- Hereditary substitutions preserve well-formedness of kinds.

    kd-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {j} →
             Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ⇇ Γ → Δ ⊢ j Kind/⟨ k ⟩ σ kd
    kd-/⟨⟩ (kd-⋯ a⇉a⋯a b⇉b⋯b) σ⇇Γ =
      kd-⋯ (Nf⇉-/⟨⟩ a⇉a⋯a σ⇇Γ) (Nf⇉-/⟨⟩ b⇉b⋯b σ⇇Γ)
    kd-/⟨⟩ (kd-Π j-kd k-kd)   σ⇇Γ =
      let j/σ-kd = kd-/⟨⟩ j-kd σ⇇Γ
      in kd-Π j/σ-kd (kd-/⟨⟩ k-kd (⇇-H↑ (≅-refl j/σ-kd) σ⇇Γ))

    -- Hereditary substitutions preserve synthesized kinds of normal
    -- types.

    Nf⇉-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {a j} →
              Γ ⊢Nf a ⇉ j → Δ ⊢/⟨ k ⟩ σ ⇇ Γ → Δ ⊢Nf a /⟨ k ⟩ σ ⇉ j Kind/⟨ k ⟩ σ
    Nf⇉-/⟨⟩ (⇉-⊥-f Γ-ctx) σ⇇Γ = ⇉-⊥-f (/⟨⟩≃-ctx Γ-ctx σ⇇Γ)
    Nf⇉-/⟨⟩ (⇉-⊤-f Γ-ctx) σ⇇Γ = ⇉-⊤-f (/⟨⟩≃-ctx Γ-ctx σ⇇Γ)
    Nf⇉-/⟨⟩ (⇉-∀-f k-kd a⇉a⋯a)  σ⇇Γ =
      let k/σ-kd = kd-/⟨⟩ k-kd σ⇇Γ
      in ⇉-∀-f k/σ-kd (Nf⇉-/⟨⟩ a⇉a⋯a (⇇-H↑ (≅-refl k/σ-kd) σ⇇Γ))
    Nf⇉-/⟨⟩ (⇉-→-f a⇉a⋯a b⇉b⋯b) σ⇇Γ =
      ⇉-→-f (Nf⇉-/⟨⟩ a⇉a⋯a σ⇇Γ) (Nf⇉-/⟨⟩ b⇉b⋯b σ⇇Γ)
    Nf⇉-/⟨⟩ (⇉-Π-i k-kd a⇉a⋯a)  σ⇇Γ =
      let k/σ-kd = kd-/⟨⟩ k-kd σ⇇Γ
      in ⇉-Π-i k/σ-kd (Nf⇉-/⟨⟩ a⇉a⋯a (⇇-H↑ (≅-refl k/σ-kd) σ⇇Γ))
    Nf⇉-/⟨⟩ (⇉-s-i a∈b⋯c) σ⇇Γ = Nf⇇-s-i (Ne∈-/⟨⟩ a∈b⋯c σ⇇Γ)

    -- Neutral proper types kind-check against their synthesized kinds
    -- after substitution.

    Ne∈-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {a b c} →
              Γ ⊢Ne a ∈ b ⋯ c → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
              Δ ⊢Nf a /⟨ k ⟩ σ ⇇ b /⟨ k ⟩ σ ⋯ c /⟨ k ⟩ σ
    Ne∈-/⟨⟩ (∈-∙ {x} x∈j j⇉as⇉b⋯c) σ⇇Γ =
      let j-kds = kd-kds (Var∈-valid x∈j)
      in Var∈-/⟨⟩-⇑-?∙∙ x∈j σ⇇Γ ≤-refl (Sp⇉-/⟨⟩ j-kds j⇉as⇉b⋯c σ⇇Γ)

    Var∈-/⟨⟩-⇑-?∙∙ : ∀ {k m n Γ Δ} {σ : SVSub m n} {x j l as b c} →
                     Γ ⊢Var x ∈ j → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
                     Δ ⊢ kd j Asc/⟨ k ⟩ σ ≤ kd l → Δ ⊢ l ⇉∙ as ⇉ b ⋯ c →
                     Δ ⊢Nf lookupSV σ x ?∙∙⟨ k ⟩ as ⇇ b ⋯ c
    Var∈-/⟨⟩-⇑-?∙∙ (⇉-var x _ Γ[x]≡kd-j) σ⇇Γ j/σ≤l l⇉as⇉b⋯c =
      ?⇇-⇑-?∙∙ (subst (_ ⊢?⟨ _ ⟩ _ ⇇_) (cong (_Asc/⟨ _ ⟩ _) Γ[x]≡kd-j)
                      (lookup-/⟨⟩≃ σ⇇Γ x))
               j/σ≤l l⇉as⇉b⋯c
    Var∈-/⟨⟩-⇑-?∙∙ (⇇-⇑ x∈j₁ j₁<∷j₂ j₂-kd) σ⇇Γ j₂/σ≤l l⇉as⇉b⋯c =
      let j₁/σ≤j₂/σ = ≤-<∷ (<∷-/⟨⟩≃ j₁<∷j₂ σ⇇Γ) (kd-/⟨⟩ j₂-kd σ⇇Γ)
      in Var∈-/⟨⟩-⇑-?∙∙ x∈j₁ σ⇇Γ (≤-trans j₁/σ≤j₂/σ j₂/σ≤l) l⇉as⇉b⋯c

    -- Hereditary substitutions preserve synthesized kinds of spines.
    Sp⇉-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {as j₁ j₂} →
              ⌊ Γ ⌋Ctx ⊢ j₁ kds → Γ ⊢ j₁ ⇉∙ as ⇉ j₂ → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
              Δ ⊢ j₁ Kind/⟨ k ⟩ σ ⇉∙ as //⟨ k ⟩ σ ⇉ j₂ Kind/⟨ k ⟩ σ
    Sp⇉-/⟨⟩ _ ⇉-[] σ⇇Γ = ⇉-[]
    Sp⇉-/⟨⟩ {k} (kds-Π j₁-kds j₂-kds)
            (⇉-∷ {a} {_} {j₁} {j₂} a⇇j₁ j₁-kd j₂[a]⇉as⇉j₃) σ⇇Γ =
      ⇉-∷ (Nf⇇-/⟨⟩ a⇇j₁ σ⇇Γ) (kd-/⟨⟩ j₁-kd σ⇇Γ)
          (subst (_ ⊢_⇉∙ _ ⇉ _) j₂[a]/σ≡j₂/σ[a/σ]
                 (Sp⇉-/⟨⟩ (kds-/⟨⟩ j₂-kds (∈-hsub a∈⌊j₁⌋)) j₂[a]⇉as⇉j₃ σ⇇Γ))
      where
        a∈⌊j₁⌋ = Nf⇇-Nf∈ a⇇j₁

        j₂[a]/σ≡j₂/σ[a/σ] = begin
            j₂ Kind[ a ∈ ⌊ j₁ ⌋ ] Kind/⟨ k ⟩ _
          ≡⟨ kds-[]-/⟨⟩-↑⋆ [] j₂-kds a∈⌊j₁⌋ (/⟨⟩⇇-/⟨⟩∈ σ⇇Γ) ⟩
            j₂ Kind/⟨ k ⟩ _ ↑ Kind/⟨ ⌊ j₁ ⌋ ⟩ sub (a /⟨ k ⟩ _)
          ≡⟨ cong (_ Kind[ a /⟨ k ⟩ _ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j₁)) ⟩
            (j₂ Kind/⟨ k ⟩ _ ↑) Kind[ a /⟨ k ⟩ _ ∈ ⌊ j₁ Kind/⟨ k ⟩ _ ⌋ ]
          ∎

    -- Hereditary substitutions preserve checked kinds of normal
    -- types.
    Nf⇇-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {a j} →
              Γ ⊢Nf a ⇇ j → Δ ⊢/⟨ k ⟩ σ ⇇ Γ → Δ ⊢Nf a /⟨ k ⟩ σ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇇-/⟨⟩ (⇇-⇑ a⇉j j<∷k) σ⇇Γ = ⇇-⇑ (Nf⇉-/⟨⟩ a⇉j σ⇇Γ) (<∷-/⟨⟩≃ j<∷k σ⇇Γ)

    -- Equal hereditary substitutions well-formed kinds to subkinds.
    kd-/⟨⟩≃-<∷ : ∀ {m n Γ k Δ} {σ τ : SVSub m n} {j} →
                 Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ j Kind/⟨ k ⟩ σ <∷ j Kind/⟨ k ⟩ τ
    kd-/⟨⟩≃-<∷ (kd-⋯ a⇉a⋯a b⇉b⋯b) σ≃τ⇇Γ =
      <∷-⋯ (Nf⇉-⋯-/⟨⟩≃ a⇉a⋯a (/⟨⟩≃-sym σ≃τ⇇Γ)) (Nf⇉-⋯-/⟨⟩≃ b⇉b⋯b σ≃τ⇇Γ)
    kd-/⟨⟩≃-<∷ (kd-Π j-kd k-kd)   σ≃τ⇇Γ =
      let σ⇇Γ     = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ     = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ   = /⟨⟩≃-sym σ≃τ⇇Γ
          j/σ≅j/σ = kd-/⟨⟩≃-≅ j-kd σ⇇Γ
          j/τ≅j/τ = kd-/⟨⟩≃-≅ j-kd τ⇇Γ
          j/τ≅j/σ = kd-/⟨⟩≃-≅ j-kd τ≃σ⇇Γ
      in <∷-Π (kd-/⟨⟩≃-<∷ j-kd τ≃σ⇇Γ)
              (kd-/⟨⟩≃-<∷ k-kd (≃-H↑ j/τ≅j/σ j/τ≅j/τ σ≃τ⇇Γ))
              (kd-Π (kd-/⟨⟩ j-kd σ⇇Γ) (kd-/⟨⟩ k-kd (⇇-H↑ j/σ≅j/σ σ⇇Γ)))

    -- Equal hereditary substitutions map well-formed kinds to kind
    -- identities.
    kd-/⟨⟩≃-≅ : ∀ {m n Γ k Δ} {σ τ : SVSub m n} {j} →
                Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                Δ ⊢ j Kind/⟨ k ⟩ σ ≅ j Kind/⟨ k ⟩ τ
    kd-/⟨⟩≃-≅ k-kd σ≃τ⇇Γ =
      <∷-antisym (kd-/⟨⟩ k-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
                 (kd-/⟨⟩ k-kd (/⟨⟩≃-valid₂ σ≃τ⇇Γ))
                 (kd-/⟨⟩≃-<∷ k-kd σ≃τ⇇Γ) (kd-/⟨⟩≃-<∷ k-kd (/⟨⟩≃-sym σ≃τ⇇Γ))

    -- Equal hereditary substitutions map normal forms to subtypes.

    Nf⇉-⋯-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a b c} →
                 Γ ⊢Nf a ⇉ b ⋯ c → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ
    Nf⇉-⋯-/⟨⟩≃ (⇉-⊥-f Γ-ctx) σ≃τ⇇Γ =
      <:-⊥ (⇉-⊥-f (/⟨⟩≃-ctx Γ-ctx (/⟨⟩≃-valid₁ σ≃τ⇇Γ)))
    Nf⇉-⋯-/⟨⟩≃ (⇉-⊤-f Γ-ctx) σ≃τ⇇Γ =
      <:-⊤ (⇉-⊤-f (/⟨⟩≃-ctx Γ-ctx (/⟨⟩≃-valid₂ σ≃τ⇇Γ)))
    Nf⇉-⋯-/⟨⟩≃ (⇉-∀-f k-kd a⇉a⋯a) σ≃τ⇇Γ =
      let σ⇇Γ       = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ       = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ     = /⟨⟩≃-sym  σ≃τ⇇Γ
          k/τ≅k/τ   = kd-/⟨⟩≃-≅ k-kd τ⇇Γ
          k/σ≅k/σ   = kd-/⟨⟩≃-≅ k-kd σ⇇Γ
          k/τ≅k/σ   = kd-/⟨⟩≃-≅ k-kd τ≃σ⇇Γ
          σ≃τ⇇j/τ∷Γ = ≃-H↑ k/τ≅k/σ k/τ≅k/τ σ≃τ⇇Γ
      in <:-∀ (≅⇒<∷ k/τ≅k/σ) (Nf⇉-⋯-/⟨⟩≃ a⇉a⋯a σ≃τ⇇j/τ∷Γ)
              (⇉-∀-f (kd-/⟨⟩ k-kd σ⇇Γ)
                     (Nf⇉-/⟨⟩ a⇉a⋯a (⇇-H↑ k/σ≅k/σ σ⇇Γ)))
    Nf⇉-⋯-/⟨⟩≃ (⇉-→-f a⇉a⋯a b⇉b⋯b) σ≃τ⇇Γ =
      <:-→ (Nf⇉-⋯-/⟨⟩≃ a⇉a⋯a (/⟨⟩≃-sym σ≃τ⇇Γ)) (Nf⇉-⋯-/⟨⟩≃ b⇉b⋯b σ≃τ⇇Γ)
    Nf⇉-⋯-/⟨⟩≃ (⇉-s-i a∈b⋯c) σ≃τ⇇Γ = Ne∈-/⟨⟩≃ a∈b⋯c σ≃τ⇇Γ

    Nf⇉-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a j} →
               Γ ⊢Nf a ⇉ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇉-/⟨⟩≃ a⇉b⋯c (kd-⋯ b⇉b⋯b c⇉c⋯c) σ≃τ⇇Γ =
      let σ⇇Γ   = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ   = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
      in <:-⇇ (Nf⇉⇒Nf⇇ (Nf⇉-/⟨⟩ a⇉b⋯c σ⇇Γ))
              (⇇-⇑ (Nf⇉-/⟨⟩ a⇉b⋯c τ⇇Γ)
                   (<∷-⋯ (Nf⇉-⋯-/⟨⟩≃ b⇉b⋯b σ≃τ⇇Γ) (Nf⇉-⋯-/⟨⟩≃ c⇉c⋯c τ≃σ⇇Γ)))
              (Nf⇉-⋯-/⟨⟩≃ a⇉b⋯c σ≃τ⇇Γ)
    Nf⇉-/⟨⟩≃ (⇉-Π-i _ a⇉l) (kd-Π j-kd l-kd) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          σ⇇Γ   = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ   = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          j/σ-kd  = kd-/⟨⟩ j-kd σ⇇Γ
          j/τ-kd  = kd-/⟨⟩ j-kd τ⇇Γ
          j/σ≅j/σ = kd-/⟨⟩≃-≅ j-kd σ⇇Γ
          j/τ≅j/τ = kd-/⟨⟩≃-≅ j-kd τ⇇Γ
          j/σ≅j/τ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
          a/σ⇉l/σ = Nf⇉-/⟨⟩ a⇉l (⇇-H↑ j/σ≅j/σ σ⇇Γ)
          a/τ⇉l/τ = Nf⇉-/⟨⟩ a⇉l (⇇-H↑ j/τ≅j/τ τ⇇Γ)
          a/σ<:a/τ⇇l/σ = Nf⇉-/⟨⟩≃ a⇉l l-kd (≃-H↑ j/σ≅j/σ j/σ≅j/τ σ≃τ⇇Γ)
          Πjl/τ<∷Πjl/σ = kd-/⟨⟩≃-<∷ (kd-Π j-kd l-kd) τ≃σ⇇Γ
          Λja/σ⇇Πjl/σ = Nf⇉⇒Nf⇇ (⇉-Π-i j/σ-kd a/σ⇉l/σ)
          Λja/τ⇇Πjl/σ = ⇇-⇑ (⇉-Π-i j/τ-kd a/τ⇉l/τ) Πjl/τ<∷Πjl/σ
      in <:-λ a/σ<:a/τ⇇l/σ Λja/σ⇇Πjl/σ Λja/τ⇇Πjl/σ

    -- Equal hereditary substitutions map proper neutrals to subtypes.
    Ne∈-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a b c} →
               Γ ⊢Ne a ∈ b ⋯ c → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ
    Ne∈-/⟨⟩≃ (∈-∙ {x} x∈j j⇉as⇉b⋯c) σ≃τ⇇Γ =
      let j-kds = kd-kds (Var∈-valid x∈j)
      in Var∈-/⟨⟩≃-⇑-?∙∙ x∈j σ≃τ⇇Γ ≤-refl (Sp⇉-/⟨⟩≃ j-kds j⇉as⇉b⋯c σ≃τ⇇Γ)

    Var∈-/⟨⟩≃-⇑-?∙∙ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {x j l as bs b c} →
                      Γ ⊢Var x ∈ j → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                      Δ ⊢ kd j Asc/⟨ k ⟩ σ ≤ kd l → Δ ⊢ l ⇉∙ as ≃ bs ⇉ b ⋯ c →
                      Δ ⊢ lookupSV σ x ?∙∙⟨ k ⟩ as <: lookupSV τ x ?∙∙⟨ k ⟩ bs
    Var∈-/⟨⟩≃-⇑-?∙∙ (⇉-var x _ Γ[x]≡kd-j) σ≃τ⇇Γ j/σ≤l l⇉as≃bs⇉b⋯c =
      ?≃-⇑-?∙∙ (subst (_ ⊢?⟨ _ ⟩ _ ≃ _ ⇇_) (cong (_Asc/⟨ _ ⟩ _) Γ[x]≡kd-j)
                      (lookup-/⟨⟩≃ σ≃τ⇇Γ x))
               j/σ≤l l⇉as≃bs⇉b⋯c
    Var∈-/⟨⟩≃-⇑-?∙∙ (⇇-⇑ x∈j₁ j₁<∷j₂ j₂-kd) σ≃τ⇇Γ j₂/σ≤l l⇉as≃bs⇉b⋯c =
      let σ⇇Γ       = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          j₁/σ≤j₂/σ = ≤-<∷ (<∷-/⟨⟩≃ j₁<∷j₂ σ⇇Γ) (kd-/⟨⟩ j₂-kd σ⇇Γ)
      in Var∈-/⟨⟩≃-⇑-?∙∙ x∈j₁ σ≃τ⇇Γ (≤-trans j₁/σ≤j₂/σ j₂/σ≤l) l⇉as≃bs⇉b⋯c

    -- Equal hereditary substitutions map spines to spine identities.
    Sp⇉-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {as j₁ j₂} →
               ⌊ Γ ⌋Ctx ⊢ j₁ kds → Γ ⊢ j₁ ⇉∙ as ⇉ j₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ j₁ Kind/⟨ k ⟩ σ ⇉∙ as //⟨ k ⟩ σ ≃
                                      as //⟨ k ⟩ τ ⇉ j₂ Kind/⟨ k ⟩ σ
    Sp⇉-/⟨⟩≃ _ ⇉-[] σ⇇Γ = ≃-[]
    Sp⇉-/⟨⟩≃ {k} (kds-Π j₁-kds j₂-kds)
             (⇉-∷ {a} {_} {j₁} {j₂} a⇇j₁ j₁-kd j₂[a]⇉as⇉j₃) σ⇇Γ =
      ≃-∷ (Nf⇇-/⟨⟩≃-≃ a⇇j₁ j₁-kd σ⇇Γ)
          (subst (_ ⊢_⇉∙ _ ≃ _ ⇉ _) j₂[a]/σ≡j₂/σ[a/σ]
                 (Sp⇉-/⟨⟩≃ (kds-/⟨⟩ j₂-kds (∈-hsub a∈⌊j₁⌋)) j₂[a]⇉as⇉j₃ σ⇇Γ))
      where
        a∈⌊j₁⌋ = Nf⇇-Nf∈ a⇇j₁

        j₂[a]/σ≡j₂/σ[a/σ] = begin
            j₂ Kind[ a ∈ ⌊ j₁ ⌋ ] Kind/⟨ k ⟩ _
          ≡⟨ kds-[]-/⟨⟩-↑⋆ [] j₂-kds a∈⌊j₁⌋ (/⟨⟩⇇-/⟨⟩∈ (/⟨⟩≃-valid₁ σ⇇Γ)) ⟩
            j₂ Kind/⟨ k ⟩ _ ↑ Kind/⟨ ⌊ j₁ ⌋ ⟩ sub (a /⟨ k ⟩ _)
          ≡⟨ cong (_ Kind[ a /⟨ k ⟩ _ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j₁)) ⟩
            (j₂ Kind/⟨ k ⟩ _ ↑) Kind[ a /⟨ k ⟩ _ ∈ ⌊ j₁ Kind/⟨ k ⟩ _ ⌋ ]
          ∎

    -- Equal hereditary substitutions map checked normal forms to
    -- subtypes.
    Nf⇇-/⟨⟩≃-<: : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a j} →
                  Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                  Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇇-/⟨⟩≃-<: (⇇-⇑ a⇉b₁⋯c₁ (<∷-⋯ b₂<:b₁ c₁<:c₂)) _ σ≃τ⇇Γ =
      let σ⇇Γ   = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ   = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
      in <:-⇇ (⇇-⇑ (Nf⇉-/⟨⟩ a⇉b₁⋯c₁ σ⇇Γ) (<∷-/⟨⟩≃ (<∷-⋯ b₂<:b₁ c₁<:c₂) σ⇇Γ))
              (⇇-⇑ (Nf⇉-/⟨⟩ a⇉b₁⋯c₁ τ⇇Γ) (<∷-/⟨⟩≃ (<∷-⋯ b₂<:b₁ c₁<:c₂) τ≃σ⇇Γ))
              (Nf⇉-⋯-/⟨⟩≃ a⇉b₁⋯c₁ σ≃τ⇇Γ)
    Nf⇇-/⟨⟩≃-<: (⇇-⇑ a⇉Πj₁l₁ (<∷-Π j₂<∷j₁ l₁<∷l₂ Πj₁l₁-kd)) Πj₂k₂-kd σ≃τ⇇Γ =
      let σ⇇Γ = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          Πj₁l₁/σ<∷Πj₂l₂/σ = <∷-/⟨⟩≃ (<∷-Π j₂<∷j₁ l₁<∷l₂ Πj₁l₁-kd) σ⇇Γ
          Πj₂l₂/σ-kd       = kd-/⟨⟩ Πj₂k₂-kd σ⇇Γ
      in <:⇇-⇑ (Nf⇉-/⟨⟩≃ a⇉Πj₁l₁ Πj₁l₁-kd σ≃τ⇇Γ) Πj₁l₁/σ<∷Πj₂l₂/σ Πj₂l₂/σ-kd

    -- Equal hereditary substitutions map checked normal forms to type
    -- identities.
    Nf⇇-/⟨⟩≃-≃ : ∀ {m n Γ k Δ} {σ τ : SVSub m n} {a j} →
                 Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ a /⟨ k ⟩ σ ≃ a /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇇-/⟨⟩≃-≃ a⇇k k-kd σ≃τ⇇Γ =
      let τ≃σ⇇Γ  = /⟨⟩≃-sym σ≃τ⇇Γ
          k/σ-kd = kd-/⟨⟩ k-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ)
      in <:-antisym k/σ-kd (Nf⇇-/⟨⟩≃-<: a⇇k k-kd σ≃τ⇇Γ)
                    (<:⇇-⇑ (Nf⇇-/⟨⟩≃-<: a⇇k k-kd τ≃σ⇇Γ)
                    (kd-/⟨⟩≃-<∷ k-kd τ≃σ⇇Γ) k/σ-kd)

    -- Equal hereditary substitutions preserve subkinding.
    <∷-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {j₁ j₂} →
              Γ ⊢ j₁ <∷ j₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
              Δ ⊢ j₁ Kind/⟨ k ⟩ σ <∷ j₂ Kind/⟨ k ⟩ τ
    <∷-/⟨⟩≃ (<∷-⋯ a₂<:a₁ b₁<:b₂) σ≃τ⇇Γ =
      <∷-⋯ (<:-/⟨⟩≃ a₂<:a₁ (/⟨⟩≃-sym σ≃τ⇇Γ)) (<:-/⟨⟩≃ b₁<:b₂ σ≃τ⇇Γ)
    <∷-/⟨⟩≃ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          τ≃τ⇇Γ = /⟨⟩≃-valid₂ σ≃τ⇇Γ
      in <∷-Π (<∷-/⟨⟩≃ j₂<∷j₁ (/⟨⟩≃-sym σ≃τ⇇Γ))
              (<∷-/⟨⟩≃ k₁<∷k₂ (≃-H↑ (<∷-/⟨⟩≃-wf k₁<∷k₂ τ≃σ⇇Γ)
                                    (<∷-/⟨⟩≃-wf k₁<∷k₂ τ≃τ⇇Γ) σ≃τ⇇Γ))
              (kd-/⟨⟩ Πj₁k₁-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ))

    -- Equal hereditary substitutions preserve subtyping.

    <:-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a₁ a₂} →
              Γ ⊢ a₁ <: a₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
              Δ ⊢ a₁ /⟨ k ⟩ σ <: a₂ /⟨ k ⟩ τ
    <:-/⟨⟩≃ (<:-trans a<:b b<:c) σ≃τ⇇Γ =
      <:-trans (<:-/⟨⟩≃ a<:b (/⟨⟩≃-valid₁ σ≃τ⇇Γ)) (<:-/⟨⟩≃ b<:c σ≃τ⇇Γ)
    <:-/⟨⟩≃ (<:-⊥ a⇉a⋯a) σ≃τ⇇Γ = <:-⊥ (Nf⇉-/⟨⟩ a⇉a⋯a (/⟨⟩≃-valid₂ σ≃τ⇇Γ))
    <:-/⟨⟩≃ (<:-⊤ a⇉a⋯a) σ≃τ⇇Γ = <:-⊤ (Nf⇉-/⟨⟩ a⇉a⋯a (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
    <:-/⟨⟩≃ (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          τ≃τ⇇Γ = /⟨⟩≃-valid₂ σ≃τ⇇Γ
      in <:-∀ (<∷-/⟨⟩≃ k₂<∷k₁ τ≃σ⇇Γ)
              (<:-/⟨⟩≃ a₁<:a₂ (≃-H↑ (<:-/⟨⟩≃-wf a₁<:a₂ τ≃σ⇇Γ)
                                    (<:-/⟨⟩≃-wf a₁<:a₂ τ≃τ⇇Γ) σ≃τ⇇Γ))
         (Nf⇉-/⟨⟩ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁ (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
    <:-/⟨⟩≃ (<:-→ a₂<:a₁ b₁<:b₂) σ≃τ⇇Γ =
      <:-→ (<:-/⟨⟩≃ a₂<:a₁ (/⟨⟩≃-sym σ≃τ⇇Γ)) (<:-/⟨⟩≃ b₁<:b₂ σ≃τ⇇Γ)
    <:-/⟨⟩≃ {σ = σ} (<:-∙ {x} x∈j j⇉as≃bs⇉c⋯d) σ≃τ⇇Γ =
      let j-kds = kd-kds (Var∈-valid x∈j)
      in Var∈-/⟨⟩≃-⇑-?∙∙ x∈j σ≃τ⇇Γ ≤-refl (Sp≃-/⟨⟩≃ j-kds j⇉as≃bs⇉c⋯d σ≃τ⇇Γ)
    <:-/⟨⟩≃ (<:-⟨| a∈b⋯c) σ≃τ⇇Γ =
      let a/σ⇉b/σ⋯c/σ = Ne∈-/⟨⟩ a∈b⋯c (/⟨⟩≃-valid₁ σ≃τ⇇Γ)
      in <:-trans (<:-⟨|-Nf⇇ a/σ⇉b/σ⋯c/σ) (Ne∈-/⟨⟩≃ a∈b⋯c σ≃τ⇇Γ)
    <:-/⟨⟩≃ (<:-|⟩ a∈b⋯c) σ≃τ⇇Γ =
      let a/τ⇉b/τ⋯c/τ = Ne∈-/⟨⟩ a∈b⋯c (/⟨⟩≃-valid₂ σ≃τ⇇Γ)
      in <:-trans (Ne∈-/⟨⟩≃ a∈b⋯c σ≃τ⇇Γ) (<:-|⟩-Nf⇇ a/τ⇉b/τ⋯c/τ)

    <:⇇-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a₁ a₂ j} →
               Γ ⊢ a₁ <: a₂ ⇇ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ a₁ /⟨ k ⟩ σ <: a₂ /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    <:⇇-/⟨⟩≃ (<:-⇇ a₁⇇b⋯c a₂⇇b⋯c a₁<:a₂) b⋯c-kd σ≃τ⇇Γ =
      let σ⇇Γ     = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ     = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ   = /⟨⟩≃-sym σ≃τ⇇Γ
      in <:-⇇ (Nf⇇-/⟨⟩ a₁⇇b⋯c σ⇇Γ)
              (Nf⇇-⇑ (Nf⇇-/⟨⟩ a₂⇇b⋯c τ⇇Γ) (kd-/⟨⟩≃-<∷ b⋯c-kd τ≃σ⇇Γ))
              (<:-/⟨⟩≃ a₁<:a₂ σ≃τ⇇Γ)
    <:⇇-/⟨⟩≃ (<:-λ a₁<:a₂⇇l Λj₁a₁⇇Πjl Λj₂a₂⇇Πjl) (kd-Π j-kd l-kd) σ≃τ⇇Γ =
      let σ⇇Γ     = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ     = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ   = /⟨⟩≃-sym σ≃τ⇇Γ
          j/σ≅j/σ = kd-/⟨⟩≃-≅ j-kd σ⇇Γ
          j/σ≅j/τ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
      in <:-λ (<:⇇-/⟨⟩≃ a₁<:a₂⇇l l-kd (≃-H↑ j/σ≅j/σ j/σ≅j/τ σ≃τ⇇Γ))
              (Nf⇇-/⟨⟩ Λj₁a₁⇇Πjl σ⇇Γ)
              (Nf⇇-⇑ (Nf⇇-/⟨⟩ Λj₂a₂⇇Πjl τ⇇Γ) (kd-/⟨⟩≃-<∷ (kd-Π j-kd l-kd) τ≃σ⇇Γ))

    -- Equal hereditary substitutions preserve spine equality.
    Sp≃-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {as₁ as₂ j₁ j₂} →
               ⌊ Γ ⌋Ctx ⊢ j₁ kds →
               Γ ⊢ j₁ ⇉∙ as₁ ≃ as₂ ⇉ j₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ j₁ Kind/⟨ k ⟩ σ ⇉∙ as₁ //⟨ k ⟩ σ ≃
                                      as₂ //⟨ k ⟩ τ ⇉ j₂ Kind/⟨ k ⟩ σ
    Sp≃-/⟨⟩≃ _ ≃-[] σ≃τ⇇Γ = ≃-[]
    Sp≃-/⟨⟩≃ {k} (kds-Π j₁-kds j₂-kds)
             (≃-∷ {a} {j = j₁} {j₂} a≃b as≃bs) σ≃τ⇇Γ =
      let a∈⌊j₁⌋            = Nf⇇-Nf∈ (proj₁ (≃-valid a≃b))
          j₂[a]/σ≡j₂/σ[a/σ] = begin
              j₂ Kind[ a ∈ ⌊ j₁ ⌋ ] Kind/⟨ k ⟩ _
            ≡⟨ kds-[]-/⟨⟩-↑⋆ [] j₂-kds a∈⌊j₁⌋ (/⟨⟩⇇-/⟨⟩∈ (/⟨⟩≃-valid₁ σ≃τ⇇Γ)) ⟩
              j₂ Kind/⟨ k ⟩ _ ↑ Kind/⟨ ⌊ j₁ ⌋ ⟩ sub (a /⟨ k ⟩ _)
            ≡⟨ cong (_ Kind[ a /⟨ k ⟩ _ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j₁)) ⟩
              (j₂ Kind/⟨ k ⟩ _ ↑) Kind[ a /⟨ k ⟩ _ ∈ ⌊ j₁ Kind/⟨ k ⟩ _ ⌋ ]
            ∎
      in ≃-∷ (≃-/⟨⟩≃ a≃b σ≃τ⇇Γ)
             (subst (_ ⊢_⇉∙ _ ≃ _ ⇉ _) j₂[a]/σ≡j₂/σ[a/σ]
                    (Sp≃-/⟨⟩≃ (kds-/⟨⟩ j₂-kds (∈-hsub a∈⌊j₁⌋)) as≃bs σ≃τ⇇Γ))

    -- Equal hereditary substitutions preserve type equality.
    ≃-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a₁ a₂ j} →
             Γ ⊢ a₁ ≃ a₂ ⇇ j → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
             Δ ⊢ a₁ /⟨ k ⟩ σ ≃ a₂ /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    ≃-/⟨⟩≃ (<:-antisym k-kd a<:b⇇k b<:a⇇k) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          k/σ-kd = kd-/⟨⟩ k-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ)
      in <:-antisym k/σ-kd (<:⇇-/⟨⟩≃ a<:b⇇k k-kd σ≃τ⇇Γ)
                    (<:⇇-⇑ (<:⇇-/⟨⟩≃ b<:a⇇k k-kd τ≃σ⇇Γ)
                           (kd-/⟨⟩≃-<∷ k-kd τ≃σ⇇Γ) k/σ-kd)

    -- Applications in canonical kind checking are admissible.
    --
    -- NOTE. In the ?⇇-⇑-?∙∙ lemma, the second result r₂ is ignored.
    -- See the comment above on /⟨⟩⇇-/⟨⟩∈ for an explanation.

    ?⇇-⇑-?∙∙ : ∀ {k n} {Γ : Ctx n} {r₁ r₂ a j as b c} →
               Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ a → Γ ⊢ a ≤ kd j →
               Γ ⊢ j ⇉∙ as ⇉ b ⋯ c → Γ ⊢Nf r₁ ?∙∙⟨ k ⟩ as ⇇ b ⋯ c
    ?⇇-⇑-?∙∙ (≃-hit a≃a⇇j ⌊j⌋≡k) j≤l l⇉as⇉b⋯c =
      Nf⇇-∙∙ (Nf⇇-⇑-≤ (proj₁ (≃-valid a≃a⇇j)) j≤l) l⇉as⇉b⋯c
             (⌊⌋≡-trans (sym (≤-⌊⌋ j≤l)) ⌊j⌋≡k)
    ?⇇-⇑-?∙∙ (≃-miss y Γ-ctx Γ[y]≡a₁ a₁≤a₂) a₂≤l l⇉as⇉b⋯c =
      Nf⇇-ne (∈-∙ (Var∈-⇑-≤ y Γ-ctx Γ[y]≡a₁ (≤-trans a₁≤a₂ a₂≤l)) l⇉as⇉b⋯c)

    Nf⇇-∙∙ : ∀ {n} {Γ : Ctx n} {a as j₁ j₂ k} →
             Γ ⊢Nf a ⇇ j₁ → Γ ⊢ j₁ ⇉∙ as ⇉ j₂ → ⌊ j₁ ⌋≡ k →
             Γ ⊢Nf a ∙∙⟨ k ⟩ as ⇇ j₂
    Nf⇇-∙∙ a⇇j₁ ⇉-[] ⌊j₁⌋≡k = a⇇j₁
    Nf⇇-∙∙ a⇇Πj₁j₂ (⇉-∷ b⇇j₁ j₁-kd j₂[b]⇉as⇉j₃) (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) =
      Nf⇇-∙∙ (Nf⇇-Π-e a⇇Πj₁j₂ b⇇j₁ j₁-kd (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂))
             j₂[b]⇉as⇉j₃ (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)

    Nf⇇-Π-e : ∀ {n} {Γ : Ctx n} {a b j₁ j₂ k} →
              Γ ⊢Nf a ⇇ Π j₁ j₂ → Γ ⊢Nf b ⇇ j₁ → Γ ⊢ j₁ kd →
              ⌊ Π j₁ j₂ ⌋≡ k → Γ ⊢Nf a ⌜·⌝⟨ k ⟩ b ⇇ j₂ Kind[ b ∈ ⌊ j₁ ⌋ ]
    Nf⇇-Π-e {_} {Γ} {_} {b}
            (⇇-⇑ (⇉-Π-i j₁-kd a⇉l₁)
            (<∷-Π {j₁} {j₂} {l₁} {l₂} j₂<∷j₁ l₁<∷l₂ Πj₁l₁-kd))
            b⇇j₂ j₂-kd (is-⇒ {_} {_} {k₁} ⌊j₂⌋≡k₁ ⌊l₂⌋≡k₂) =
      let σ⇇j₂∷Γ = ⇇-hsub b⇇j₂ j₂-kd ⌊j₂⌋≡k₁
      in ⇇-⇑ (Nf⇉-/⟨⟩ (⇓-Nf⇉ j₂-kd j₂<∷j₁ a⇉l₁) σ⇇j₂∷Γ)
             (subst (λ k → Γ ⊢ l₁ Kind[ b ∈ k₁ ] <∷ l₂ Kind[ b ∈ k ])
                    (sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₂⌋≡k₁))
                    (<∷-/⟨⟩≃ l₁<∷l₂ σ⇇j₂∷Γ))

    -- Applications in checked type equality are admissible.

    ?≃-⇑-?∙∙ : ∀ {k n} {Γ : Ctx n} {r₁ r₂ a j as bs c d} →
               Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ a → Γ ⊢ a ≤ kd j →
               Γ ⊢ j ⇉∙ as ≃ bs ⇉ c ⋯ d →
               Γ ⊢ r₁ ?∙∙⟨ k ⟩ as <: r₂ ?∙∙⟨ k ⟩ bs
    ?≃-⇑-?∙∙ (≃-hit a≃b⇇j ⌊j⌋≡k) j≤l l⇉as≃bs⇉c⋯d =
      ≃⇒<:-⋯ (≃-∙∙ (≃-⇑-≤ a≃b⇇j j≤l) l⇉as≃bs⇉c⋯d
                   (⌊⌋≡-trans (sym (≤-⌊⌋ j≤l)) ⌊j⌋≡k))
    ?≃-⇑-?∙∙ (≃-miss y Γ-ctx Γ[y]≡a₁ a₁≤a₂) a₂≤l l⇉as≃bs⇉c⋯d =
      <:-∙ (Var∈-⇑-≤ y Γ-ctx Γ[y]≡a₁ (≤-trans a₁≤a₂ a₂≤l)) l⇉as≃bs⇉c⋯d

    ≃-∙∙ : ∀ {n} {Γ : Ctx n} {a b as bs j₁ j₂ k} →
           Γ ⊢ a ≃ b ⇇ j₁ → Γ ⊢ j₁ ⇉∙ as ≃ bs ⇉ j₂ → ⌊ j₁ ⌋≡ k →
           Γ ⊢ a ∙∙⟨ k ⟩ as ≃ b ∙∙⟨ k ⟩ bs ⇇ j₂
    ≃-∙∙ a≃b⇇j₁ ≃-[] ⌊j₁⌋≡k = a≃b⇇j₁
    ≃-∙∙ a≃b⇇Πj₁j₂ (≃-∷ c≃d⇇j₁ j₂[b]⇉cs≃ds⇉j₃) (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) =
      ≃-∙∙ (≃-Π-e a≃b⇇Πj₁j₂ c≃d⇇j₁ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂))
           j₂[b]⇉cs≃ds⇉j₃ (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)

    ≃-Π-e : ∀ {n} {Γ : Ctx n} {a₁ a₂ b₁ b₂ j₁ j₂ k} →
            Γ ⊢ a₁ ≃ a₂ ⇇ Π j₁ j₂ → Γ ⊢ b₁ ≃ b₂ ⇇ j₁ → ⌊ Π j₁ j₂ ⌋≡ k →
            Γ ⊢ a₁ ⌜·⌝⟨ k ⟩ b₁ ≃ a₂ ⌜·⌝⟨ k ⟩ b₂ ⇇ j₂ Kind[ b₁ ∈ ⌊ j₁ ⌋ ]
    ≃-Π-e a₁≃a₂⇇Πj₁j₂ b₁≃b₂⇇j₂ (is-⇒ ⌊j₂⌋≡k₁ ⌊j₂⌋≡k₂) with ≃-Π-can a₁≃a₂⇇Πj₁j₂
    ≃-Π-e {_} {Γ} {_} {_} {b₁} {b₂} Λl₁a₁≃Λl₂a₂⇇Πj₁j₂ b₁≃b₂⇇j₁
          (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂)
      | l₁ , a₁ , l₂ , a₂ , Λl₁a₁⇇Πj₁j₂ , Λl₂a₂⇇Πj₁j₂ , kd-Π j₁-kd j₂-kd ,
        j₁<∷l₁ , l₁≅l₂ , a₁<:a₂⇇j₂ , a₂<:a₁⇇j₂ , refl , refl =
        let ⌊Πj₁j₂⌋≡k     = is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂
            k₁≡⌊j₁⌋       = sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₁⌋≡k₁)
            b₁⇇j₁ , b₂⇇j₁ = ≃-valid b₁≃b₂⇇j₁
            σ≃τ⇇j₁∷Γ      = ≃-hsub b₁≃b₂⇇j₁ ⌊j₁⌋≡k₁
            τ≃σ⇇j₁∷Γ      = /⟨⟩≃-sym σ≃τ⇇j₁∷Γ
            σ⇇j₁∷Γ        = /⟨⟩≃-valid₁ σ≃τ⇇j₁∷Γ
        in <:-antisym (subst (λ k → _ ⊢ _ Kind[ _ ∈ k ] kd)
                             (sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₁⌋≡k₁))
                             (kd-/⟨⟩ j₂-kd (/⟨⟩≃-valid₁ σ≃τ⇇j₁∷Γ)))
                      (subst (λ k → _ ⊢ _ <: _ ⇇ _ Kind[ _ ∈ k ]) k₁≡⌊j₁⌋
                             (<:⇇-/⟨⟩≃ a₁<:a₂⇇j₂ j₂-kd σ≃τ⇇j₁∷Γ))
                      (<:⇇-⇑ (<:⇇-/⟨⟩≃ a₂<:a₁⇇j₂ j₂-kd τ≃σ⇇j₁∷Γ)
                             (subst (λ k → Γ ⊢ _ <∷ _ Kind[ _ ∈ k ]) k₁≡⌊j₁⌋
                                    (kd-/⟨⟩≃-<∷ j₂-kd τ≃σ⇇j₁∷Γ))
                             (subst (λ k → Γ ⊢ _ Kind[ _ ∈ k ] kd) k₁≡⌊j₁⌋
                                    (kd-/⟨⟩ j₂-kd σ⇇j₁∷Γ)))

    -- Helpers (to satisfy the termination checker).
    --
    -- These are simply (manual) expansions of the form
    --
    --   XX-/⟨⟩≃-wf x σ≃τ⇇Γ  =  kd-/⟨⟩≃-≅ (wf-kd-inv (wf-∷₁ (XX-ctx x))) σ≃τ⇇Γ
    --
    -- to ensure the above definitions remain structurally recursive
    -- in the various derivations.

    kd-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j k} →
                 kd j ∷ Γ ⊢ k kd → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    kd-/⟨⟩≃-wf (kd-⋯ a⇉a⋯a _) σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    kd-/⟨⟩≃-wf (kd-Π j-kd _)  σ≃τ⇇Γ = kd-/⟨⟩≃-wf j-kd σ≃τ⇇Γ

    Nf⇉-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a k} →
                  kd j ∷ Γ ⊢Nf a ⇉ k → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                  Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    Nf⇉-/⟨⟩≃-wf (⇉-⊥-f (wf-kd j-kd ∷ Γ-ctx)) σ≃τ⇇Γ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-⊤-f (wf-kd j-kd ∷ Γ-ctx)) σ≃τ⇇Γ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-∀-f k-kd _)               σ≃τ⇇Γ = kd-/⟨⟩≃-wf k-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-→-f a⇉a⋯a _)              σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-Π-i j-kd _)               σ≃τ⇇Γ = kd-/⟨⟩≃-wf j-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-s-i a∈b⋯c)                σ≃τ⇇Γ = Ne∈-/⟨⟩≃-wf a∈b⋯c σ≃τ⇇Γ

    Ne∈-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a k} →
                  kd j ∷ Γ ⊢Ne a ∈ k → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                  Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    Ne∈-/⟨⟩≃-wf (∈-∙ x∈k _) σ≃τ⇇Γ = Var∈-/⟨⟩≃-wf x∈k σ≃τ⇇Γ

    Var∈-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a k} →
                   kd j ∷ Γ ⊢Var a ∈ k → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                   Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    Var∈-/⟨⟩≃-wf (⇉-var x (wf-kd j-kd ∷ Γ-ctx) _) σ≃τ⇇Γ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
    Var∈-/⟨⟩≃-wf (⇇-⇑ x∈k _ _)                    σ≃τ⇇Γ = Var∈-/⟨⟩≃-wf x∈k σ≃τ⇇Γ

    <∷-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j k₁ k₂} →
                 kd j ∷ Γ ⊢ k₁ <∷ k₂ → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    <∷-/⟨⟩≃-wf (<∷-⋯ a₂<:a₁ _)   σ≃τ⇇Γ = <:-/⟨⟩≃-wf a₂<:a₁ σ≃τ⇇Γ
    <∷-/⟨⟩≃-wf (<∷-Π j₁<∷j₂ _ _) σ≃τ⇇Γ = <∷-/⟨⟩≃-wf j₁<∷j₂ σ≃τ⇇Γ

    <:-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a₁ a₂} →
                kd j ∷ Γ ⊢ a₁ <: a₂ → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    <:-/⟨⟩≃-wf (<:-trans a<:b _) σ≃τ⇇Γ = <:-/⟨⟩≃-wf a<:b σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-⊥ a⇉a⋯a)      σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-⊤ a⇉a⋯a)      σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-∀ k₂<∷k₁ _ _) σ≃τ⇇Γ = <∷-/⟨⟩≃-wf k₂<∷k₁ σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-→ a₂<:a₁ _)   σ≃τ⇇Γ = <:-/⟨⟩≃-wf a₂<:a₁ σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-∙ x∈j _)      σ≃τ⇇Γ = Var∈-/⟨⟩≃-wf x∈j σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-⟨| a∈b⋯c)     σ≃τ⇇Γ = Ne∈-/⟨⟩≃-wf a∈b⋯c σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-|⟩ a∈b⋯c)     σ≃τ⇇Γ = Ne∈-/⟨⟩≃-wf a∈b⋯c σ≃τ⇇Γ

  -- Equal hereditary substitutions preserve kind equality.
  ≅-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {k₁ k₂} →
           Γ ⊢ k₁ ≅ k₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
           Δ ⊢ k₁ Kind/⟨ k ⟩ σ ≅ k₂ Kind/⟨ k ⟩ τ
  ≅-/⟨⟩≃ (<∷-antisym j-kd k-kd j<∷k k<∷j) σ≃τ⇇Γ =
    <∷-antisym (kd-/⟨⟩ j-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
               (kd-/⟨⟩ k-kd (/⟨⟩≃-valid₂ σ≃τ⇇Γ))
               (<∷-/⟨⟩≃ j<∷k σ≃τ⇇Γ) (<∷-/⟨⟩≃ k<∷j (/⟨⟩≃-sym σ≃τ⇇Γ))


-- Syntactic kits from Conor McBride's
-- "Type-Preserving Renaming and Substitution"
module Syntax.Substitution.Kits where

open import Syntax.Types
open import Syntax.Context
open import Syntax.Terms

open import CategoryTheory.Categories

open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym)

-- Type of entities that we can traverse
-- (instantiated by variables and types)
Schema : Set₁
Schema = Context -> Judgement -> Set

-- Explicit substitution from term in context Δ to term in context Γ
-- E.g. from Γ ⌊ A ⌋ Γ′ ⊢ N : B to Γ ⌊⌋ Γ′ ⊢ N[σ] : B
-- using substitution Γ ⌊⌋ Γ′ ⊢ σ : Γ ⌊ A ⌋ Γ′
data Subst (𝒮 : Schema) : Context -> Context -> Set where
    -- Empty substitution
    ●   : ∀ {Δ}     -> Subst 𝒮 ∙ Δ
    -- Extending the domain of a substitution
    _▸_ : ∀ {A Γ Δ} -> (σ : Subst 𝒮 Γ Δ) -> (T : 𝒮 Δ A) -> Subst 𝒮 (Γ , A) Δ

-- Syntactic kit grouping together common operations on traversable
-- syntactic entities such as variables and terms
record Kit (𝒮 : Schema) : Set where
    field
        -- Convert a variable to the entity
        𝓋 : ∀ {Γ A} -> A ∈ Γ -> 𝒮 Γ A
        -- Convert the entity to a term
        𝓉 : ∀ {Γ A} -> 𝒮 Γ A -> Γ ⊢ A
        -- Weaken the entity
        𝓌 : ∀ {B Γ A} -> 𝒮 Γ A -> 𝒮 (Γ , B) A
        -- Stabilise the context of the entity
        𝒶 : ∀ {Γ A} -> 𝒮 Γ (A always) -> 𝒮 (Γ ˢ) (A always)

-- Substitutable kit
record SubstKit (𝒮 : Schema) : Set where
    field
        -- Underlying traversable kit
        𝓀 : Kit 𝒮
        -- Apply substitution to a kit
        𝓈 : ∀ {Γ Δ A} -> Subst 𝒮 Γ Δ -> 𝒮 Γ A -> 𝒮 Δ A

open Kit

-- | Combinators
-- | All take a syntactic (substitutable) kit as an argument
-- | which provides the necessary operations

-- Weakening a substitution
-- Δ ⊢ σ : Γ to (Δ , A) ⊢ σ : Γ
_⁺_ : ∀ {A 𝒮 Γ Δ} -> Subst 𝒮 Γ Δ -> Kit 𝒮 -> Subst 𝒮 Γ (Δ , A)
●       ⁺ _ = ●
(σ ▸ T) ⁺ k = (σ ⁺ k) ▸ 𝓌 k T
infixl 40 _⁺_

-- Lifting a substitution
-- Δ ⊢ σ : Γ to (Δ , A) ⊢ σ : (Γ , A)
_↑_ : ∀ {A 𝒮 Γ Δ} -> Subst 𝒮 Γ Δ -> Kit 𝒮 -> Subst 𝒮 (Γ , A) (Δ , A)
σ ↑ k = (σ ⁺ k) ▸ 𝓋 k top
infixl 40 _↑_

-- Stabilising a substitution
-- Δ ⊢ σ : Γ to Δ ˢ ⊢ σ : Γ ˢ
_↓ˢ_ : ∀ {𝒮 Γ Δ} -> Subst 𝒮 Γ Δ -> Kit 𝒮 -> Subst 𝒮 (Γ ˢ) (Δ ˢ)
●                    ↓ˢ _ = ●
(_▸_ {A now} σ T)    ↓ˢ k = σ ↓ˢ k
(_▸_ {A always} σ T) ↓ˢ k = (σ ↓ˢ k) ▸ 𝒶 k T
infixl 40 _↓ˢ_

-- Identity substitution
idₛ : ∀ {Γ 𝒮} -> Kit 𝒮 -> Subst 𝒮 Γ Γ
idₛ {∙}     k = ●
idₛ {Γ , _} k = idₛ k ↑ k

-- Composition of substitutions
_∘[_]ₛ_ : ∀ {𝒮 Γ Δ Ξ} -> Subst 𝒮 Δ Ξ -> SubstKit 𝒮 -> Subst 𝒮 Γ Δ -> Subst 𝒮 Γ Ξ
σ₂ ∘[ k ]ₛ ●        = ●
σ₂ ∘[ k ]ₛ (σ₁ ▸ T) = (σ₂ ∘[ k ]ₛ σ₁) ▸ SubstKit.𝓈 k σ₂ T

-- Substitution from an order-preserving embedding
-- Γ ⊆ Δ to Δ ⊢ σ : Γ
_⊆ₛ_ : ∀ {𝒮 Γ Δ} -> Γ ⊆ Δ -> Kit 𝒮 -> Subst 𝒮 Γ Δ
refl ⊆ₛ k     = idₛ k
(keep s) ⊆ₛ k = (s ⊆ₛ k) ↑ k
(drop s) ⊆ₛ k = (s ⊆ₛ k) ⁺ k

-- Substitution from propositional equality of contexts
_≡ₛ_ : ∀ {𝒮 Γ Δ} -> Γ ≡ Δ -> Kit 𝒮 -> Subst 𝒮 Γ Δ
refl ≡ₛ k = idₛ k

-- Substitution from idempotence of stabilisation
_ˢˢₛ_ : ∀ {𝒮} -> (Γ : Context) -> Kit 𝒮 -> Subst 𝒮 (Γ ˢ) (Γ ˢ ˢ)
∙ ˢˢₛ k = ●
(Γ , A now) ˢˢₛ k = Γ ˢˢₛ k
(Γ , A always) ˢˢₛ k = (Γ ˢˢₛ k) ↑ k

-- | Standard substitutions
-- | Common transformations between contexts

module _ {𝒮 : Schema} (sk : SubstKit 𝒮) where
    open SubstKit sk
    open Kit 𝓀

    -- | Weakening

    -- Weakening the top of the context
    weak-topₛ : ∀{A Γ} -> Subst 𝒮 Γ (Γ , A)
    weak-topₛ = idₛ 𝓀 ⁺ 𝓀

    -- Weakening the middle of the context
    weak-midₛ : ∀{A} Γ Γ′ -> Subst 𝒮 (Γ ⌊⌋ Γ′) (Γ ⌊ A ⌋ Γ′)
    weak-midₛ Γ ∙ = weak-topₛ
    weak-midₛ Γ (Γ′ , B) = weak-midₛ Γ Γ′ ↑ 𝓀

    -- General weakening from an OPE
    weakₛ : ∀{Γ Δ} -> Γ ⊆ Δ -> Subst 𝒮 Γ Δ
    weakₛ = _⊆ₛ 𝓀

    -- | Exchange

    -- Exchange on top
    ex-topₛ : ∀{A B} Γ -> Subst 𝒮 (Γ , A , B) (Γ , B , A)
    ex-topₛ Γ = (idₛ 𝓀 ⁺ 𝓀 ↑ 𝓀) ▸ (𝓋 𝓀 (pop top))

    -- General exchange lemma
    exₛ : ∀{A B} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊ B ⌋ Γ″) (Γ ⌊ B ⌋ Γ′ ⌊ A ⌋ Γ″)
    exₛ Γ ∙ ∙ = ex-topₛ Γ
    exₛ {A} {B} Γ (Γ′ , C) ∙ =
        (exₛ Γ Γ′ [ A ] ∘[ sk ]ₛ ex-topₛ (Γ , C ⌊⌋ Γ′)) ∘[ sk ]ₛ exₛ Γ Γ′ [ B ]
    exₛ Γ ∙ (Γ″ , D) = exₛ Γ ∙ Γ″ ↑ 𝓀
    exₛ Γ (Γ′ , C) (Γ″ , D) = exₛ Γ (Γ′ , C) Γ″ ↑ 𝓀

    -- | Contraction

    -- Contraction on top
    contr-topₛ : ∀{A Γ} -> Subst 𝒮 (Γ , A , A) (Γ , A)
    contr-topₛ = (idₛ 𝓀) ▸ (𝓋 𝓀 top)

    -- General contraction lemma (left)
    contr-lₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″) (Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″)
    contr-lₛ Γ ∙ ∙ = contr-topₛ
    contr-lₛ Γ (Γ′ , B) ∙ = (idₛ 𝓀) ▸ (𝓌 𝓀 (𝓈 (contr-lₛ Γ Γ′ ∙) (𝓋 𝓀 top)))
    contr-lₛ Γ ∙ (Γ″ , C) = contr-lₛ Γ ∙ Γ″ ↑ 𝓀
    contr-lₛ Γ (Γ′ , B) (Γ″ , C) = contr-lₛ Γ (Γ′ , B) Γ″ ↑ 𝓀

    -- General contraction lemma (right)
    contr-rₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″) (Γ ⌊⌋ Γ′ ⌊ A ⌋ Γ″)
    contr-rₛ Γ ∙ ∙ = contr-topₛ
    contr-rₛ {A} Γ (Γ′ , B) ∙ =
        (ex-topₛ (Γ ⌊⌋ Γ′) ∘[ sk ]ₛ contr-rₛ Γ Γ′ [ B ]) ∘[ sk ]ₛ ex-topₛ (Γ , A ⌊⌋ Γ′)
    contr-rₛ Γ ∙ (Γ″ , C) = contr-rₛ Γ ∙ Γ″ ↑ 𝓀
    contr-rₛ Γ (Γ′ , B) (Γ″ , C) = contr-rₛ Γ (Γ′ , B) Γ″ ↑ 𝓀

    -- | Movement

    -- Moving a variable to the right in the context
    move-rₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″) (Γ ⌊⌋ Γ′ ⌊ A ⌋ Γ″)
    move-rₛ {A} Γ Γ′ Γ″ = contr-rₛ Γ Γ′ Γ″ ∘[ sk ]ₛ weak-midₛ (Γ ⌊ A ⌋ Γ′) Γ″

    -- Moving a variable to the left in the context
    -- Bit verbose as we have to deal with associativity
    move-lₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊⌋ Γ′ ⌊ A ⌋ Γ″) (Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″)
    move-lₛ {A} Γ Γ′ Γ″
        =        contr-lₛ Γ Γ′ Γ″
        ∘[ sk ]ₛ ((sym (⌊A⌋-assoc Γ Γ′ Γ″ A A) ≡ₛ 𝓀)
        ∘[ sk ]ₛ ((weak-midₛ {A} Γ (Γ′ ⌊ A ⌋ Γ″))
        ∘[ sk ]ₛ (⌊⌋-assoc Γ (Γ′ , A) Γ″ ≡ₛ 𝓀)))

    -- Moving a variable to the right in the stabilised context context
    moveˢ-rₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ˢ ⌊ A ⌋ (Γ′ ⌊⌋ Γ″) ˢ) ((Γ ⌊⌋ Γ′) ˢ ⌊ A ⌋ Γ″ ˢ)
    moveˢ-rₛ {A} Γ Γ′ Γ″
        rewrite ˢ-pres-⌊⌋ Γ Γ′
              | ˢ-pres-⌊⌋ Γ′ Γ″
              | sym (⌊⌋-assoc (Γ ˢ , A) (Γ′ ˢ) (Γ″ ˢ))
        = move-rₛ (Γ ˢ) (Γ′ ˢ) (Γ″ ˢ)

    -- | Substitution

    -- Substitution for the top of the context
    sub-topₛ : ∀{A Γ} -> 𝒮 Γ A -> Subst 𝒮 (Γ , A) Γ
    sub-topₛ T = (idₛ 𝓀) ▸ T

    -- Substitution for the top of a stabilised context
    sub-topˢₛ : ∀{Γ A} -> 𝒮 Γ A -> Subst 𝒮 (Γ ˢ , A) Γ
    sub-topˢₛ {Γ} T = (Γˢ⊆Γ Γ ⊆ₛ 𝓀) ▸ T

    -- Substitution for the middle of the context
    sub-midₛ : ∀{A} Γ Γ′ -> 𝒮 (Γ ⌊⌋ Γ′) A -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′) (Γ ⌊⌋ Γ′)
    sub-midₛ Γ Γ′ T = sub-topₛ T ∘[ sk ]ₛ move-rₛ Γ Γ′ ∙


module Prelude.Bot where

data Bot : Set where

magic : ∀{A : Set} -> Bot -> A
magic ()


module Issue1078.A where -- The typo in the module name is intended!

open import Common.Level using (Level)
open import Issue1078A

test = Level


module Monads.Except where

open import Class.Monad
open import Class.Monad.Except
open import Monads.ExceptT
open import Monads.Identity
open import Level

private
  variable
    a : Level
    A : Set a

Except : Set a -> Set a -> Set a
Except = ExceptT Id

instance
  Except-Monad : Monad (Except A)
  Except-Monad = ExceptT-Monad

  Except-MonadExcept : MonadExcept (Except A) A
  Except-MonadExcept = ExceptT-MonadExcept


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

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

open import LibraBFT.Base.Types
open import LibraBFT.Impl.Consensus.PersistentLivenessStorage
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.PersistentLivenessStorage.Properties where

module saveVoteMSpec (vote : Vote) where
  open OutputProps
  postulate -- TODO-2: refine and prove
    contract
      : ∀ P pre
        → (∀ outs → NoMsgs outs → NoErrors outs → P (inj₁ fakeErr) pre outs)
        → (∀ outs → NoMsgs outs → NoErrors outs
           → P (inj₂ unit) pre outs)
        → RWS-weakestPre (saveVoteM vote) P unit pre


{-#  OPTIONS --type-in-type #-}
module TooManyArgs where

open import AgdaPrelude

myFun : (a : Set) -> a -> a -> a
myFun a x y = x

myApp = myFun _ Zero Zero Zero Zero