{-# OPTIONS --safe #-}

module SafeFlagPostulate where

data Empty : Set where

postulate inhabitant : Empty


-- Andreas, 2015-03-17
-- Andreas, 2020-10-26 conform to Issue1428a

open import Agda.Builtin.Size

data ⊥ : Set where

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

-- This definition of size predecessor should be forbidden...
module _ (i : Size) where
  postulate
    pred : Size< i

-- ...otherwise the injectivity test loops here.
iter : ∀ i → SizeLt i → ⊥
iter i (wrap j) = iter j (wrap (pred j))

loop : Size → ⊥
loop i = iter i (wrap (pred i))

absurd : ⊥
absurd = FIXME loop ∞

-- Testcase temporarily mutilated, original error:
--
-- -Issue1428c.agda:...
-- -We don't like postulated sizes in parametrized modules.
--
-- +Issue1428c.agda:...
-- +Not in scope:
-- +  FIXME at Issue1428c.agda:...
-- +when scope checking FIXME


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

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

open import LibraBFT.Abstract.Types
open EpochConfig

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

open import LibraBFT.Concrete.System.Parameters

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

-- This module contains placeholders for the future analog of the
-- corresponding VotesOnce property.  Defining the implementation
-- obligation and proving that it is an invariant of an implementation
-- is a substantial undertaking.  We are working first on proving the
-- simpler VotesOnce property to settle down the structural aspects
-- before tackling the harder semantic issues.
module LibraBFT.Concrete.Properties.LockedRound where

 -- TODO-3: define the implementation obligation
 ImplObligation₁ : Set
 ImplObligation₁ = Unit

 -- Next, we prove that given the necessary obligations,
 module Proof
   (sps-corr : StepPeerState-AllValidParts)
   (Impl-LR1 : ImplObligation₁)
   where

  -- Any reachable state satisfies the LR rule for any epoch in the system.
  module _ {e}(st : SystemState e)(r : ReachableSystemState st)(eid : Fin e) where
   -- Bring in 'unwind', 'ext-unforgeability' and friends
   open Structural sps-corr

   -- Bring in ConcSystemState
   open import LibraBFT.Concrete.System sps-corr
   open PerState st r
   open PerEpoch eid

   open import LibraBFT.Abstract.Obligations.LockedRound 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔) as LR

   postulate  -- TODO-3: prove it
     lrr : LR.Type ConcSystemState


module UselessPrivatePrivate where

private
  private
    postulate
      A : Set


module par-swap.dpg-pot where

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym)
open import Data.Maybe using ()
open import Data.List.Any using (here ; there)
open import Data.List.Any.Properties using ( ++-comm ; ++⁻ ; ++⁺ˡ ; ++⁺ʳ )
open import Data.Nat as Nat using (ℕ)

open import par-swap
open import par-swap.properties

open import Esterel.Lang.CanFunction
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction.Plug
open import Esterel.Environment as Env
open import Esterel.Context

open import utility

open import sn-calculus
open import context-properties -- get view, E-views
open import sn-calculus-props

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.CompletionCode as Code
  using () renaming (CompletionCode to Code)

canₛ-par :
  ∀ r₁ r₂ -> ∀ (θ : Env) (S : ℕ) →
   S ∈ Canₛ (r₂ ∥ r₁) θ →
   S ∈ Canₛ (r₁ ∥ r₂) θ
canₛ-par r₁ r₂ θ S S∈r₂∥r₁
 = ++-comm (proj₁ (Can r₂ θ)) (proj₁ (Can r₁ θ)) S∈r₂∥r₁

canₖ-par :
  ∀ r₁ r₂ -> ∀ (θ : Env) (k : Code) →
    k ∈ Canₖ (r₂ ∥ r₁) θ →
    k ∈ Canₖ (r₁ ∥ r₂) θ
canₖ-par
 = \ {r₁ r₂ θ S S∈r₂∥r₁ ->
      thing S
      (proj₁ (proj₂ (Can r₁ θ)))
      (proj₁ (proj₂ (Can r₂ θ)))
      S∈r₂∥r₁}  where

 simplify-foldr++-[] : ∀ (l2 : List Code) ->
   (Data.List.foldr{A = (List Code)}
     _++_
     []
     (Data.List.map (λ (k : Code) → []) l2)) ≡ []
 simplify-foldr++-[] [] = refl
 simplify-foldr++-[] (x ∷ l2) = simplify-foldr++-[] l2

 whatevs-left : ∀ S (whatevs : Code -> Code) l1 l2 ->
   Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map (λ k → Data.List.map (Code._⊔_ k) l2) l1))
   ->
   Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map (λ k → (whatevs k) ∷ Data.List.map (Code._⊔_ k) l2) l1))
 whatevs-left S whatevs [] l2 ()
 whatevs-left S whatevs (x ∷ l1) l2 blob
  with ++⁻ (Data.List.map (Code._⊔_ x) l2) blob
 ... | inj₁ y = there (++⁺ˡ y)
 ... | inj₂ y
  with whatevs-left S whatevs l1 l2 y
 ... | R = there (++⁺ʳ (Data.List.map (Code._⊔_ x) l2)  R)

 whatevs-right :
   ∀ S (whatevs : Code -> List Code) x l1 ->
   Data.List.Any.Any (_≡_ S) (Data.List.map (Code._⊔_ x) l1)
   ->
   Data.List.Any.Any (_≡_ S)
      (Data.List.foldr _++_ []
       (Data.List.map (λ k → (k Code.⊔ x) ∷ whatevs k)
        l1))
 whatevs-right S whatevs x [] blob = blob
 whatevs-right S whatevs x (x₁ ∷ l1) (here px)
  rewrite px = here (Code.⊔-comm x x₁)
 whatevs-right S whatevs x (x₁ ∷ l1) (there blob)
  = there (++⁺ʳ (whatevs x₁) (whatevs-right S whatevs x l1 blob))

 thing : ∀ S l1 l2 ->
    Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map
       (λ k → Data.List.map (Code._⊔_ k) l1)
       l2))
    ->
    Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map
       (λ k → Data.List.map (Code._⊔_ k) l2)
       l1))

 thing S l1 [] blob
   rewrite simplify-foldr++-[] l1
   = blob

 thing S l1 (x ∷ l2) blob
  with ++⁻ (Data.List.map (Code._⊔_ x) l1) blob
 thing S l1 (x ∷ l2) _ | inj₁ y =
   whatevs-right S (λ { k → Data.List.map (Code._⊔_ k) l2 }) x l1 y
 thing S l1 (x ∷ l2) _ | inj₂ y =
   whatevs-left S (\ { k ->  (k Code.⊔ x)}) l1 l2 (thing S l1 l2 y)

canₛₕ-par :
  ∀ r₁ r₂ -> ∀ (θ : Env) →
   Canₛₕ (r₂ ∥ r₁) θ ⊆¹ Canₛₕ (r₁ ∥ r₂) θ
canₛₕ-par r₁ r₂ θ S S∈r₂∥r₁
 = ++-comm (proj₂ (proj₂ (Can r₂ θ))) (proj₂ (proj₂ (Can r₁ θ))) S∈r₂∥r₁

canθₛ-C-par : ∀ sigs S'' -> ∀ {C p r₁ r₂} ->
    p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
    ∀ {θ} S' ->
     S' ∉ Canθₛ sigs S'' p θ ->
     S' ∉ Canθₛ sigs S'' (C ⟦ r₂ ∥ r₁ ⟧c) θ
canθₛ-C-par sigs S'' {C} {p} {r₁} {r₂} pC {θ} S' S'∉Canθₛ[p] S'∈Canθₛ[C⟦r₂∥r₁⟧c]
  with canθₛ-plug S'' sigs C (r₁ ∥ r₂) (r₂ ∥ r₁)
                 (canₛ-par r₁ r₂) (canₖ-par r₁ r₂) θ S'
... |  r₂r₁->r₁r₂ rewrite sym (unplugc pC) = S'∉Canθₛ[p] (r₂r₁->r₁r₂ S'∈Canθₛ[C⟦r₂∥r₁⟧c])

canθₛₕ-C-par : ∀ sigs S' -> ∀ {C p r₁ r₂} ->
    p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
    ∀ {θ} s' ->
     s' ∉ Canθₛₕ sigs S' p θ ->
     s' ∉ Canθₛₕ sigs S' (C ⟦ r₂ ∥ r₁ ⟧c) θ
canθₛₕ-C-par sigs S' {C} {p} {r₁} {r₂} pC {θ} s' s'∉Canθₛₕ[p] s'∈Canθₛₕ[C⟦r₂∥r₁⟧c]
  with canθₛₕ-plug S' sigs C (r₁ ∥ r₂) (r₂ ∥ r₁)
                  (canₛₕ-par r₁ r₂) (canₖ-par r₁ r₂) (canₛ-par r₁ r₂) θ s'
... | r₂r₁->r₁r₂ rewrite sym (unplugc pC) = s'∉Canθₛₕ[p] (r₂r₁->r₁r₂ s'∈Canθₛₕ[C⟦r₂∥r₁⟧c])

DPG-pot-view :
 ∀ {C r₁ r₂ p q θ θ' A A'} ->
  p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
  (psn⟶₁q : ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ' , A' ⟩· q) ->
  (p≡q : p ≡ q) ->
  (A≡A' : A ≡ A') ->
  ->pot-view psn⟶₁q p≡q A≡A' ->
  Σ[ dd′ ∈ Term × Term ]
  (ρ⟨ θ , A ⟩· C ⟦ r₂ ∥ r₁ ⟧c sn⟶ (proj₂ dd′))
  ×
  ((proj₂ dd′) sn⟶* (proj₁ dd′))
  ×
  ((ρ⟨ θ' , A' ⟩· q) ∥R* (proj₁ dd′))
DPG-pot-view pC (ris-present S∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (ris-absent S∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (remit S∈ ¬S≡a x) p≡q A≡A' ()
DPG-pot-view pC (rraise-shared e' x) p≡q A≡A' ()
DPG-pot-view pC (rset-shared-value-old e' s∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (rset-shared-value-new e' s∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (rraise-var e' x₁) p≡q A≡A' ()
DPG-pot-view pC (rset-var x∈ e' x₁) p≡q A≡A' ()
DPG-pot-view pC (rif-false x∈ x₁ x₂) p≡q A≡A' ()
DPG-pot-view pC (rif-true x∈ x₁ x₂) p≡q A≡A' ()
DPG-pot-view pC (rabsence{θ}{_}{S} S∈ x x₁) .refl .refl (vabsence .S .S∈ .x .x₁)
  = _ , rcontext [] dchole
         (rabsence{θ}{_}{S} S∈ x (canθₛ-C-par (sig θ) 0 pC (Signal.unwrap S) x₁)) ,
    rrefl ,
    Context1-∥R* (cenv _ _) (∥Rn (∥Rstep pC) ∥R0)
DPG-pot-view pC (rreadyness{θ}{_}{s} s∈ x x₁) .refl .refl (vreadyness .s .s∈ .x .x₁)
  = _ , rcontext [] dchole
         (rreadyness{s = s} s∈ x (canθₛₕ-C-par (sig θ) 0 pC (SharedVar.unwrap s) x₁)) ,
    rrefl ,
    Context1-∥R* (cenv _ _) (∥Rn (∥Rstep pC) ∥R0)
DPG-pot-view pC (rmerge x) p≡q A≡A' ()


{- 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.Concrete.Records
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Impl.Consensus.Network            as Network
open import LibraBFT.Impl.Consensus.Network.Properties as NetworkProps
open import LibraBFT.Impl.Consensus.RoundManager       as RoundManager
open import LibraBFT.Impl.Consensus.RoundManager.Properties
open import LibraBFT.Impl.IO.OBM.InputOutputHandlers
open import LibraBFT.Impl.OBM.Logging.Logging
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.NetworkMsg
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude
open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms

open Invariants
open RoundManagerTransProps

module LibraBFT.Impl.IO.OBM.Properties.InputOutputHandlers where

module epvvSpec where

  contract
    : ∀ pre Post
      → let ep = pre ^∙ pssSafetyData-rm ∙ sdEpoch
            vv = pre ^∙ rmEpochState ∙ esVerifier in
        (Post (ep , vv) pre [])
      → LBFT-weakestPre epvv Post pre
  contract pre Post pf ._ refl ._ refl ._ refl ._ refl = pf

module handleProposalSpec (now : Instant) (pm : ProposalMsg) where

  open handleProposal now pm

  module _ (pool : SentMessages) (pre : RoundManager) where

    open Invariants.Reqs (pm ^∙ pmProposal) (pre ^∙ lBlockTree)

    record Contract (_ : Unit) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General properties / invariants
        rmInv              : Preserves RoundManagerInv pre post
        invalidProposal    : ¬ (BlockId-correct (pm ^∙ pmProposal)) → pre ≡ post × OutputProps.NoVotes outs
        noEpochChange      : NoEpochChange pre post
        -- Voting
        voteAttemptCorrect : BlockId-correct (pm ^∙ pmProposal)
                           → NoHC1 → Voting.VoteAttemptCorrectWithEpochReq pre post outs (pm ^∙ pmProposal)
        -- voteBuildsOnRC : TODO-2: We will need to know that, if we're sending a Vote, then there
        --                          is a Block b such that the Vote's proposed id is bId B and there
        --                          is a RecordChain (B b) and all the Records in that RecordChain
        --                          are InSys.  This is needed to prove ImplObligation-RC.  However,
        --                          before doing so, it may be worth considering strengthening the
        --                          Concrete PreferredRound proof, so that only IsValidVote is
        --                          required of the implementation, and that is used to construct
        --                          the required RecordChain, independently of the implementation.
        -- QCs
        outQcs∈RM : QCProps.OutputQc∈RoundManager outs post
        qcPost    : QCProps.∈Post⇒∈PreOr (_QC∈NM (P pm)) pre post

    contract : LBFT-weakestPre (handleProposal now pm) Contract pre
    contract =
      epvvSpec.contract pre Post-epvv contract-step₁
      where
      Post-epvv : LBFT-Post (Epoch × ValidatorVerifier)
      Post-epvv = RWS-weakestPre-bindPost unit (λ where (myEpoch , vv) → step₁ myEpoch vv) Contract

      myEpoch = pre ^∙ pssSafetyData-rm ∙ sdEpoch
      vv      = pre ^∙ rmEpochState ∙ esVerifier

      contractBail : ∀ outs → OutputProps.NoMsgs outs → Contract unit pre outs
      contractBail outs noMsgs =
        mkContract reflPreservesRoundManagerInv (const $ refl , OutputProps.NoMsgs⇒NoVotes outs noMsgs) (reflNoEpochChange{pre})
          vac outQcs∈RM qcPost
        where
        vac : BlockId-correct (pm ^∙ pmProposal) → NoHC1 → Voting.VoteAttemptCorrectWithEpochReq pre pre outs (pm ^∙ pmProposal)
        vac _ _ = Voting.mkVoteAttemptCorrectWithEpochReq
                    (Voting.voteAttemptBailed outs (OutputProps.NoMsgs⇒NoVotes outs noMsgs)) tt

        outQcs∈RM : QCProps.OutputQc∈RoundManager outs pre
        outQcs∈RM = QCProps.NoMsgs⇒OutputQc∈RoundManager outs pre noMsgs

        qcPost : QCProps.∈Post⇒∈PreOr _  pre pre
        qcPost qc = Left

      contract-step₁ : Post-epvv (myEpoch , vv) pre []
      proj₁ (contract-step₁ (myEpoch@._ , vv@._) refl) (inj₁ e) pp≡Left =
        contractBail _ refl
      proj₁ (contract-step₁ (myEpoch@._ , vv@._) refl) (inj₂ i) pp≡Left =
        contractBail _ refl
      proj₂ (contract-step₁ (myEpoch@._ , vv@._) refl) unit pp≡Right =
        processProposalMsgMSpec.contract now pm proposalId≡ pre Contract pf
        where

        sdEpoch≡ : pre ^∙ pssSafetyData-rm ∙ sdEpoch ≡ pm ^∙ pmProposal ∙ bEpoch
        sdEpoch≡
          with processProposalSpec.contract pm myEpoch vv
        ...| con rewrite pp≡Right = sym (proj₁ con)

        proposalId≡ : BlockId-correct (pm ^∙ pmProposal)
        proposalId≡
           with processProposalSpec.contract pm myEpoch vv
        ...| con rewrite pp≡Right = proj₂ con

        module PPM = processProposalMsgMSpec now pm proposalId≡

        pf : RWS-Post-⇒ (PPM.Contract pre) Contract
        pf unit st outs con =
          mkContract PPMSpec.rmInv (λ x → ⊥-elim (x proposalId≡)) PPMSpec.noEpochChange
            vac PPMSpec.outQcs∈RM PPMSpec.qcPost
          where
          module PPMSpec = processProposalMsgMSpec.Contract con

          vac : BlockId-correct (pm ^∙ pmProposal) → NoHC1
              → Voting.VoteAttemptCorrectWithEpochReq pre st outs (pm ^∙ pmProposal)
          vac _ nohc = Voting.mkVoteAttemptCorrectWithEpochReq (PPMSpec.voteAttemptCorrect nohc)
                         (Voting.voteAttemptEpochReq! (PPMSpec.voteAttemptCorrect nohc) sdEpoch≡)

    contract! : LBFT-Post-True Contract (handleProposal now pm) pre
    contract! = LBFT-contract (handleProposal now pm) Contract pre contract

module handleVoteSpec (now : Instant) (vm : VoteMsg) where
  open handleVote now vm

  module _ (pool : SentMessages) (pre : RoundManager) where

    record Contract (_ : Unit) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General properties / invariants
        rmInv         : Preserves RoundManagerInv pre post
        noEpochChange : NoEpochChange pre post
        noSDChange    : NoSafetyDataChange pre post
        -- Output
        noVotes       : OutputProps.NoVotes outs
        -- Signatures
        outQcs∈RM : QCProps.OutputQc∈RoundManager outs post
        qcPost    : QCProps.∈Post⇒∈PreOr (_QC∈NM (V vm)) pre post
        -- TODO-2: `handleVote` can create a new QC once it receives enough
        -- votes. We need to be tracking /votes/ here, not QCs

    postulate -- TODO-2: prove (waiting on: refinement of `Contract`)
      contract : LBFT-weakestPre (handleVote now vm) Contract pre

    contract! : LBFT-Post-True Contract (handleVote now vm) pre
    contract! = LBFT-contract (handleVote now vm) Contract pre contract


-- Everything is strictly positive, but Agda doesn't see this.
{-# OPTIONS --no-positivity-check #-}

module Generic.Core where

open import Generic.Lib.Prelude public

infix  4 _≤ℓ_
infixr 5 _⇒_ _⊛_

_≤ℓ_ : Level -> Level -> Set
α ≤ℓ β = α ⊔ β ≡ β

mutual
  Binder : ∀ {ι} α β γ -> ArgInfo -> ι ⊔ lsuc (α ⊔ β) ≡ γ -> Set ι -> Set γ
  Binder α β γ i q I = Coerce q (∃ λ (A : Set α) -> < relevance i > A -> Desc I β)

  data Desc {ι} (I : Set ι) β : Set (ι ⊔ lsuc β) where
    var : I -> Desc I β
    π   : ∀ {α} i
        -> (q : α ≤ℓ β)
        -> Binder α β _ i (cong (λ αβ -> ι ⊔ lsuc αβ) q) I
        -> Desc I β
    _⊛_ : Desc I β -> Desc I β -> Desc I β

pattern DPi i A D = π i refl (coerce (A , D))

{-# DISPLAY π i refl (coerce (A , D)) = DPi i A D #-}

pattern explRelDPi A D = DPi explRelInfo A D
pattern explIrrDPi A D = DPi explIrrInfo A D
pattern implRelDPi A D = DPi implRelInfo A D
pattern implIrrDPi A D = DPi implIrrInfo A D
pattern instRelDPi A D = DPi instRelInfo A D
pattern instIrrDPi A D = DPi instIrrInfo A D

{-# DISPLAY DPi explRelInfo A D = explRelDPi A D #-}
{-# DISPLAY DPi explIrrInfo A D = explIrrDPi A D #-}
{-# DISPLAY DPi implRelInfo A D = implRelDPi A D #-}
{-# DISPLAY DPi implIrrInfo A D = implIrrDPi A D #-}
{-# DISPLAY DPi instRelInfo A D = instRelDPi A D #-}
{-# DISPLAY DPi instIrrInfo A D = instIrrDPi A D #-}

_⇒_ : ∀ {ι α β} {I : Set ι} {{q : α ≤ℓ β}} -> Set α -> Desc I β -> Desc I β
_⇒_ {{q}} A D = π (explRelInfo) q (qcoerce (A , λ _ -> D))

mutual
  ⟦_⟧ : ∀ {ι β} {I : Set ι} -> Desc I β -> (I -> Set β) -> Set β
  ⟦ var i   ⟧ B = B i
  ⟦ π i q C ⟧ B = ⟦ i / C ⟧ᵇ q B
  ⟦ D ⊛ E   ⟧ B = ⟦ D ⟧ B × ⟦ E ⟧ B

  ⟦_/_⟧ᵇ : ∀ {α ι β γ q} {I : Set ι} i
         -> Binder α β γ i q I -> α ≤ℓ β -> (I -> Set β) -> Set β
  ⟦ i / coerce (A , D) ⟧ᵇ q B = Coerce′ q $ Pi i A λ x -> ⟦ D x ⟧ B

mutual
  Extend : ∀ {ι β} {I : Set ι} -> Desc I β -> (I -> Set β) -> I -> Set β
  Extend (var i)   B j = Lift _ (i ≡ j)
  Extend (π i q C) B j = Extendᵇ i C q B j
  Extend (D ⊛ E)   B j = ⟦ D ⟧ B × Extend E B j

  Extendᵇ : ∀ {ι α β γ q} {I : Set ι} i
          -> Binder α β γ i q I -> α ≤ℓ β -> (I -> Set β) -> I -> Set β
  Extendᵇ i (coerce (A , D)) q B j = Coerce′ q $ ∃ λ x -> Extend (D x) B j

module _ {ι β} {I : Set ι} (D : Data (Desc I β)) where
  mutual
    data μ j : Set β where
      node : Node D j -> μ j

    Node : Data (Desc I β) -> I -> Set β
    Node D j = Any (λ C -> Extend C μ j) (consTypes D)

mutual
  Cons : ∀ {ι β} {I : Set ι} -> (I -> Set β) -> Desc I β -> Set β
  Cons B (var i)   = B i
  Cons B (π i q C) = Consᵇ B i C q
  Cons B (D ⊛ E)   = ⟦ D ⟧ B -> Cons B E

  Consᵇ : ∀ {ι α β γ q} {I : Set ι}
        -> (I -> Set β) -> ∀ i -> Binder α β γ i q I -> α ≤ℓ β -> Set β
  Consᵇ B i (coerce (A , D)) q = Coerce′ q $ Pi i A λ x -> Cons B (D x)

cons : ∀ {ι β} {I : Set ι} {D} -> (D₀ : Data (Desc I β)) -> D ∈ consTypes D₀ -> Cons (μ D₀) D
cons {D = D} D₀ p = go D λ e ->
  node (mapAny (consTypes D₀) (λ q -> subst (λ E -> Extend E _ _) q e) p) where
    mutual
      go : ∀ {ι β} {I : Set ι} {B : I -> Set β}
         -> (D : Desc I β) -> (∀ {j} -> Extend D B j -> B j) -> Cons B D
      go (var i)   k = k lrefl
      go (π a q C) k = goᵇ a C k
      go (D ⊛ E)   k = λ x -> go E (k ∘ _,_ x)

      goᵇ : ∀ {ι α β γ q q′} {I : Set ι} {B : I -> Set β} i
          -> (C : Binder α β γ i q′ I) -> (∀ {j} -> Extendᵇ i C q B j -> B j) -> Consᵇ B i C q
      goᵇ {q = q} i (coerce (A , D)) k =
        coerce′ q $ lamPi i λ x -> go (D x) (k ∘ coerce′ q ∘ _,_ x)

allCons : ∀ {ι β} {I : Set ι} -> (D : Data (Desc I β)) -> All (Cons (μ D)) (consTypes D)
allCons D = allIn _ (cons D)

node-inj : ∀ {i β} {I : Set i} {D : Data (Desc I β)} {j} {e₁ e₂ : Node D D j}
         -> node {D = D} e₁ ≡ node e₂ -> e₁ ≡ e₂
node-inj refl = refl

μ′ : ∀ {β} -> Data (Desc ⊤₀ β) -> Set β
μ′ D = μ D tt

pos : ∀ {β} -> Desc ⊤₀ β
pos = var tt

pattern #₀ p = node (inj₁ p)
pattern #₁ p = node (inj₂ (inj₁ p))
pattern #₂ p = node (inj₂ (inj₂ (inj₁ p)))
pattern #₃ p = node (inj₂ (inj₂ (inj₂ (inj₁ p))))
pattern #₄ p = node (inj₂ (inj₂ (inj₂ (inj₂ (inj₁ p)))))
pattern #₅ p = node (inj₂ (inj₂ (inj₂ (inj₂ (inj₂ (inj₁ p))))))

pattern !#₀ p = node p
pattern !#₁ p = node (inj₂ p)
pattern !#₂ p = node (inj₂ (inj₂ p))
pattern !#₃ p = node (inj₂ (inj₂ (inj₂ p)))
pattern !#₄ p = node (inj₂ (inj₂ (inj₂ (inj₂ p))))
pattern !#₅ p = node (inj₂ (inj₂ (inj₂ (inj₂ (inj₂ p)))))


open import MJ.Types
import MJ.Classtable.Core as Core

module MJ.Classtable.Code {c}(Ct : Core.Classtable c) where

open import Prelude
open import Data.Maybe as Maybe using (Maybe; just; nothing)
open import Data.Star as Star
open import Data.List
open import Data.List.Relation.Unary.All hiding (construct)
open import Data.List.Properties.Extra as List+
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Data.String

import Data.Vec.Relation.Unary.All as Vec∀

open Core c
open Classtable Ct
open import MJ.Classtable.Membership Ct
open import MJ.LexicalScope c
open import MJ.Syntax Ct

data Body (I : Ctx) : Ty c → Set where
  body : ∀ {r}{O : Ctx} → Stmts I r O → Expr O r → Body I r

{-
A helper to generate the shape of the context for method bodies
-}
methodctx : Cid c → List (Ty c) → Ctx
methodctx cid as = (ref cid ∷ as)

{-
A helper to generate the shape of the context for constructors
-}
constrctx : Cid c → Ctx
constrctx cid = let cl = Σ cid in (ref cid ∷ Class.constr cl)

-- A method is either just a body, or a body prefixed by a super call.
data Method (cid : Cid c)(m : String) : Sig c → Set where
  super_⟨_⟩then_ : ∀ {as b} →
                let
                  pid = Class.parent (Σ cid)
                  Γ   = methodctx cid as
                in
                  -- must have a super to call, with the same signature
                  AccMember pid METHOD m (as , b) →
                  -- super call arguments
                  All (Expr Γ) as →
                  -- body
                  Body (Γ +local b) b → Method cid m (as , b)
  body        : ∀ {as b} → Body (methodctx cid as) b → Method cid m (as , b)

-- Constructors are similar
data Constructor (cid : Cid c) : Set where
  super_then_ : let
                  pid = Class.parent (Σ cid)
                  pclass = Σ pid
                  Γ   = constrctx cid
                in
                  -- super call arguments
                  All (Expr Γ) (Class.constr pclass) →
                  -- body
                  Body Γ void →
                  Constructor cid
  body        : Body (constrctx cid) void → Constructor cid

{-
A class implementation consists of a constructor and a body for every
METHOD declaration.
-}
record Implementation (cid : Cid c) : Set where
  constructor implementation
  open Class (Σ cid) public
  field
    construct : Constructor cid
    mbodies   : All (λ{ (name , sig) → Method cid name sig }) (decls METHOD)

-- Code is a lookup table for class implementations for every class identifier
Code = ∀ cid → Implementation cid

-- Mirroring `IsMember METHOD` we define the notion of an inherited method body.
InheritedMethod : ∀ (cid : Cid c)(m : String) → Sig c → Set
InheritedMethod cid m s = ∃ λ pid → Σ ⊢ cid <: pid × Method pid m s


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

{-# OPTIONS --erased-cubical --sized-types #-}

module Lambda.Delay-monad.Compiler-correctness where

import Equality.Propositional as E
open import Prelude
open import Prelude.Size

open import Maybe E.equality-with-J hiding (_>>=′_)
open import Monad E.equality-with-J
open import Vec.Function E.equality-with-J

open import Delay-monad.Bisimilarity
open import Delay-monad.Monad

open import Lambda.Compiler
open import Lambda.Delay-monad.Interpreter
open import Lambda.Delay-monad.Virtual-machine
open import Lambda.Syntax hiding ([_])
open import Lambda.Virtual-machine

private
  module C = Closure Code
  module T = Closure Tm

-- Bind preserves strong bisimilarity.

infixl 5 _>>=-congM_

_>>=-congM_ :
  ∀ {i ℓ} {A B : Type ℓ} {x y : M ∞ A} {f g : A → M ∞ B} →
  [ i ] run x ∼ run y →
  (∀ z → [ i ] run (f z) ∼ run (g z)) →
  [ i ] run (x >>= f) ∼ run (y >>= g)
p >>=-congM q = p >>=-cong [ (λ _ → run fail ∎) , q ]

-- Bind is associative.

associativityM :
  ∀ {ℓ} {A B C : Type ℓ} (x : M ∞ A) (f : A → M ∞ B) (g : B → M ∞ C) →
  run (x >>= (λ x → f x >>= g)) ∼ run (x >>= f >>= g)
associativityM x f g =
  run (x >>= λ x → f x >>= g)                                       ∼⟨⟩

  run x >>=′ maybe (λ x → run (f x >>= g)) (return nothing)         ∼⟨ (run x ∎) >>=-cong [ (λ _ → run fail ∎) , (λ x → run (f x >>= g) ∎) ] ⟩

  run x >>=′ (λ x → maybe (MaybeT.run ∘ f) (return nothing) x >>=′
                    maybe (MaybeT.run ∘ g) (return nothing))        ∼⟨ associativity′ (run x) _ _ ⟩

  run x >>=′ maybe (MaybeT.run ∘ f) (return nothing)
        >>=′ maybe (MaybeT.run ∘ g) (return nothing)                ∼⟨⟩

  run (x >>= f >>= g)                                               ∎

-- Compiler correctness.

mutual

  ⟦⟧-correct :
    ∀ {i n} t {ρ : T.Env n} {c s} {k : T.Value → M ∞ C.Value} →
    (∀ v → [ i ] run (exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩) ≈
                 run (k v)) →
    [ i ] run (exec ⟨ comp t c , s , comp-env ρ ⟩) ≈ run (⟦ t ⟧ ρ >>= k)

  ⟦⟧-correct (con i) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ con i ∷ c , s , comp-env ρ ⟩)                     ≳⟨⟩
    run (exec ⟨ c , val (comp-val (T.con i)) ∷ s , comp-env ρ ⟩)  ≈⟨ hyp (T.con i) ⟩∼
    run (k (T.con i))                                             ∼⟨⟩
    run (⟦ con i ⟧ ρ >>= k)                                       ∎

  ⟦⟧-correct (var x) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ var x ∷ c , s , comp-env ρ ⟩)                 ≳⟨⟩
    run (exec ⟨ c , val (comp-val (ρ x)) ∷ s , comp-env ρ ⟩)  ≈⟨ hyp (ρ x) ⟩∼
    run (k (ρ x))                                             ∼⟨⟩
    run (⟦ var x ⟧ ρ >>= k)                                   ∎

  ⟦⟧-correct (ƛ t) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ clo (comp t (ret ∷ [])) ∷ c , s , comp-env ρ ⟩)   ≳⟨⟩
    run (exec ⟨ c , val (comp-val (T.ƛ t ρ)) ∷ s , comp-env ρ ⟩)  ≈⟨ hyp (T.ƛ t ρ) ⟩∼
    run (k (T.ƛ t ρ))                                             ∼⟨⟩
    run (⟦ ƛ t ⟧ ρ >>= k)                                         ∎

  ⟦⟧-correct (t₁ · t₂) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩)    ≈⟨ (⟦⟧-correct t₁ λ v₁ → ⟦⟧-correct t₂ λ v₂ → ∙-correct v₁ v₂ hyp) ⟩∼

    run (⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂ >>= k)    ∼⟨ (run (⟦ t₁ ⟧ ρ) ∎) >>=-congM (λ _ → associativityM (⟦ t₂ ⟧ ρ) _ _) ⟩

    run (⟦ t₁ ⟧ ρ >>= λ v₁ → (⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂) >>= k)  ∼⟨ associativityM (⟦ t₁ ⟧ ρ) _ _ ⟩

    run (⟦ t₁ · t₂ ⟧ ρ >>= k)                                      ∎

  ∙-correct :
    ∀ {i n} v₁ v₂ {ρ : T.Env n} {c s} {k : T.Value → M ∞ C.Value} →
    (∀ v → [ i ] run (exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩) ≈
                 run (k v)) →
    [ i ] run (exec ⟨ app ∷ c
                    , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
                    , comp-env ρ
                    ⟩) ≈
          run (v₁ ∙ v₂ >>= k)
  ∙-correct (T.con i) v₂ {ρ} {c} {s} {k} hyp =
    run (exec ⟨ app ∷ c
              , val (comp-val v₂) ∷ val (C.con i) ∷ s
              , comp-env ρ
              ⟩)                                       ∼⟨⟩

    run fail                                           ∼⟨⟩

    run (T.con i ∙ v₂ >>= k)                           ∎

  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} hyp =
    run (exec ⟨ app ∷ c
              , val (comp-val v₂) ∷ val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
              , comp-env ρ
              ⟩)                                                    ≈⟨ later (λ { .force →

      run (exec ⟨ comp t₁ (ret ∷ [])
                , ret c (comp-env ρ) ∷ s
                , cons (comp-val v₂) (comp-env ρ₁)
             ⟩)                                                          ≡⟨ E.cong (λ ρ′ → run (exec ⟨ comp t₁ (ret ∷ []) ,
                                                                                ret c (comp-env ρ) ∷ s , ρ′ ⟩))
                                                                                (E.sym comp-cons) ⟩
      run (exec ⟨ comp t₁ (ret ∷ [])
                , ret c (comp-env ρ) ∷ s
                , comp-env (cons v₂ ρ₁)
                ⟩)                                                       ≈⟨ ⟦⟧-correct t₁ (λ v →

        run (exec ⟨ ret ∷ []
                  , val (comp-val v) ∷ ret c (comp-env ρ) ∷ s
                  , comp-env (cons v₂ ρ₁)
                  ⟩)                                                          ≳⟨⟩

        run (exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩)                  ≈⟨ hyp v ⟩∎

        run (k v)                                                             ∎) ⟩∼

      run (⟦ t₁ ⟧ (cons v₂ ρ₁) >>= k)                                    ∎ }) ⟩∎

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

-- Note that the equality that is used here is syntactic.

correct :
  ∀ t →
  exec ⟨ comp t [] , [] , nil ⟩ ≈M
  ⟦ t ⟧ nil >>= λ v → return (comp-val v)
correct t =
  run (exec ⟨ comp t [] , [] , nil ⟩)            ≡⟨ E.cong (λ ρ → run (exec ⟨ comp t [] , [] , ρ ⟩)) $ E.sym comp-nil ⟩
  run (exec ⟨ comp t [] , [] , comp-env nil ⟩)   ≈⟨ ⟦⟧-correct t (λ v → return (just (comp-val v)) ∎) ⟩
  run (⟦ t ⟧ nil >>= λ v → return (comp-val v))  ∎


S : Set; S = S


-- Andreas, 2016-06-11

postulate Foo : Foo → Set


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Tarski-style semantics with context pairs as concrete worlds, and glueing for α, ▻, and □.
-- Hilbert-style syntax.

module BasicIS4.Semantics.TarskiOvergluedDyadicHilbert where

open import BasicIS4.Syntax.Common public
open import Common.Semantics public

-- Intuitionistic Tarski models.

record Model : Set₁ where
  infix 3 _⊩ᵅ_ _[⊢]_
  field
    -- Forcing for atomic propositions; monotonic.
    _⊩ᵅ_    : Cx² Ty Ty → Atom → Set
    mono²⊩ᵅ : ∀ {P Π Π′} → Π ⊆² Π′ → Π ⊩ᵅ P → Π′ ⊩ᵅ P

    -- Hilbert-style syntax representation; monotonic.
    _[⊢]_    : Cx² Ty Ty → Ty → Set
    mono²[⊢] : ∀ {A Π Π′}    → Π ⊆² Π′ → Π [⊢] A → Π′ [⊢] A
    [var]     : ∀ {A Γ Δ}     → A ∈ Γ → Γ ⁏ Δ [⊢] A
    [app]     : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ▻ B → Γ ⁏ Δ [⊢] A → Γ ⁏ Δ [⊢] B
    [ci]      : ∀ {A Γ Δ}     → Γ ⁏ Δ [⊢] A ▻ A
    [ck]      : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ▻ B ▻ A
    [cs]      : ∀ {A B C Γ Δ} → Γ ⁏ Δ [⊢] (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
    [mvar]    : ∀ {A Γ Δ}     → A ∈ Δ → Γ ⁏ Δ [⊢] A
    [box]     : ∀ {A Γ Δ}     → ∅ ⁏ Δ [⊢] A → Γ ⁏ Δ [⊢] □ A
    [cdist]   : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] □ (A ▻ B) ▻ □ A ▻ □ B
    [cup]     : ∀ {A Γ Δ}     → Γ ⁏ Δ [⊢] □ A ▻ □ □ A
    [cdown]   : ∀ {A Γ Δ}     → Γ ⁏ Δ [⊢] □ A ▻ A
    [cpair]   : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ▻ B ▻ A ∧ B
    [cfst]    : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ∧ B ▻ A
    [csnd]    : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ∧ B ▻ B
    [unit]    : ∀ {Γ Δ}       → Γ ⁏ Δ [⊢] ⊤

    -- NOTE: [mlam] is necessary for [mmulticut], which is necessary for eval.
    [mlam] : ∀ {A B Γ Δ} → Γ ⁏ Δ , A [⊢] B → Γ ⁏ Δ [⊢] □ A ▻ B

  infix 3 _[⊢]⋆_
  _[⊢]⋆_ : Cx² Ty Ty → Cx Ty → Set
  Π [⊢]⋆ ∅     = 𝟙
  Π [⊢]⋆ Ξ , A = Π [⊢]⋆ Ξ × Π [⊢] A

open Model {{…}} public

-- Forcing in a particular model.

module _ {{_ : Model}} where
  infix 3 _⊩_
  _⊩_ : Cx² Ty Ty → Ty → Set
  Π ⊩ α P   = Glue (Π [⊢] α P) (Π ⊩ᵅ P)
  Π ⊩ A ▻ B = ∀ {Π′} → Π ⊆² Π′ → Glue (Π′ [⊢] A ▻ B) (Π′ ⊩ A → Π′ ⊩ B)
  Π ⊩ □ A   = ∀ {Π′} → Π ⊆² Π′ → Glue (Π′ [⊢] □ A) (Π′ ⊩ A)
  Π ⊩ A ∧ B = Π ⊩ A × Π ⊩ B
  Π ⊩ ⊤    = 𝟙

  infix 3 _⊩⋆_
  _⊩⋆_ : Cx² Ty Ty → Cx Ty → Set
  Π ⊩⋆ ∅     = 𝟙
  Π ⊩⋆ Ξ , A = Π ⊩⋆ Ξ × Π ⊩ A

-- Monotonicity with respect to context inclusion.

module _ {{_ : Model}} where
  mono²⊩ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊩ A → Π′ ⊩ A
  mono²⊩ {α P}   ψ s = mono²[⊢] ψ (syn s) ⅋ mono²⊩ᵅ ψ (sem s)
  mono²⊩ {A ▻ B} ψ s = λ ψ′ → s (trans⊆² ψ ψ′)
  mono²⊩ {□ A}   ψ s = λ ψ′ → s (trans⊆² ψ ψ′)
  mono²⊩ {A ∧ B} ψ s = mono²⊩ {A} ψ (π₁ s) , mono²⊩ {B} ψ (π₂ s)
  mono²⊩ {⊤}    ψ s = ∙

  mono²⊩⋆ : ∀ {Ξ Π Π′} → Π ⊆² Π′ → Π ⊩⋆ Ξ → Π′ ⊩⋆ Ξ
  mono²⊩⋆ {∅}     ψ ∙        = ∙
  mono²⊩⋆ {Ξ , A} ψ (ts , t) = mono²⊩⋆ ψ ts , mono²⊩ {A} ψ t

-- Extraction of syntax representation in a particular model.

module _ {{_ : Model}} where
  reifyʳ : ∀ {A Π} → Π ⊩ A → Π [⊢] A
  reifyʳ {α P}   s = syn s
  reifyʳ {A ▻ B} s = syn (s refl⊆²)
  reifyʳ {□ A}   s = syn (s refl⊆²)
  reifyʳ {A ∧ B} s = [app] ([app] [cpair] (reifyʳ {A} (π₁ s))) (reifyʳ {B} (π₂ s))
  reifyʳ {⊤}    s = [unit]

  reifyʳ⋆ : ∀ {Ξ Π} → Π ⊩⋆ Ξ → Π [⊢]⋆ Ξ
  reifyʳ⋆ {∅}     ∙        = ∙
  reifyʳ⋆ {Ξ , A} (ts , t) = reifyʳ⋆ ts , reifyʳ t

-- Useful theorems in functional form.

module _ {{_ : Model}} where
  [mmulticut] : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ [⊢]⋆ □⋆ Ξ → Γ ⁏ Ξ [⊢] A → Γ ⁏ Δ [⊢] A
  [mmulticut] {∅}     ∙        u = mono²[⊢] (refl⊆ , bot⊆) u
  [mmulticut] {Ξ , B} (ts , t) u = [app] ([mmulticut] ts ([mlam] u)) t

-- Additional useful equipment.

module _ {{_ : Model}} where
  _⟪$⟫_ : ∀ {A B Π} → Π ⊩ A ▻ B → Π ⊩ A → Π ⊩ B
  s ⟪$⟫ a = sem (s refl⊆²) a

  ⟪K⟫ : ∀ {A B Π} → Π ⊩ A → Π ⊩ B ▻ A
  ⟪K⟫ {A} a ψ = let a′ = mono²⊩ {A} ψ a
                in  [app] [ck] (reifyʳ a′) ⅋ K a′

  ⟪S⟫ : ∀ {A B C Π} → Π ⊩ A ▻ B ▻ C → Π ⊩ A ▻ B → Π ⊩ A → Π ⊩ C
  ⟪S⟫ s₁ s₂ a = (s₁ ⟪$⟫ a) ⟪$⟫ (s₂ ⟪$⟫ a)

  ⟪S⟫′ : ∀ {A B C Π} → Π ⊩ A ▻ B ▻ C → Π ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ {A} {B} {C} s₁ ψ = let s₁′ = mono²⊩ {A ▻ B ▻ C} ψ s₁
                              t   = syn (s₁′ refl⊆²)
                          in  [app] [cs] t ⅋ λ s₂ ψ′ →
                              let s₁″ = mono²⊩ {A ▻ B ▻ C} (trans⊆² ψ ψ′) s₁
                                  s₂′ = mono²⊩ {A ▻ B} ψ′ s₂
                                  t′  = syn (s₁″ refl⊆²)
                                  u   = syn (s₂′ refl⊆²)
                              in  [app] ([app] [cs] t′) u ⅋ ⟪S⟫ s₁″ s₂′

  _⟪D⟫_ : ∀ {A B Π} → Π ⊩ □ (A ▻ B) → Π ⊩ □ A → Π ⊩ □ B
  (s₁ ⟪D⟫ s₂) ψ = let t ⅋ s₁′ = s₁ ψ
                      u ⅋ a   = s₂ ψ
                  in  [app] ([app] [cdist] t) u ⅋ s₁′ ⟪$⟫ a

  _⟪D⟫′_ : ∀ {A B Π} → Π ⊩ □ (A ▻ B) → Π ⊩ □ A ▻ □ B
  _⟪D⟫′_ {A} {B} s₁ ψ = let s₁′ = mono²⊩ {□ (A ▻ B)} ψ s₁
                        in  [app] [cdist] (reifyʳ (λ {_} ψ′ → s₁′ ψ′)) ⅋ _⟪D⟫_ s₁′

  ⟪↑⟫ : ∀ {A Π} → Π ⊩ □ A → Π ⊩ □ □ A
  ⟪↑⟫ {A} s ψ = [app] [cup] (syn (s ψ)) ⅋ λ ψ′ → s (trans⊆² ψ ψ′)

  ⟪↓⟫ : ∀ {A Π} → Π ⊩ □ A → Π ⊩ A
  ⟪↓⟫ s = sem (s refl⊆²)

  _⟪,⟫′_ : ∀ {A B Π} → Π ⊩ A → Π ⊩ B ▻ A ∧ B
  _⟪,⟫′_ {A} a ψ = let a′ = mono²⊩ {A} ψ a
                   in  [app] [cpair] (reifyʳ a′) ⅋ _,_ a′

-- Forcing in a particular world of a particular model, for sequents.

module _ {{_ : Model}} where
  infix 3 _⊩_⇒_
  _⊩_⇒_ : Cx² Ty Ty → Cx² Ty Ty → Ty → Set
  Π ⊩ Γ ⁏ Δ ⇒ A = Π ⊩⋆ Γ → Π ⊩⋆ □⋆ Δ → Π ⊩ A

  infix 3 _⊩_⇒⋆_
  _⊩_⇒⋆_ : Cx² Ty Ty → Cx² Ty Ty → Cx Ty → Set
  Π ⊩ Γ ⁏ Δ ⇒⋆ Ξ = Π ⊩⋆ Γ → Π ⊩⋆ □⋆ Δ → Π ⊩⋆ Ξ

-- Entailment, or forcing in all worlds of all models, for sequents.

infix 3 _⊨_
_⊨_ : Cx² Ty Ty → Ty → Set₁
Π ⊨ A = ∀ {{_ : Model}} {w : Cx² Ty Ty} → w ⊩ Π ⇒ A

infix 3 _⊨⋆_
_⊨⋆_ : Cx² Ty Ty → Cx Ty → Set₁
Π ⊨⋆ Ξ = ∀ {{_ : Model}} {w : Cx² Ty Ty} → w ⊩ Π ⇒⋆ Ξ

-- Additional useful equipment, for sequents.

module _ {{_ : Model}} where
  lookup : ∀ {A Γ w} → A ∈ Γ → w ⊩⋆ Γ → w ⊩ A
  lookup top     (γ , a) = a
  lookup (pop i) (γ , b) = lookup i γ

  mlookup : ∀ {A Δ w} → A ∈ Δ → w ⊩⋆ □⋆ Δ → w ⊩ A
  mlookup top     (γ , s) = sem (s refl⊆²)
  mlookup (pop i) (γ , s) = mlookup i γ

  -- TODO: More equipment.


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

-- This error is detected by TypeChecking.Rules.Decl.

module ATPBadType2 where

foo : Set → Set
foo A = A

{-# ATP type foo #-}


open import Prelude

module Implicits.Resolution.Termination.Lemmas.SizeMeasures
  where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Vec
open import Data.Fin.Substitution
open import Extensions.Vec
open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties
open import Relation.Binary using (module DecTotalOrder)
open DecTotalOrder decTotalOrder using () renaming (refl to ≤-refl)
open import Extensions.Nat
open import Implicits.Resolution.Termination.SizeMeasures

-- we can show that our size measure a ρ< b is well founded
-- by relating it to the well-foundedness proof of _<'_
open import Induction.WellFounded
ρ<-well-founded : Well-founded _ρ<_
ρ<-well-founded = sub.well-founded (image.well-founded <-well-founded)
    where
        open import Induction.Nat
        open import Data.Nat
        open import Data.Nat.Properties
        module sub = Inverse-image (λ{ (_ , a ) → || a ||})
        module image = Subrelation {A = ℕ} {_<_} {_<′_} ≤⇒≤′

open import Induction.WellFounded
hρ<-well-founded : Well-founded _hρ<_
hρ<-well-founded = sub.well-founded (image.well-founded <-well-founded)
  where
    open import Induction.Nat
    open import Data.Nat
    open import Data.Nat.Properties
    module sub = Inverse-image (λ{ (_ , a ) → h|| a ||})
    module image = Subrelation {A = ℕ} {_<_} {_<′_} ≤⇒≤′

m<-well-founded : Well-founded _m<_
m<-well-founded = sub.well-founded (image.well-founded <-well-founded)
    where
        module sub = Inverse-image (λ{ (_ , _ , a) → m|| a ||})
        module image = Subrelation {A = ℕ} {_<_} {_<′_} ≤⇒≤′

module TypeSubstSizeLemmas where
  open MetaTypeTypeSubst

  mutual
    ||a/Var|| : ∀ {m ν μ} (a : MetaType m ν) (s : Sub Fin ν μ) →
                m|| a /Var s || ≡ m|| a ||
    ||a/Var|| (a ⇒ b) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (∀' a) s = cong (λ u → 1 + u) (||a/Var|| a (s VarSubst.↑))
    ||a/Var|| (simpl (tvar x)) s = refl
    ||a/Var|| (simpl (mvar x)) s = refl
    ||a/Var|| (simpl (a →' b)) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (simpl (tc c)) s = refl

    ||weaken-a|| : ∀ {m ν} (a : MetaType m ν) → m|| weaken a || ≡ m|| a ||
    ||weaken-a|| {m} {ν} a = begin
      m|| weaken a ||
        ≡⟨ refl ⟩
      m|| a /Var VarSubst.wk ||
        ≡⟨ ||a/Var|| a VarSubst.wk ⟩
      m|| a || ∎

    ||s↑|| : ∀ {m ν μ} (s : Sub (MetaType m) ν μ) →
                       (∀ (x : Fin ν) → m|| lookup x s || ≡ 1) →
                       ∀ y → m|| lookup y (s ↑) || ≡ 1
    ||s↑|| s p zero = refl
    ||s↑|| s p (suc y) = begin
      m|| lookup y (map weaken s) ||
        ≡⟨ cong m||_|| (sym $ lookup⋆map s weaken y) ⟩
      m|| weaken (lookup y s) ||
        ≡⟨ ||weaken-a|| (lookup y s) ⟩
      m|| (lookup y s) ||
        ≡⟨ p y ⟩
      1 ∎

    ||a/s|| : ∀ {m ν μ} (a : MetaType m ν) (s : Sub (MetaType m) ν μ) →
             (∀ x → m|| lookup x s || ≡ 1) →
             m|| a / s || ≡ m|| a ||
    ||a/s|| (a ⇒ b) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (∀' a) s p = cong (λ u → 1 + u) (||a/s|| a (s ↑) (||s↑|| s p))
    ||a/s|| {m} {ν} (simpl (tvar x)) s p = begin
      m|| (simpl (tvar x)) / s ||
        ≡⟨ cong m||_|| (MetaTypeTypeLemmas.var-/ {x = x}) ⟩
      m|| lookup x s ||
        ≡⟨ p x ⟩
      1 ∎
    ||a/s|| (simpl (mvar x)) s p = refl
    ||a/s|| (simpl (a →' b)) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (simpl (tc c)) s p = refl

module MetaSubstSizeLemmas where
  open MetaTypeMetaSubst hiding (open-meta)

  mutual
    ||a/Var|| : ∀ {ν m n} (a : MetaType m ν) (s : Sub Fin m n) →
                m|| a /Var s || ≡ m|| a ||
    ||a/Var|| (a ⇒ b) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| {ν = ν} (∀' a) s =
      cong (λ u → 1 + u) (||a/Var|| a ((varLift MetaLift.↑tp) {ν = ν} s))
    ||a/Var|| (simpl (tvar x)) s = refl
    ||a/Var|| (simpl (mvar x)) s = refl
    ||a/Var|| (simpl (a →' b)) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (simpl (tc c)) s = refl

    ||weaken-a|| : ∀ {m ν} (a : MetaType m ν) → m|| weaken a || ≡ m|| a ||
    ||weaken-a|| {m} {ν} a = begin
      m|| weaken a ||
        ≡⟨ refl ⟩
      m|| a /Var VarSubst.wk ||
        ≡⟨ ||a/Var|| a VarSubst.wk ⟩
      m|| a || ∎

    ||s↑|| : ∀ {m ν μ} (s : Sub (MetaType m) ν μ) →
                       (∀ (x : Fin ν) → m|| lookup x s || ≡ 1) →
                       ∀ y → m|| lookup y (s ↑) || ≡ 1
    ||s↑|| s p zero = refl
    ||s↑|| s p (suc y) = begin
      m|| lookup y (map weaken s) ||
        ≡⟨ cong m||_|| (sym $ lookup⋆map s weaken y) ⟩
      m|| weaken (lookup y s) ||
        ≡⟨ ||weaken-a|| (lookup y s) ⟩
      m|| (lookup y s) ||
        ≡⟨ p y ⟩
      1 ∎

    ||a/s|| : ∀ {m ν n} (a : MetaType m ν) (s : Sub (flip MetaType ν) m n) →
             (∀ x → m|| lookup x s || ≡ 1) →
             m|| a / s || ≡ m|| a ||
    ||a/s|| (a ⇒ b) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (∀' a) s p = cong (λ u → 1 + u) (||a/s|| a (map MetaTypeTypeSubst.weaken s) lem)
      where
        lem : ∀ x → m|| lookup x (map MetaTypeTypeSubst.weaken s) || ≡ 1
        lem x = begin
          m|| lookup x (map MetaTypeTypeSubst.weaken s) ||
            ≡⟨ cong m||_|| (sym $ lookup⋆map s _ x) ⟩
          m|| MetaTypeTypeSubst.weaken (lookup x s) ||
            ≡⟨ TypeSubstSizeLemmas.||weaken-a|| (lookup x s) ⟩
          m|| lookup x s ||
            ≡⟨ p x ⟩
          1 ∎
    ||a/s|| {m} {ν} (simpl (mvar x)) s p = begin
      m|| (simpl (mvar x)) / s ||
        ≡⟨ cong m||_|| (MetaTypeTypeLemmas.var-/ {x = x}) ⟩
      m|| lookup x s ||
        ≡⟨ p x ⟩
      1 ∎
    ||a/s|| (simpl (tvar x)) s p = refl
    ||a/s|| (simpl (a →' b)) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (simpl (tc c)) s p = refl

    ||open-meta-a||≡a : ∀ {m ν} (a : MetaType m (suc ν)) → m|| open-meta a || ≡ m|| a ||
    ||open-meta-a||≡a {m} {ν} a = begin
      m|| open-meta a ||
        ≡⟨ TypeSubstSizeLemmas.||a/s|| (MMS.weaken a) (MTS.sub (simpl (mvar zero))) lem ⟩
      m|| (MMS.weaken a) ||
        ≡⟨ ||weaken-a|| a ⟩
      m|| a || ∎
        where
          module MMS = MetaTypeMetaSubst
          module MTS = MetaTypeTypeSubst
          lem : ∀ (x : Fin (suc ν)) → m|| lookup x (MetaTypeTypeSubst.sub (simpl (mvar zero))) || ≡ 1
          lem zero = refl
          lem (suc x) =
            cong m||_|| (MetaTypeTypeLemmas.lookup-sub-↑⋆ {t = (simpl (mvar zero))} zero x)

module SubstSizeLemmas where
  open TypeLemmas

  mutual
    ||a|| : ∀ {ν} (a : Type ν) → || a || ≥ 1
    ||a|| (simpl (tc x)) = s≤s z≤n
    ||a|| (simpl (tvar n)) = s≤s z≤n
    ||a|| (simpl (a →' b)) = s≤s z≤n
    ||a|| (a ⇒ b) = s≤s z≤n
    ||a|| (∀' a) = s≤s z≤n

    ||a/Var|| : ∀ {ν μ} (a : Type ν) (s : Sub Fin ν μ) → || a /Var s || ≡ || a ||
    ||a/Var|| (a ⇒ b) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (∀' a) s = cong (λ u → 1 + u) (||a/Var|| a (s VarSubst.↑))
    ||a/Var|| (simpl (tvar x)) s = refl
    ||a/Var|| (simpl (a →' b)) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (simpl (tc c)) s = refl

    ||weaken-a|| : ∀ {ν} (a : Type ν) → || weaken a || ≡ || a ||
    ||weaken-a|| {ν} a = begin
      || weaken a ||
        ≡⟨ refl ⟩
      || a /Var VarSubst.wk ||
        ≡⟨ ||a/Var|| a VarSubst.wk ⟩
      || a || ∎

    ||s↑|| : ∀ {ν μ} (s : Sub Type ν μ) →
                       (∀ (x : Fin ν) → || lookup x s || ≡ 1) →
                       ∀ y → || lookup y (s ↑) || ≡ 1
    ||s↑|| s p zero = refl
    ||s↑|| s p (suc y) = begin
      || lookup y (map weaken s) ||
        ≡⟨ cong ||_|| (sym $ lookup⋆map s weaken y) ⟩
      || weaken (lookup y s) ||
        ≡⟨ ||weaken-a|| (lookup y s) ⟩
      || (lookup y s) ||
        ≡⟨ p y ⟩
      1 ∎

    ||a/s|| : ∀ {ν μ} (a : Type ν) (s : Sub Type ν μ) →
             (∀ x → || lookup x s || ≡ 1) →
             || a / s || ≡ || a ||
    ||a/s|| (a ⇒ b) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (∀' a) s p = cong (λ u → 1 + u) (||a/s|| a (s ↑) (||s↑|| s p))
    ||a/s|| {m} {ν} (simpl (tvar x)) s p = begin
      || (simpl (tvar x)) / s ||
        ≡⟨ cong ||_|| (var-/ {x = x}) ⟩
      || lookup x s ||
        ≡⟨ p x ⟩
      1 ∎
    ||a/s|| (simpl (a →' b)) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (simpl (tc c)) s p = refl

    ||a/wk↑k|| : ∀ {ν} k (a : Type (k + ν)) → || a / wk ↑⋆ k || ≡ || a ||
    ||a/wk↑k|| k a = ||a/s|| a (wk ↑⋆ k) (λ x → cong ||_|| (lookup-wk-↑⋆ k x))

    ||a/s||' : ∀ {ν μ} (a : Type ν) (s : Sub Type ν μ) → || a || ≤ || a / s ||
    ||a/s||' (simpl (tc x)) s = s≤s z≤n
    ||a/s||' (simpl (tvar n)) s = ||a|| (lookup n s)
    ||a/s||' (simpl (a →' b)) s = s≤s (<-+ (||a/s||' a s) (||a/s||' b s))
    ||a/s||' (a ⇒ b) s = s≤s (<-+ (||a/s||' a s) (||a/s||' b s))
    ||a/s||' (∀' b) s = s≤s (||a/s||' b (s TypeSubst.↑))

    h||a/s|| : ∀ {ν μ} (a : Type ν) (s : Sub Type ν μ) → (, a) hρ≤ (, a / s)
    h||a/s|| (simpl (tc x)) s = s≤s z≤n
    h||a/s|| (simpl (tvar n)) s = ||a|| (proj₂ (lookup n s ◁))
    h||a/s|| (simpl (a →' b)) s = s≤s (<-+ (||a/s||' a s) (||a/s||' b s))
    h||a/s|| (a ⇒ b) s = h||a/s|| b s
    h||a/s|| (∀' b) s = h||a/s|| b (s TypeSubst.↑)

a-ρ<-∀a : ∀ {n} a → (suc n , a) ρ< (, ∀' a)
a-ρ<-∀a _ = ≤-refl

b-ρ<-a⇒b : ∀ {ν} (a b : Type ν) → (_ , b) ρ< (_ , a ⇒ b)
b-ρ<-a⇒b a b = s≤s (≤-steps || a || ≤-refl)

b-hρ≤-a⇒b : ∀ {ν} (a b : Type ν) → (_ , b) hρ≤ (_ , a ⇒ b)
b-hρ≤-a⇒b a b = subst (λ u → u ≤ h|| a ⇒ b ||) refl ≤-refl

a-m<-∀a : ∀ {m ν} a → (m , suc ν , a) m< (m , ν , ∀' a)
a-m<-∀a a = ≤-refl

b-m<-a⇒b : ∀ {m ν} a b → (m , ν , b) m< (m , ν , a ⇒ b)
b-m<-a⇒b a b = s≤s (≤-steps m|| a || ≤-refl)

open-meta-a-m<-∀'a : ∀ {m ν} a → (suc m , ν , open-meta a) m< (m , ν , ∀' a)
open-meta-a-m<-∀'a a = subst (λ x → x < m||  ∀' a ||)
  (sym $ MetaSubstSizeLemmas.||open-meta-a||≡a a) (a-m<-∀a a)


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

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Base.ByteString
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
open import LibraBFT.Hash
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Util.Util
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId

-- This is a minimal/fake example handler that obeys the VotesOnce rule, enabling us to start
-- exploring how we express the algorithm and prove properties about it.  It simply sends a vote for
-- 1 + its LatestVotedRound, and increments its LatestVotedRound.  It is called RoundManager for
-- historical reasons, because this what a previous version of LibraBFT called its main handler;
-- this will be updated when we move towards modeling a more recent implementation.

module LibraBFT.Impl.Consensus.RoundManager where

  open RWST-do

  processCommitM : LedgerInfoWithSignatures → LBFT (List ExecutedBlock)
  processCommitM finalityProof = pure []

  fakeAuthor : Author
  fakeAuthor = 0

  fakeBlockInfo : Epoch → Round → ProposalMsg → BlockInfo
  fakeBlockInfo eid rnd pm = BlockInfo∙new eid rnd (pm ^∙ pmProposal ∙ bId)

  fakeLedgerInfo : BlockInfo → ProposalMsg → LedgerInfo
  fakeLedgerInfo bi pm = LedgerInfo∙new bi (pm ^∙ pmProposal ∙ bId)

  postulate -- TODO-1: these are temporary scaffolding for the fake implementation
    fakeSK  : SK
    fakeSig : Signature

  processProposalMsg : Instant → ProposalMsg → LBFT Unit
  processProposalMsg inst pm = do
    st ← get
    xx ← use rmHighestQC   -- Not used; just a demonstration that our RoundManager-specific "use" works
    modify' rmHighestQC xx -- Similarly for modify'
    let RoundManager∙new rm rmc rmw = st
        𝓔  = α-EC (rm , rmc)
        e  = rm ^∙ rmEpoch
        nr = suc (rm ^∙ rmLastVotedRound)
        uv = Vote∙new
                    (VoteData∙new (fakeBlockInfo e nr pm) (fakeBlockInfo e 0 pm))
                    fakeAuthor
                    (fakeLedgerInfo (fakeBlockInfo e nr pm) pm)
                    fakeSig
                    nothing
        sv = record uv { ₋vSignature = sign ⦃ sig-Vote ⦄ uv fakeSK}
        bt = rmw ^∙ (lBlockTree 𝓔)
        si = SyncInfo∙new (₋btHighestQuorumCert bt) (₋btHighestCommitCert bt)
        rm' = rm [ rmLastVotedRound := nr ]
        st' = RoundManager∙new rm' (RoundManagerEC-correct-≡ (₋rmEC st) rm' refl rmc)
                                   (subst RoundManagerWithEC (α-EC-≡ rm rm' refl refl rmc) rmw)
    put st'
    tell1 (SendVote (VoteMsg∙new sv si) (fakeAuthor ∷ []))
    pure unit

  processVote : Instant → VoteMsg → LBFT Unit
  processVote now msg = pure unit


module Model where

open import Data.Product
open import Data.Char
open import Data.String
open import Data.Container.Indexed
open import IO.Primitive

open import Signature

postulate
  Model        : Set
  initialModel : Model

  moveModel          : Dir → Model → Model
  setMode            : Mode → Model → Model
  getPrompt          : Model → Prompt
  addCharToBuffer    : Char → Model → Model
  getBuffer          : Model → String
  setCurrentFeed     : Model → Feed → Model
  getCurrentFeedsUrl : Model → String
  searchModel        : String → Model → Model
  searchNextModel    : String → Model → Model
  addFeedToModel     : String → Model → Model

cmdToResp : ∀ {m} (c : Command Hårss m) → Model → IO (Response Hårss c)
cmdToResp (moveP d)    m = return _
cmdToResp (promptP p)  m = return _
cmdToResp (putCharP c) m = return _
cmdToResp doneP        m = return (getBuffer m , getPrompt m)
cmdToResp fetchP       m = fetchUrl (getCurrentFeedsUrl m)
  where
  postulate
    fetchUrl : String → IO Feed
cmdToResp searchNextP  m = return (getBuffer m)


{-# OPTIONS --erased-cubical --no-main --save-metas #-}

open import Agda.Builtin.Bool

open import Erased-cubical-Cubical

postulate
  f : Not-compiled → Bool

-- It is at the time of writing not possible to give a COMPILE GHC
-- pragma for f, because Not-compiled is not compiled.

{-# COMPILE GHC f = \_ -> True #-}


open import Prelude

open import Level using (_⊔_; Lift; lift) renaming (suc to ls; zero to lz)
open import Data.String using (String)
open import Data.Maybe using (Maybe; nothing; just)
open import Data.Nat using (_≤_)

open import RW.Data.RTrie.Decl

module RW.Data.RTrie.Lookup
    where

  postulate
    trie-err : ∀{a}{A : Set a} → String → A

  open import RW.Utils.Monads
  open Monad {{...}}
  open Eq {{...}}

  import RW.Data.PMap (RTermᵢ ⊥) as IdxMap
  import RW.Data.PMap ℕ as ℕmap

  -------------------------------
  -- Some type boilerplate

  Label : Set
  Label = ℕ ⊎ Name

  Lst : Set
  Lst = ℕmap.to (RTerm ⊥) × Maybe Label

  Lst-empty : Lst
  Lst-empty = ℕmap.empty , nothing

  Lst-open : Lst → (ℕmap.to (RTerm ⊥) × Maybe Name)
  Lst-open (e , l) = (e , lbl-join l)
    where
      lbl-join : Maybe Label → Maybe Name
      lbl-join nothing = nothing
      lbl-join (just (i1 _)) = nothing
      lbl-join (just (i2 a)) = just a

  ---------------------------
  -- Lookup monad

  L : Set → Set
  L = Reader (List Lst)

  ----------------------------
  -- Rule application

  -- Note how a mismatch erases labels!
  applyBRule1 : Rule → Lst → Lst
  applyBRule1 (Gr x)   (e , _) = e , just (i1 x)
  applyBRule1 (Tr x y) (e , just (i1 l))
    with x ≟-ℕ l
  ...| yes _ = e , just (i1 y)
  ...| no  _ = e , nothing
  applyBRule1 (Tr x y) (e , just (i2 _)) = e , nothing
  applyBRule1 (Fr x y) (e , just (i1 l))
    with x ≟-ℕ l
  ...| yes _ = e , just (i2 y)
  ...| no  _ = e , nothing
  applyBRule1 (Fr _ _) (e , just (i2 _)) = e , nothing
  applyBRule1 _        (e , nothing) = e , nothing

  applyBRule : Rule → L (List Lst)
  applyBRule r = reader-ask >>= return ∘ (Prelude.map (applyBRule1 r))

  ruleList : List Rule → L (List Lst)
  ruleList rs = mapM applyBRule rs >>= return ∘ concat
    where
      isNothing : ∀{a}{A : Set a} → Maybe A → Bool
      isNothing nothing = true
      isNothing _       = false

      prune : List Lst → List Lst
      prune = Prelude.filter (isNothing ∘ p2)

  ------------------------------
  -- Actual Lookup

  map-filter : ∀{a}{A B : Set a} → (B → Bool) → (A → B) → List A → List B
  map-filter p f = foldr (λ h r → let x = f h in ite (p x) (x ∷ r) r) []
    where
      ite : ∀{a}{A : Set a} → Bool → A → A → A
      ite true  t _ = t
      ite false _ e = e

  mutual
    -- TODO: refine this, only apply the rules after validating and adding bindings.
    lkup-inst1 : RTerm ⊥ → ℕ × List Rule → L (List Lst)
    lkup-inst1 k (s , r)
      = ruleList r
      >>= return ∘ map-filter (isValid s k) (addUnbound s k)
      where
        addUnbound : ℕ → RTerm ⊥ → Lst → Lst
        addUnbound s k (e , l) = (ℕmap.alter (maybe just (just k)) s e , l)

        toBool : ∀{a}{A : Set a} → Dec A → Bool
        toBool (yes _) = true
        toBool (no  _) = false

        isValid : ℕ → RTerm ⊥ → Lst → Bool
        isValid s k (e , l) = toBool (ℕmap.lkup s e ≟2 just k)
          where
            _≟2_ : (a₁ a₂ : Maybe (RTerm ⊥)) → Dec (a₁ ≡ a₂)
            _≟2_ a b = Eq.cmp eq-Maybe a b

    -- Looks up a term given a list of instantiations.
    -- This is not, by far, a lookup function. We're just adding all possibilities together.
    lkup-inst : RTerm ⊥ → List (ℕ × List Rule) → L (List Lst)
    lkup-inst t [] = return []
    lkup-inst t rs = mapM (lkup-inst1 t) rs >>= return ∘ concat

    -- Looks a list of RTerms in their respecive cells.
    {-# TERMINATING #-}
    lkup-list : List (RTerm ⊥ × Cell)
              → L (List Lst)
    lkup-list [] = return []
    lkup-list ((t , (d , mh) , bs) ∷ ts)
      = lkup-aux t (Fork (((d , mh) , bs) ∷ []))
      >>= λ s₁ → (reader-local (_++_ s₁) $ lkup-list ts)
      >>= return ∘ (_++_ s₁)

    lkup-aux : RTerm ⊥ → RTrie → L (List Lst)
    lkup-aux _ (Leaf r) = ruleList r
    lkup-aux k (Fork (((d , rs) , bs) ∷ []))
      = let tid , tr = out k
      in lkup-inst k bs
      -- If tid ∉ mh, we run the lookup again, but in the default branch.
      -- Otherwise, we run a lkup-list.
      >>= λ r → maybe (lkup≡just tr) (lkup-aux k d) (IdxMap.lkup tid rs)
      >>= return ∘ (_++_ r)
      where
        lkup≡just : List (RTerm ⊥) → RTrie → L (List Lst)
        lkup≡just [] (Leaf r) = ruleList r
        lkup≡just _  (Leaf _) = return []
        lkup≡just tr (Fork ms) = lkup-list (zip tr ms)

    lkup-aux _ _ = trie-err "lkup-aux takes 1-cell forks"

  -- Interfacing
  lookup : RTerm ⊥ → RTrie → List (ℕmap.to (RTerm ⊥) × Name)
  lookup t bt = accept (Prelude.map Lst-open (lkup-aux t bt (Lst-empty ∷ [])))
    where
      accept : ∀{a}{A : Set a} → List (A × Maybe Name) → List (A × Name)
      accept [] = []
      accept ((a , just b) ∷ hs) = (a , b) ∷ accept hs
      accept (_ ∷ hs)            = accept hs


{- 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
-}

import      LibraBFT.Impl.Consensus.ConsensusTypes.Vote               as Vote
import      LibraBFT.Impl.Consensus.ConsensusTypes.TimeoutCertificate as TimeoutCertificate
open import LibraBFT.Impl.OBM.Rust.RustTypes
import      LibraBFT.Impl.Types.CryptoProxies                         as CryptoProxies
import      LibraBFT.Impl.Types.LedgerInfoWithSignatures              as LedgerInfoWithSignatures
import      LibraBFT.Impl.Types.ValidatorVerifier                     as ValidatorVerifier
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Hash
import      Util.KVMap                                                as Map
open import Util.Prelude

module LibraBFT.Impl.Consensus.PendingVotes where

insertVoteM : Vote → ValidatorVerifier → LBFT VoteReceptionResult
insertVoteM vote vv = do
  let liDigest = hashLI (vote ^∙ vLedgerInfo)
  atv          ← use (lPendingVotes ∙ pvAuthorToVote)
  caseMD Map.lookup (vote ^∙ vAuthor) atv of λ where
    (just previouslySeenVote) →
      ifD liDigest ≟Hash (hashLI (previouslySeenVote ^∙ vLedgerInfo))
      then (do
        let newTimeoutVote = Vote.isTimeout vote ∧ not (Vote.isTimeout previouslySeenVote)
        if not newTimeoutVote
          then pure DuplicateVote
          else continue1 liDigest)
      else
        pure EquivocateVote
    nothing →
      continue1 liDigest

 where

  continue2 : U64 → LBFT VoteReceptionResult

  continue1 : HashValue → LBFT VoteReceptionResult
  continue1 liDigest = do
    pv            ← use lPendingVotes
    lPendingVotes ∙ pvAuthorToVote %= Map.kvm-insert-Haskell (vote ^∙ vAuthor) vote
    let liWithSig = CryptoProxies.addToLi (vote ^∙ vAuthor) (vote ^∙ vSignature)
                      (fromMaybe (LedgerInfoWithSignatures∙new (vote ^∙ vLedgerInfo) Map.empty)
                                 (Map.lookup liDigest (pv ^∙ pvLiDigestToVotes)))
    lPendingVotes ∙ pvLiDigestToVotes %= Map.kvm-insert-Haskell liDigest liWithSig
    case⊎D ValidatorVerifier.checkVotingPower vv (Map.kvm-keys (liWithSig ^∙ liwsSignatures)) of λ where
      (Right unit) →
        pure (NewQuorumCertificate (QuorumCert∙new (vote ^∙ vVoteData) liWithSig))
      (Left (ErrVerify (TooLittleVotingPower votingPower _))) →
        continue2 votingPower
      (Left _) →
        pure VRR_TODO

  continue2 qcVotingPower =
    caseMD vote ^∙ vTimeoutSignature of λ where
      (just timeoutSignature) → do
        pv            ← use lPendingVotes
        let partialTc = TimeoutCertificate.addSignature (vote ^∙ vAuthor) timeoutSignature
                          (fromMaybe (TimeoutCertificate∙new (Vote.timeout vote))
                                     (pv ^∙ pvMaybePartialTC))
        lPendingVotes ∙ pvMaybePartialTC %= const (just partialTc)
        case⊎D ValidatorVerifier.checkVotingPower vv (Map.kvm-keys (partialTc ^∙ tcSignatures)) of λ where
          (Right unit) →
            pure (NewTimeoutCertificate partialTc)
          (Left (ErrVerify (TooLittleVotingPower votingPower _))) →
            pure (TCVoteAdded votingPower)
          (Left _) →
            pure VRR_TODO
      nothing →
        pure (QCVoteAdded qcVotingPower)


module Generic.Lib.Reflection.Core where

open import Agda.Builtin.Reflection using (withNormalisation; Relevance; Visibility; clause) public
open import Reflection
  renaming (visible to expl; hidden to impl; instance′ to inst;
    relevant to rel; irrelevant to irr; pi to absPi; lam to absLam; def to appDef)
  hiding (Arg-info; var; con; meta; visibility; relevance; _≟_; return; _>>=_; _>>_) public
open import Reflection.Argument.Information using (ArgInfo; visibility; relevance) public
import Reflection.Name
open Term    using () renaming (var to appVar; con to appCon; meta to appMeta) public
open Pattern using () renaming (var to patVar; con to patCon) public
open Literal using () renaming (meta to litMeta) public
open Sort public

open import Generic.Lib.Intro
open import Generic.Lib.Equality.Propositional
open import Generic.Lib.Decidable
open import Generic.Lib.Category
open import Generic.Lib.Data.Nat
open import Generic.Lib.Data.String
open import Generic.Lib.Data.Maybe
open import Generic.Lib.Data.Product
open import Generic.Lib.Data.List

open import Data.Vec using (toList)
open import Data.Vec.N-ary using (N-ary; curryⁿ)

infixr 5 _‵→_
infixl 3 _·_

listCurryⁿ : ∀ {α β} {A : Set α} {B : Set β} n -> (List A -> B) -> N-ary n A B
listCurryⁿ n f = curryⁿ {n = n} (f ∘ toList)

named : String -> String
named s = if s == "_" then "x" else s

record Reify {α} (A : Set α) : Set α where
  field reify : A -> Term

  macro
    reflect : A -> Term -> TC _
    reflect = unify ∘ reify
open Reify {{...}} public

pattern pureVar  n = appVar  n []
pattern pureCon  c = appCon  c []
pattern pureDef  f = appDef  f []
pattern pureMeta m = appMeta m []

{-# DISPLAY appVar  i [] = pureVar  i #-}
{-# DISPLAY appCon  c [] = pureCon  c #-}
{-# DISPLAY appDef  f [] = pureDef  f #-}
{-# DISPLAY appMeta m [] = pureMeta m #-}

pattern explInfo r = arg-info expl r
pattern implInfo r = arg-info impl r
pattern instInfo r = arg-info inst r

{-# DISPLAY arg-info expl r = explInfo r #-}
{-# DISPLAY arg-info impl r = implInfo r #-}
{-# DISPLAY arg-info inst r = instInfo r #-}

pattern explRelInfo = explInfo rel
pattern explIrrInfo = explInfo irr
pattern implRelInfo = implInfo rel
pattern implIrrInfo = implInfo irr
pattern instRelInfo = instInfo rel
pattern instIrrInfo = instInfo irr

{-# DISPLAY explInfo rel = explRelInfo #-}
{-# DISPLAY explInfo irr = explIrrInfo #-}
{-# DISPLAY implInfo rel = implRelInfo #-}
{-# DISPLAY implInfo irr = implIrrInfo #-}
{-# DISPLAY instInfo rel = instRelInfo #-}
{-# DISPLAY instInfo irr = instIrrInfo #-}

pattern explArg r x = arg (explInfo r) x
pattern implArg r x = arg (implInfo r) x
pattern instArg r x = arg (instInfo r) x

{-# DISPLAY arg (explInfo r) = explArg r #-}
{-# DISPLAY arg (implInfo r) = implArg r #-}
{-# DISPLAY arg (instInfo r) = instArg r #-}

pattern explRelArg x = explArg rel x
pattern implRelArg x = implArg rel x
pattern instRelArg x = instArg rel x

{-# DISPLAY explArg rel x = explRelArg x #-}
{-# DISPLAY implArg rel x = implRelArg x #-}
{-# DISPLAY instArg rel x = instRelArg x #-}

pattern pi s a b = absPi a (abs s b)

{-# DISPLAY absPi a (abs s b) = pi s a b #-}

pattern explPi r s a b = pi s (explArg r a) b
pattern implPi r s a b = pi s (implArg r a) b
pattern instPi r s a b = pi s (instArg r a) b

{-# DISPLAY pi (explArg r a) s b = explPi r s a b #-}
{-# DISPLAY pi (implArg r a) s b = implPi r s a b #-}
{-# DISPLAY pi (instArg r a) s b = instPi r s a b #-}

pattern explRelPi s a b = explPi rel a s b
pattern explIrrPi s a b = explPi irr a s b
pattern implRelPi s a b = implPi rel a s b
pattern implIrrPi s a b = implPi irr a s b
pattern instRelPi s a b = instPi rel a s b
pattern instIrrPi s a b = instPi irr a s b

{-# DISPLAY explPi rel a s b = explRelPi s a b #-}
{-# DISPLAY explPi irr a s b = explIrrPi s a b #-}
{-# DISPLAY implPi rel a s b = implRelPi s a b #-}
{-# DISPLAY implPi irr a s b = implIrrPi s a b #-}
{-# DISPLAY instPi rel a s b = instRelPi s a b #-}
{-# DISPLAY instPi irr a s b = instIrrPi s a b #-}

pattern lam v s t = absLam v (abs s t)

{-# DISPLAY absLam v (abs s t) = lam v s t #-}

pattern explLam s t = lam expl s t
pattern implLam s t = lam impl s t
pattern instLam s t = lam inst s t

{-# DISPLAY lam expl s t = explLam s t #-}
{-# DISPLAY lam impl s t = implLam s t #-}
{-# DISPLAY lam inst s t = instLam s t #-}

pattern _‵→_ a b = pi "_" (explRelArg a) b

-- No longer parses for whatever reason.
-- {-# DISPLAY pi "_" (explRelArg a) b = a ‵→ b #-}

mutual
  <_>_ : ∀ {α} -> Relevance -> Set α -> Set α
  <_>_ = flip RelValue

  data RelValue {α} (A : Set α) : Relevance -> Set α where
    relv :  A -> < rel > A
    irrv : .A -> < irr > A

elimRelValue : ∀ {r α π} {A : Set α}
             -> (P : ∀ {r} -> < r > A -> Set π)
             -> (∀  x -> P (relv x))
             -> (∀ .x -> P (irrv x))
             -> (x : < r > A)
             -> P x
elimRelValue P f g (relv x) = f x
elimRelValue P f g (irrv x) = g x

unrelv : ∀ {α} {A : Set α} -> < rel > A -> A
unrelv (relv x) = x

-- Is it possible to handle this in some other way that doesn't require a postulate?
-- See the `appRel` function below. Or is the postulate fine?
postulate
  .unirrv : ∀ {α} {A : Set α} -> < irr > A -> A

<_>_~>_ : ∀ {α β} -> Relevance -> Set α -> Set β -> Set (α ⊔ β)
< rel > A ~> B =  A -> B
< irr > A ~> B = .A -> B

lamRel : ∀ {r α β} {A : Set α} {B : Set β} -> (< r > A -> B) -> < r > A ~> B
lamRel {rel} f = λ x -> f (relv x)
lamRel {irr} f = λ x -> f (irrv x)

-- The laziness is intentional.
appRel : ∀ {r α β} {A : Set α} {B : Set β} -> (< r > A ~> B) -> < r > A -> B
appRel {rel} f rx = f (unrelv rx)
appRel {irr} f rx = f (unirrv rx)

Pi : ∀ {α β} i -> (A : Set α) -> (< relevance i > A -> Set β) -> Set (α ⊔ β)
Pi explRelInfo A B =   (x : A)  -> B (relv x)
Pi explIrrInfo A B = . (x : A)  -> B (irrv x)
Pi implRelInfo A B =   {x : A}  -> B (relv x)
Pi implIrrInfo A B = . {x : A}  -> B (irrv x)
Pi instRelInfo A B =  {{x : A}} -> B (relv x)
Pi instIrrInfo A B = .{{x : A}} -> B (irrv x)

lamPi : ∀ {α β} {A : Set α} i {B : < relevance i > A -> Set β} -> (∀ x -> B x) -> Pi i A B
lamPi explRelInfo f = λ x -> f (relv x)
lamPi explIrrInfo f = λ x -> f (irrv x)
lamPi implRelInfo f = f _
lamPi implIrrInfo f = f _
lamPi instRelInfo f = f _
lamPi instIrrInfo f = f _

appPi : ∀ {α β} {A : Set α} i {B : < relevance i > A -> Set β} -> Pi i A B -> ∀ x -> B x
appPi explRelInfo f (relv x) = f x
appPi explIrrInfo f (irrv x) = f x
appPi implRelInfo y (relv x) = y
appPi implIrrInfo y (irrv x) = y
appPi instRelInfo y (relv x) = y {{x}}
appPi instIrrInfo y (irrv x) = y {{x}}

RelEq : ∀ {α} -> Relevance -> Set α -> Set α
RelEq rel A = Eq A
RelEq irr A = ⊤

vis : {A : Set} -> (A -> List (Arg Term) -> Term) -> A -> List Term -> Term
vis k x = k x ∘ map explRelArg

vis# : ∀ {A : Set} n -> (A -> List (Arg Term) -> Term) -> A -> N-ary n Term Term
vis# n k = listCurryⁿ n ∘ vis k

isRelevant : Relevance -> Bool
isRelevant rel = true
isRelevant irr = false

argInfo : ∀ {α} {A : Set α} -> Arg A -> _
argInfo (arg i x) = i

argVal : ∀ {α} {A : Set α} -> Arg A -> A
argVal (arg i x) = x

unExpl : ∀ {α} {A : Set α} -> Arg A -> Maybe A
unExpl (explArg r x) = just x
unExpl  _            = nothing

absName : ∀ {α} {A : Set α} -> Abs A -> String
absName (abs s x) = s

absVal : ∀ {α} {A : Set α} -> Abs A -> A
absVal (abs s x) = x

patVars : List String -> List (Arg Pattern)
patVars = map (explRelArg ∘ patVar ∘ named)

record Data {α} (A : Set α) : Set α where
  no-eta-equality
  constructor packData
  field
    dataName  : Name
    parsTele  : Type
    indsTele  : Type
    consTypes : List A
    consNames : All (const Name) consTypes
open Data public

instance
  NameEq : Eq Name
  NameEq = viaBase Reflection.Name._≟_

  EqRelValue : ∀ {α r} {A : Set α} {{aEq : RelEq r A}} -> Eq (< r > A)
  EqRelValue {A = A} {{aEq}} = record
    { _≟_ = go
    } where
        relv-inj : {x y : A} -> relv x ≡ relv y -> x ≡ y
        relv-inj refl = refl

        go : ∀ {r} {{aEq : RelEq r A}} -> IsSet (< r > A)
        go (relv x) (relv y) = dcong relv relv-inj (x ≟ y)
        go (irrv x) (irrv y) = yes refl

  ArgFunctor : ∀ {α} -> RawFunctor {α} Arg
  ArgFunctor = record
    { _<$>_ = λ{ f (arg i x) -> arg i (f x) }
    }

  AbsFunctor : ∀ {α} -> RawFunctor {α} Abs
  AbsFunctor = record
    { _<$>_ = λ{ f (abs s x) -> abs s (f x) }
    }

  TCMonad : ∀ {α} -> RawMonad {α} TC
  TCMonad = record
    { return = Reflection.return
    ; _>>=_  = Reflection._>>=_
    }

  TCApplicative : ∀ {α} -> RawApplicative {α} TC
  TCApplicative = rawIApplicative

  TCFunctor : ∀ {α} -> RawFunctor {α} TC
  TCFunctor = rawFunctor

keep : (ℕ -> ℕ) -> ℕ -> ℕ
keep ι  0      = 0
keep ι (suc n) = suc (ι n)

{-# TERMINATING #-}
mutual
  ren : (ℕ -> ℕ) -> Term -> Term
  ren ι (appVar v xs)   = appVar (ι v) (rens ι xs)
  ren ι (appCon c xs)   = appCon c (rens ι xs)
  ren ι (appDef f xs)   = appDef f (rens ι xs)
  ren ι (lam v s t)     = lam v s (ren (keep ι) t)
  ren ι (pat-lam cs xs) = undefined where postulate undefined : _
  ren ι (pi s a b)      = pi s (ren ι <$> a) (ren (keep ι) b)
  ren ι (agda-sort s)   = agda-sort (renSort ι s)
  ren ι (lit l)         = lit l
  ren ι (appMeta x xs)  = appMeta x (rens ι xs)
  ren ι  unknown        = unknown

  rens : (ℕ -> ℕ) -> List (Arg Term) -> List (Arg Term)
  rens ι = map (fmap (ren ι))

  renSort : (ℕ -> ℕ) -> Sort -> Sort
  renSort ι (set t) = set (ren ι t)
  renSort ι (lit n) = lit n
  renSort ι unknown = unknown

shiftBy : ℕ -> Term -> Term
shiftBy = ren ∘ _+_

shift : Term -> Term
shift = shiftBy 1

unshiftBy : ℕ -> Term -> Term
unshiftBy n = ren (_∸ n)

isSomeName : Name -> Term -> Bool
isSomeName n (appDef m _) = n == m
isSomeName n (appCon m _) = n == m
isSomeName n  t           = false

{-# TERMINATING #-}
mutual
  mapName : (ℕ -> List (Arg Term) -> Term) -> Name -> Term -> Term
  mapName f n (appVar v xs)   = appVar v (mapNames f n xs)
  mapName f n (appCon m xs)   = (if n == m then f 0 else appCon m) (mapNames f n xs)
  mapName f n (appDef m xs)   = (if n == m then f 0 else appDef m) (mapNames f n xs)
  mapName f n (lam v s t)     = lam v s (mapName (f ∘ suc) n t)
  mapName f n (pat-lam cs xs) = undefined where postulate undefined : _
  mapName f n (pi s a b)      = pi s (mapName f n <$> a) (mapName (f ∘ suc) n b)
  mapName f n (agda-sort s)   = agda-sort (mapNameSort f n s)
  mapName f n (lit l)         = lit l
  mapName f n (appMeta x xs)  = appMeta x (mapNames f n xs)
  mapName f n  unknown        = unknown

  mapNames : (ℕ -> List (Arg Term) -> Term) -> Name -> List (Arg Term) -> List (Arg Term)
  mapNames f n = map (fmap (mapName f n))

  mapNameSort : (ℕ -> List (Arg Term) -> Term) -> Name -> Sort -> Sort
  mapNameSort f n (set t) = set (mapName f n t)
  mapNameSort f n (lit l) = lit l
  mapNameSort f n unknown = unknown

explsOnly : List (Arg Term) -> List Term
explsOnly = mapMaybe unExpl

initType : Type -> Type
initType (pi s a b) = pi s a (initType b)
initType  b         = unknown

lastType : Type -> Type
lastType (pi s a b) = lastType b
lastType  b         = b

-- These two should return just `Type` like everything else.
takePis : ℕ -> Type -> Maybe Type
takePis  0       a         = just unknown
takePis (suc n) (pi s a b) = pi s a <$> takePis n b
takePis  _       _         = nothing

dropPis : ℕ -> Type -> Maybe Type
dropPis  0       a         = just a
dropPis (suc n) (pi s a b) = dropPis n b
dropPis  _       _         = nothing

monoLastType : Type -> Type
monoLastType = go 0 where
  go : ℕ -> Type -> Type
  go n (pi s a b) = go (suc n) b
  go n  b         = unshiftBy n b

appendType : Type -> Type -> Type
appendType (pi s a b) c = pi s a (appendType b c)
appendType  b         c = c

explLamsBy : Type -> Term -> Term
explLamsBy (explPi r s a b) t = explLam s (explLamsBy b t)
explLamsBy (pi       s a b) t = explLamsBy b t
explLamsBy  b               t = t

implicitize : Type -> Type
implicitize (explPi r s a b) = implPi r s a (implicitize b)
implicitize (pi       s a b) = pi       s a (implicitize b)
implicitize  b               = b

leadImpls : Type -> List (Abs Term)
leadImpls (implPi r s a b) = abs s a ∷ leadImpls b
leadImpls  b               = []

pisToAbsArgTypes : Type -> List (Abs (Arg Type))
pisToAbsArgTypes (pi s a b) = abs s a ∷ pisToAbsArgTypes b
pisToAbsArgTypes  b         = []

explPisToAbsTypes : Type -> List (Abs Type)
explPisToAbsTypes (explPi r s a b) = abs s a ∷ explPisToAbsTypes b
explPisToAbsTypes (pi       s a b) = explPisToAbsTypes b
explPisToAbsTypes  b               = []

explPisToNames : Type -> List String
explPisToNames = map absName ∘ explPisToAbsTypes

countPis : Type -> ℕ
countPis = length ∘ pisToAbsArgTypes

countExplPis : Type -> ℕ
countExplPis = length ∘ explPisToAbsTypes

pisToAbsArgVars : ℕ -> Type -> List (Abs (Arg Term))
pisToAbsArgVars (suc n) (pi s (arg i a) b) = abs s (arg i (pureVar n)) ∷ pisToAbsArgVars n b
pisToAbsArgVars  n       b                 = []

pisToArgVars : ℕ -> Type -> List (Arg Term)
pisToArgVars = map absVal % ∘ pisToAbsArgVars

explPisToAbsVars : ℕ -> Type -> List (Abs Term)
explPisToAbsVars (suc n) (explPi r s a b) = abs s (pureVar n) ∷ explPisToAbsVars n b
explPisToAbsVars (suc n) (pi       s a b) = explPisToAbsVars n b
explPisToAbsVars  n       b               = []

throw : ∀ {α} {A : Set α} -> String -> TC A
throw s = typeError (strErr s ∷ [])

panic : ∀ {α} {A : Set α} -> String -> TC A
panic s = throw $ "panic: " ++ˢ s

-- I'll merge these later.
macro
  sate : Name -> Term -> TC _
  sate f ?r =
    getType f >>= λ a ->
    let res = λ app -> quoteTC (vis# (countExplPis a) app f) >>= unify ?r in
    getDefinition f >>= λ
      { (data-cons _) -> res appCon
      ;  _            -> res appDef
      }

  sateMacro : Name -> Term -> TC _
  sateMacro f ?r =
    getType f >>= λ a ->
    quoteTC (vis# (pred (countExplPis a)) appDef f) >>= unify ?r

_·_ : Term -> Term -> Term
_·_ = sate _$_

unshift′ : Term -> Term
unshift′ t = explLam "_" t · sate tt₀

-- A note for myself: `foldℕ (sate lsuc) (sate lzero) n` is not `reify n`:
-- it's damn `lsuc` -- not `suc`.
termLevelOf : Term -> Maybe Term
termLevelOf (agda-sort (set t)) = just t
termLevelOf (agda-sort (lit n)) = just (foldℕ (sate lsuc) (sate lzero) n)
termLevelOf (agda-sort unknown) = just unknown
termLevelOf _ = nothing

instance
  TermReify : Reify Term
  TermReify = record
    { reify = id
    }

  NameReify : Reify Name
  NameReify = record
    { reify = lit ∘′ name
    }

  VisibilityReify : Reify Visibility
  VisibilityReify = record
    { reify = λ
        { expl -> sate expl
        ; impl -> sate impl
        ; inst -> sate inst
        }
    }

  RelevanceReify : Reify Relevance
  RelevanceReify = record
    { reify = λ
        { rel -> sate rel
        ; irr -> sate irr
        }
    }

  ArgInfoReify : Reify ArgInfo
  ArgInfoReify = record
    { reify = λ{ (arg-info v r) -> sate arg-info (reify v) (reify r) }
    }

  ProdReify : ∀ {α β} {A : Set α} {B : A -> Set β}
                {{aReify : Reify A}} {{bReify : ∀ {x} -> Reify (B x)}} -> Reify (Σ A B)
  ProdReify = record
    { reify = uncurry λ x y -> sate _,_ (reify x) (reify y)
    }

  ℕReify : Reify ℕ
  ℕReify = record
    { reify = foldℕ (sate suc) (sate zero)
    }

  ListReify : ∀ {α} {A : Set α} {{aReify : Reify A}} -> Reify (List A)
  ListReify = record
    { reify = foldr (sate _∷_ ∘ reify) (sate [])
    }

  AllReify : ∀ {α β} {A : Set α} {B : A -> Set β} {xs} {{bReify : ∀ {x} -> Reify (B x)}}
           -> Reify (All B xs)
  AllReify {B = B} {{bReify}} = record
    { reify = go _
    } where
        go : ∀ xs -> All B xs -> Term
        go  []       tt      = sate tt₀
        go (x ∷ xs) (y , ys) = sate _,_ (reify {{bReify}} y) (go xs ys)

toTuple : List Term -> Term
toTuple = foldr₁ (sate _,_) (sate tt₀)

curryBy : Type -> Term -> Term
curryBy = go 0 where
  go : ℕ -> Type -> Term -> Term
  go n (pi s (arg (arg-info v r) a) b) t = lam v s $ go (suc n) b t
  go n  _                              t = shiftBy n t · toTuple (map pureVar (downFrom n))

explUncurryBy : Type -> Term -> Term
explUncurryBy a f = explLam "x" $ appDef (quote id) (explArg rel (shift f) ∷ go a (pureVar 0)) where
  go : Term -> Term -> List (Arg Term)
  go (explPi r s a b@(pi _ _ _)) p = explArg r (sate proj₁ p) ∷ go b (sate proj₂ p)
  go (pi       s a b@(pi _ _ _)) p = go b (sate proj₂ p)
  go (explPi r s a b)            x = explArg r x ∷ []
  go  _                          t = []

defineTerm : Name -> Term -> TC _
defineTerm n t =
  getType n >>= λ a ->
  defineFun n (clause (map (implRelArg ∘ patVar ∘ named ∘ absName) (leadImpls a)) t ∷ [])

-- Able to normalize a Setω.
normalize : Term -> TC Term
normalize (pi s (arg i a) b) =
  pi s ∘ arg i <$> normalize a <*> extendContext (arg i a) (normalize b)
normalize  t                 = normalise t

getNormType : Name -> TC Type
getNormType = getType >=> normalize

inferNormType : Term -> TC Type
inferNormType = inferType >=> normalize

getData : Name -> TC (Data Type)
getData d = getNormType d >>= λ ab -> getDefinition d >>= λ
  { (data-type p cs) ->
       mapM (λ c -> _,_ c ∘ dropPis p <$> getNormType c) cs >>= λ mans ->
         case takePis p ab ⊗ (dropPis p ab ⊗ (mapM (uncurry λ c ma -> flip _,_ c <$> ma) mans)) of λ
           {  nothing             -> panic "getData: data"
           ; (just (a , b , acs)) -> return ∘ uncurry (packData d a b) $ splitList acs
           }
  ; (record-type c _) -> getNormType c >>= dropPis (countPis ab) >>> λ
       {  nothing  -> panic "getData: record"
       ; (just a′) -> return $ packData d (initType ab) (lastType ab) (a′ ∷ []) (c , tt)
       }
  ;  _ -> throw "not a data"
  }

macro
  TypeOf : Term -> Term -> TC _
  TypeOf t ?r = inferNormType t >>= unify ?r

  runTC : ∀ {α} {A : Set α} -> TC A -> Term -> TC _
  runTC a ?r = bindTC a quoteTC >>= unify ?r


module OpenPublicPlusTypeError where

module X where

  postulate D : Set

open X public

postulate x : D

typeIncorrect : Set
typeIncorrect = Set1


-- Prop has been removed from the language
module PropNoMore where

postulate
  X : Prop


-- Andreas, 2016-10-11, AIM XXIV
-- COMPILED pragma accidentially also accepted for abstract definitions

open import Common.String

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () () #-}

postulate
  IO : Set → Set
  doNothing : IO Unit

{-# COMPILED_TYPE IO IO #-}
{-# BUILTIN IO IO #-}
{-# COMPILED doNothing (return ()) #-}

{-# IMPORT Data.Text.IO #-}

abstract
  putStrLn : String → IO Unit
  putStrLn _ = doNothing

{-# COMPILED putStrLn Data.Text.IO.putStrLn #-}

main = putStrLn "Hello, world!"

-- WAS: compiler produced ill-formed Haskell-code
-- NOW: Error on COMPILED pragma


module Untyped.Abstract where

open import Function

open import Data.String
open import Data.Nat
open import Data.Unit
open import Data.Product
open import Data.List
open import Data.Sum as Sum
open import Data.Maybe
open import Strict

open import Debug.Trace
open import Category.Monad

open import Untyped.Monads

postulate fail : ∀ {a : Set} → a

willneverhappenipromise : ∀ {a : Set} → String → a
willneverhappenipromise m = trace m fail

module _ where

  Var  = ℕ
  Chan = ℕ

  mutual
    record Closure : Set where
      inductive
      constructor ⟨_⊢_⟩
      field
        env  : Env
        body : Exp

    data Val : Set where
      tt    : Val
      nat   : ℕ → Val
      chan  : Chan → Val
      ⟨_,_⟩ : Val → Val → Val -- pairs
      clos  : Closure → Val -- closures

    Env = List Val

    data Exp : Set where
      -- the functional core
      nat     : ℕ → Exp
      var     : Var → Exp
      ƛ       : Exp → Exp
      _·_     : Exp → Exp → Exp

      -- products
      pair    : Exp → Exp → Exp
      letp    : Exp → Exp → Exp

      -- communication
      close   : Exp → Exp
      receive : Exp → Exp
      send    : (ch : Exp) → (v : Exp) → Exp

      -- threading
      fork    : Exp → Exp

  extend  : Val → Env → Env
  extend = _∷_

  unsafeLookup : ∀ {a} → ℕ → List a → a
  unsafeLookup _ [] = willneverhappenipromise "lookup fail"
  unsafeLookup zero (x ∷ xs)    = x
  unsafeLookup (suc n) (x ∷ xs) = unsafeLookup n xs

  unsafeUpdate : ∀ {a} → ℕ → List a → a → List a
  unsafeUpdate n [] a = willneverhappenipromise "update fail"
  unsafeUpdate zero (x ∷ xs) a = a ∷ xs
  unsafeUpdate (suc n) (x ∷ xs) a = x ∷ unsafeUpdate n xs a

  -- Ideally this should be two different dispatch sets
  data Comm : Set where
    -- communication
    send  : Chan → Val → Comm
    recv  : Chan → Comm
    clos  : Chan → Comm

  data Threading : Set where
    -- threading
    fork  : Closure → Threading
    yield : Threading

  Cmd = Comm ⊎ Threading

  ⟦_⟧-comm : Comm → Set
  ⟦ clos x ⟧-comm = ⊤
  ⟦ send x x₁ ⟧-comm = ⊤
  ⟦ recv x ⟧-comm = Val

  ⟦_⟧-thr : Threading → Set
  ⟦ fork x ⟧-thr = Chan
  ⟦ yield ⟧-thr  = ⊤

  ⟦_⟧ : Cmd → Set
  ⟦ inj₁ x ⟧ = ⟦ x ⟧-comm
  ⟦ inj₂ y ⟧ = ⟦ y ⟧-thr

  data Thread : Set where
    thread : Free Cmd ⟦_⟧ Val → Thread

  ThreadPool = List Thread

  Links  = Chan → Chan

  data Blocked : Set where
    blocked : Blocked

  {- Free an expression from its earthly -}
  module _ {m}
    ⦃ m-monad : RawMonad m ⦄
    ⦃ m-read  : MonadReader m Env ⦄
    ⦃ m-res   : MonadResumption m Closure Chan ⦄
    ⦃ m-comm  : MonadComm m Chan Val ⦄
    where

    open M

    {-# NON_TERMINATING #-}
    eval : Exp → m Val
    eval (nat n) = do
      return (nat n)
    eval (var x) = do
      asks (unsafeLookup x)
    eval (ƛ e) = do
      asks (clos ∘ ⟨_⊢ e ⟩)
    eval (f · e) = do
      clos ⟨ env ⊢ body ⟩ ← eval f
        where _ → willneverhappenipromise "not a closure"
      v ← eval e
      local (λ _ → extend v env) (eval body)

    -- products
    eval (pair e₁ e₂) = do
      v₁ ← eval e₁
      v₂ ← eval e₂
      return ⟨ v₁ , v₂ ⟩

    eval (letp b e) = do
      ⟨ v₁ , v₂ ⟩ ← eval b
        where _ → willneverhappenipromise "not a pair"
      local (extend v₂ ∘ extend v₁) $ eval e

    -- communication
    eval (close e) = do
      chan c ← eval e
        where _ → willneverhappenipromise "not a channel to close"
      M.close c
      return tt
    eval (receive e) = do
      chan c ← eval e
        where _ → willneverhappenipromise "not a channel to receive on"
      M.recv c
    eval (send e₁ e₂) = do
      chan c ← eval e₁
        where _ → willneverhappenipromise "not a channel to send on"
      v ← eval e₂
      M.send c v
      return tt

    -- threading
    eval (fork e) = do
      clos cl ← eval e
        where _ → willneverhappenipromise "not a closure to fork"
      c ← M.fork cl
      return (chan c)

  {- Interpreting communication commands -}
  module _ {com}
    ⦃ com-comm  : MonadComm com Chan Val ⦄ where

    communicate : (cmd : Comm) → com ⟦ cmd ⟧-comm
    communicate (Comm.send c v) = M.send c v
    communicate (Comm.recv x)   = M.recv x
    communicate (clos x)        = M.close x

  {- Interpreting threading commands -}
  module _ {thr}
    ⦃ thr-res   : MonadResumption thr Closure Chan ⦄ where

    threading : (cmd : Threading) → thr ⟦ cmd ⟧-thr
    threading (Threading.fork cl) = M.fork cl
    threading Threading.yield     = M.yield

  module _ {cmd}
    ⦃ cmd-comm  : MonadComm cmd Chan Val ⦄
    ⦃ cmd-res   : MonadResumption cmd Closure Chan ⦄ where

    handle : (c : Cmd) → cmd ⟦ c ⟧
    handle = Sum.[ communicate , threading ]

  {- Round robin scheduling -}
  module _ {w : Set} {m}

    ⦃ monad : RawMonad m ⦄
    ⦃ read  : MonadState m (List w) ⦄

    (atomic : w → m ⊤) where

    open M

    {-# NON_TERMINATING #-}
    robin : m ⊤
    robin = do
      (h ∷ tl) ← get
        where [] → return tt
      put tl
      atomic h
      robin


{- 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 #-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types.EpochIndep
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open        WithAbsVote

-- Here we have the abstraction functions that connect
-- the datatypes defined in LibraBFT.Impl.Consensus.Types
-- to the abstract records from LibraBFT.Abstract.Records
-- for a given EpochConfig.
--
module LibraBFT.Concrete.Records (𝓔 : EpochConfig) where
 open import LibraBFT.Impl.Consensus.Types.EpochDep 𝓔
 open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 ConcreteVoteEvidence as Abs hiding (bId; qcVotes; Block)
 open        EpochConfig 𝓔
 --------------------------------
 -- Abstracting Blocks and QCs --
 --------------------------------

 α-Block : Block → Abs.Block
 α-Block b with ₋bdBlockType (₋bBlockData b)
 ...| NilBlock = record
      { bId     = ₋bId b
      ; bPrevQC = just (b ^∙ (bBlockData ∙ bdQuorumCert ∙ qcVoteData ∙  vdParent ∙ biId))
      ; bRound  = b ^∙ bBlockData ∙ bdRound
      }
 ...| Genesis = record
      { bId     = b ^∙ bId
      ; bPrevQC = nothing
      ; bRound  = b ^∙ bBlockData ∙ bdRound
      }
 ...| Proposal cmd α = record
      { bId     = b ^∙ bId
      ; bPrevQC = just (b ^∙ bBlockData ∙ bdQuorumCert ∙ qcVoteData ∙ vdParent ∙ biId)
      ; bRound  = b ^∙ bBlockData ∙ bdRound
      }

 α-VoteData-Block : VoteData → Abs.Block
 α-VoteData-Block vd = record
      { bId     = vd ^∙ vdProposed ∙ biId
      ; bPrevQC = just (vd ^∙ vdParent ∙ biId)
      ; bRound  = vd ^∙ vdProposed ∙ biRound
      }

 α-Vote : (qc : QuorumCert)(valid : MetaIsValidQC qc) → ∀ {as} → as ∈ qcVotes qc → Abs.Vote
 α-Vote qc v {as} as∈QC = α-ValidVote (rebuildVote qc as)
                                      (₋ivvMember (All-lookup (₋ivqcMetaVotesValid v) as∈QC))

 -- Abstraction of votes produce votes that carry evidence
 -- they have been cast.
 α-Vote-evidence : (qc : QuorumCert)(valid : MetaIsValidQC qc)
                 → ∀{vs} (prf : vs ∈ qcVotes qc)
                 → ConcreteVoteEvidence (α-Vote qc valid prf)
 α-Vote-evidence qc valid {as} v∈qc
   = record { ₋cveVote        = rebuildVote qc as
            ; ₋cveIsValidVote = All-lookup (₋ivqcMetaVotesValid valid) v∈qc
            ; ₋cveIsAbs       = refl
            }

 α-QC : Σ QuorumCert MetaIsValidQC → Abs.QC
 α-QC (qc , valid) = record
   { qCertBlockId = qc ^∙ qcVoteData ∙ vdProposed ∙ biId
   ; qRound       = qc ^∙ qcVoteData ∙ vdProposed ∙ biRound
   ; qVotes       = All-reduce (α-Vote qc valid) All-self
   ; qVotes-C1    = {! MetaIsValidQC.₋ivqcMetaIsQuorum valid!}
   ; qVotes-C2    = All-reduce⁺ (α-Vote qc valid) (λ _ → refl) All-self
   ; qVotes-C3    = All-reduce⁺ (α-Vote qc valid) (λ _ → refl) All-self
   ; qVotes-C4    = All-reduce⁺ (α-Vote qc valid) (α-Vote-evidence qc valid) All-self
   }

 -- What does it mean for an (abstract) Block or QC to be represented in a NetworkMsg?
 data _α-∈NM_ : Abs.Record → NetworkMsg → Set where
   qc∈NM : ∀ {cqc q nm}
         → (valid : MetaIsValidQC cqc)
         → cqc QC∈NM nm
         → q ≡ α-QC (cqc , valid)
         → Abs.Q q α-∈NM nm
   b∈NM  : ∀ {cb pm nm}
         → nm ≡ P pm
         → pm ^∙ pmProposal ≡ cb
         → Abs.B (α-Block cb) α-∈NM nm

 -- Our system model contains a message pool, which is a list of NodeId-NetworkMsg pairs.  The
 -- following relation expresses that an abstract record r is represented in a given message pool
 -- sm.
 data _α-Sent_ (r : Abs.Record) (sm : List (NodeId × NetworkMsg)) : Set where
   ws : ∀ {p nm} → getEpoch nm ≡ epoch → (p , nm) ∈ sm → r α-∈NM nm → r α-Sent sm


module Issue296 where

postulate
  Unit : Set
  IO   : Set → Set
  foo  : ((A B : Set) → Unit) → IO Unit
  bar  : (A B : Set) → Unit

{-# BUILTIN IO IO #-}
{-# COMPILE GHC IO = type IO #-}
{-# COMPILE GHC Unit = type () #-}
{-# COMPILE GHC bar = undefined #-}

main : IO Unit
main = foo bar


{-# OPTIONS --warning=error #-}

module UselessAbstractAbstract where

A : Set₁
abstract
  abstract
    A = Set