{- 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.OBM.Genesis                      as Genesis
open import LibraBFT.Impl.OBM.Rust.RustTypes
open import LibraBFT.Impl.OBM.Util
import      LibraBFT.Impl.Types.OnChainConfig.ValidatorSet as ValidatorSet
import      LibraBFT.Impl.Types.ValidatorVerifier          as ValidatorVerifier
open import LibraBFT.Impl.OBM.Rust.RustTypes
open import LibraBFT.Impl.OBM.Util
import      LibraBFT.Impl.Types.OnChainConfig.ValidatorSet as ValidatorSet
import      LibraBFT.Impl.Types.ValidatorVerifier          as ValidatorVerifier
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import Util.PKCS
open import Util.Prelude

module LibraBFT.Impl.IO.OBM.GenKeyFile where

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

EndpointAddress           = Author
AddressToSkAndPkAssocList = List (EndpointAddress × (SK × PK))

------------------------------------------------------------------------------
genKeys   : {-Crypto.SystemDRG →-} ℕ   → List (SK × PK)
mkAuthors : {-Crypto.SystemDRG →-} U64 → List EndpointAddress
          → Either ErrLog AddressToSkAndPkAssocList
mkValidatorSignersAndVerifierAndProposerElection
          : U64 → AddressToSkAndPkAssocList
          → Either ErrLog (List ValidatorSigner × ValidatorVerifier × ProposerElection)
------------------------------------------------------------------------------

NfLiwsVssVvPe =
  (U64 × LedgerInfoWithSignatures × List ValidatorSigner × ValidatorVerifier × ProposerElection)

NfLiwsVsVvPe =
  (U64 × LedgerInfoWithSignatures × ValidatorSigner × ValidatorVerifier × ProposerElection)

create'
  : U64 → List EndpointAddress {-→ SystemDRG-}
  → Either ErrLog
    ( U64 × AddressToSkAndPkAssocList
    × List ValidatorSigner × ValidatorVerifier × ProposerElection × LedgerInfoWithSignatures )
create' numFailures addresses {-drg-} = do
 authors       ← mkAuthors {-drg-} numFailures addresses
 (s , vv , pe) ← mkValidatorSignersAndVerifierAndProposerElection numFailures authors
 case Genesis.obmMkGenesisLedgerInfoWithSignatures s (ValidatorSet.obmFromVV vv) of λ where
       (Left err)   → Left err
       (Right liws) → pure (numFailures , authors , s , vv , pe , liws)

abstract
  create = create'
  create≡ : create ≡ create'
  create≡ = refl

mkAuthors {-drg-} numFailures0 addresses0 = do
  addrs <- checkAddresses
  checkBftAndRun numFailures0 addrs f
 where
  f : ℕ → List EndpointAddress → AddressToSkAndPkAssocList
  f _numFailures addresses = zip addresses (genKeys {-drg-} (length addresses))
  checkAddresses : Either ErrLog (List EndpointAddress)
  checkAddresses = pure addresses0

postulate -- Valid assumption: secret and public keys for each NodeId
  mkSK : NodeId → SK
  mkPK : NodeId → PK

genKeys    zero   = []
genKeys x@(suc n) = (mkSK x , mkPK x) ∷ genKeys n

mkValidatorSignersAndVerifierAndProposerElection numFaults ks = do
  -- IMPL-DIFF: Agda Author type does NOT contain a PK
  let allAuthors       = fmap fst ks
  validatorVerifier    ← ValidatorVerifier.initValidatorVerifier numFaults ks
  let authorKeyPairs   = fmap (λ (a , (sk , _)) → (a , sk)) ks
      validatorSigners = foldl' go [] authorKeyPairs
  pure (validatorSigners , validatorVerifier , ProposerElection∙new allAuthors)
 where
  go : List ValidatorSigner → (Author × SK) → List ValidatorSigner
  go acc (author , sk) = ValidatorSigner∙new author sk ∷ acc


module Luau.Value where

open import Agda.Builtin.Float using (Float)
open import Luau.Addr using (Addr)
open import Luau.Syntax using (Block; Expr; nil; addr; number)
open import Luau.Var using (Var)

data Value : Set where
  nil : Value
  addr : Addr → Value
  number : Float → Value

val : ∀ {a} → Value → Expr a
val nil = nil
val (addr a) = addr a
val (number x) = number x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Definitions used in the reflection machinery
------------------------------------------------------------------------

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

module Reflection.Definition where

open import Data.List.Base using (map)
import Data.List.Properties as Listₚ
import Data.Nat.Properties as ℕₚ
import Data.Nat.Show as NatShow
open import Data.Product using (_×_; <_,_>; uncurry)
open import Data.String as String using (String; _<+>_; intersperse; braces)
open import Function using (_∘′_)
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Binary using (DecidableEquality)
open import Relation.Binary.PropositionalEquality

import Reflection.Argument as Arg
import Reflection.Name     as Name
import Reflection.Term     as Term

------------------------------------------------------------------------
-- Re-exporting type publically

open import Agda.Builtin.Reflection public
  using    ( Definition
           ; function
           ; data-type
           ; axiom
           )
  renaming ( record-type to record′
           ; data-cons   to constructor′
           ; prim-fun    to primitive′ )

------------------------------------------------------------------------
-- Decidable equality

function-injective : ∀ {cs cs′} → function cs ≡ function cs′ → cs ≡ cs′
function-injective refl = refl

data-type-injective₁ : ∀ {pars pars′ cs cs′} → data-type pars cs ≡ data-type pars′ cs′ → pars ≡ pars′
data-type-injective₁ refl = refl

data-type-injective₂ : ∀ {pars pars′ cs cs′} → data-type pars cs ≡ data-type pars′ cs′ → cs ≡ cs′
data-type-injective₂ refl = refl

data-type-injective : ∀ {pars pars′ cs cs′} → data-type pars cs ≡ data-type pars′ cs′ → pars ≡ pars′ × cs ≡ cs′
data-type-injective = < data-type-injective₁ , data-type-injective₂ >

record′-injective₁ : ∀ {c c′ fs fs′} → record′ c fs ≡ record′ c′ fs′ → c ≡ c′
record′-injective₁ refl = refl

record′-injective₂ : ∀ {c c′ fs fs′} → record′ c fs ≡ record′ c′ fs′ → fs ≡ fs′
record′-injective₂ refl = refl

record′-injective : ∀ {c c′ fs fs′} → record′ c fs ≡ record′ c′ fs′ → c ≡ c′ × fs ≡ fs′
record′-injective = < record′-injective₁ , record′-injective₂ >

constructor′-injective : ∀ {c c′} → constructor′ c ≡ constructor′ c′ → c ≡ c′
constructor′-injective refl = refl

_≟_ : DecidableEquality Definition
function cs       ≟ function cs′        =
  Dec.map′ (cong function) function-injective (cs Term.≟-Clauses cs′)
data-type pars cs ≟ data-type pars′ cs′ =
  Dec.map′ (uncurry (cong₂ data-type)) data-type-injective
           (pars ℕₚ.≟ pars′ ×-dec Listₚ.≡-dec Name._≟_ cs cs′)
record′ c fs      ≟ record′ c′ fs′      =
  Dec.map′ (uncurry (cong₂ record′)) record′-injective
           (c Name.≟ c′ ×-dec Listₚ.≡-dec (Arg.≡-dec Name._≟_) fs fs′)
constructor′ d    ≟ constructor′ d′     =
  Dec.map′ (cong constructor′) constructor′-injective (d Name.≟ d′)
axiom             ≟ axiom               = yes refl
primitive′        ≟ primitive′          = yes refl

-- antidiagonal
function cs ≟ data-type pars cs₁ = no (λ ())
function cs ≟ record′ c fs = no (λ ())
function cs ≟ constructor′ d = no (λ ())
function cs ≟ axiom = no (λ ())
function cs ≟ primitive′ = no (λ ())
data-type pars cs ≟ function cs₁ = no (λ ())
data-type pars cs ≟ record′ c fs = no (λ ())
data-type pars cs ≟ constructor′ d = no (λ ())
data-type pars cs ≟ axiom = no (λ ())
data-type pars cs ≟ primitive′ = no (λ ())
record′ c fs ≟ function cs = no (λ ())
record′ c fs ≟ data-type pars cs = no (λ ())
record′ c fs ≟ constructor′ d = no (λ ())
record′ c fs ≟ axiom = no (λ ())
record′ c fs ≟ primitive′ = no (λ ())
constructor′ d ≟ function cs = no (λ ())
constructor′ d ≟ data-type pars cs = no (λ ())
constructor′ d ≟ record′ c fs = no (λ ())
constructor′ d ≟ axiom = no (λ ())
constructor′ d ≟ primitive′ = no (λ ())
axiom ≟ function cs = no (λ ())
axiom ≟ data-type pars cs = no (λ ())
axiom ≟ record′ c fs = no (λ ())
axiom ≟ constructor′ d = no (λ ())
axiom ≟ primitive′ = no (λ ())
primitive′ ≟ function cs = no (λ ())
primitive′ ≟ data-type pars cs = no (λ ())
primitive′ ≟ record′ c fs = no (λ ())
primitive′ ≟ constructor′ d = no (λ ())
primitive′ ≟ axiom = no (λ ())


-- Semantics of syntactic traversal and substitution
module Semantics.Substitution.Traversal where

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

open import Semantics.Types
open import Semantics.Context
open import Semantics.Terms
open import Semantics.Substitution.Kits

open import CategoryTheory.Categories using (Category ; ext)
open import CategoryTheory.Functor
open import CategoryTheory.NatTrans
open import CategoryTheory.Monad
open import CategoryTheory.Comonad
open import CategoryTheory.Instances.Reactive renaming (top to ⊤)
open import TemporalOps.Diamond
open import TemporalOps.Box
open import TemporalOps.OtherOps
open import TemporalOps.Linear
open import TemporalOps.StrongMonad

open import Data.Sum
open import Data.Product using (_,_)
open import Relation.Binary.PropositionalEquality as ≡
    using (_≡_ ; refl ; sym ; trans ; cong ; cong₂ ; subst)

open ≡.≡-Reasoning
private module F-□ = Functor F-□
private module F-◇ = Functor F-◇
open Comonad W-□
open Monad M-◇
open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

module _ {𝒮} {k : Kit 𝒮} (⟦k⟧ : ⟦Kit⟧ k) where
    open ⟦Kit⟧ ⟦k⟧
    open Kit k
    open ⟦K⟧ ⟦k⟧
    open K k

    -- Soundness of syntactic traversal:
    -- Denotation of a term M traversed with substitution σ is
    -- the same as the denotation of σ followed by the denotation of M
    traverse-sound : ∀{Γ Δ A} (σ : Subst 𝒮 Γ Δ) (M : Γ ⊢ A)
                  -> ⟦ traverse σ M ⟧ₘ ≈ ⟦ M ⟧ₘ ∘ ⟦subst⟧ σ
    traverse′-sound : ∀{Γ Δ A} (σ : Subst 𝒮 Γ Δ) (C : Γ ⊨ A)
                  -> ⟦ traverse′ σ C ⟧ᵐ ≈ ⟦ C ⟧ᵐ ∘ ⟦subst⟧ σ

    traverse-sound ● (var ())
    traverse-sound (σ ▸ T) (var top) = ⟦𝓉⟧ T
    traverse-sound (σ ▸ T) (var (pop x)) = traverse-sound σ (var x)
    traverse-sound σ (lam {Γ} {A} M) {n} {⟦Δ⟧} = ext lemma
        where
        lemma : ∀(⟦A⟧ : ⟦ A ⟧ₜ n) →
                Λ ⟦ traverse (σ ↑ k) M ⟧ₘ n ⟦Δ⟧ ⟦A⟧ ≡ (Λ ⟦ M ⟧ₘ ∘ ⟦subst⟧ σ) n ⟦Δ⟧ ⟦A⟧
        lemma ⟦A⟧ rewrite traverse-sound (σ ↑ k) M {n} {⟦Δ⟧ , ⟦A⟧}
                        | ⟦↑⟧ (A now) σ {n} {⟦Δ⟧ , ⟦A⟧} = refl
    traverse-sound σ (M $ N) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧}
                                             | traverse-sound σ N {n} {⟦Δ⟧} = refl
    traverse-sound σ unit = refl
    traverse-sound σ [ M ,, N ] {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧}
                                                | traverse-sound σ N {n} {⟦Δ⟧} = refl
    traverse-sound σ (fst M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse-sound σ (snd M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse-sound σ (inl M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse-sound σ (inr M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse-sound σ (case M inl↦ N₁ ||inr↦ N₂) {n} {⟦Δ⟧}
        rewrite traverse-sound σ M {n} {⟦Δ⟧} with ⟦ M ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)
    traverse-sound σ (case_inl↦_||inr↦_ {A = A} M N₁ N₂) {n} {⟦Δ⟧} | inj₁ ⟦A⟧
        rewrite traverse-sound (σ ↑ k) N₁ {n} {⟦Δ⟧ , ⟦A⟧}
              | ⟦↑⟧ (A now) σ {n} {⟦Δ⟧ , ⟦A⟧} = refl
    traverse-sound σ (case_inl↦_||inr↦_ {B = B} M N₁ N₂) {n} {⟦Δ⟧} | inj₂ ⟦B⟧
        rewrite traverse-sound (σ ↑ k) N₂ {n} {⟦Δ⟧ , ⟦B⟧}
              | ⟦↑⟧ (B now) σ {n} {⟦Δ⟧ , ⟦B⟧} = refl
    traverse-sound σ (sample M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse-sound {Γ} {Δ} {A} σ (stable M) {n} {⟦Δ⟧} = ext lemma
        where
        lemma : ∀ l -> ⟦ traverse {Γ} σ (stable M) ⟧ₘ n ⟦Δ⟧ l
                     ≡ (⟦ stable {Γ} M ⟧ₘ ∘ ⟦subst⟧ σ) n ⟦Δ⟧ l
        lemma l rewrite traverse-sound (σ ↓ˢ k) M {l} {⟦ Δ ˢ⟧□ n ⟦Δ⟧ l}
                      | □-≡ n l (⟦↓ˢ⟧ σ {n} {⟦Δ⟧}) l = refl
    traverse-sound σ (sig M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse-sound σ (letSig_In_ {A = A} M N) {n} {⟦Δ⟧}
        rewrite traverse-sound σ M {n} {⟦Δ⟧}
              | traverse-sound (σ ↑ k) N {n} {⟦Δ⟧ , ⟦ M ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)}
              | ⟦↑⟧ (A always) σ {n} {⟦Δ⟧ , (⟦ M ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))} = refl
    traverse-sound σ (event E) = traverse′-sound σ E

    traverse′-sound σ (pure M) {n} {⟦Δ⟧} rewrite traverse-sound σ M {n} {⟦Δ⟧} = refl
    traverse′-sound σ (letSig_InC_ {A = A} S C) {n} {⟦Δ⟧}
                rewrite traverse-sound σ S {n} {⟦Δ⟧}
                      | traverse′-sound (σ ↑ k) C {n} {⟦Δ⟧ , ⟦ S ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)}
                      | ⟦↑⟧ (A always) σ {n} {⟦Δ⟧ , (⟦ S ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))} = refl

    traverse′-sound {Γ} {Δ} σ (letEvt_In_ {A = A} {B} E C) {n} {⟦Δ⟧}
        rewrite traverse-sound σ E {n} {⟦Δ⟧}
              | (ext λ m → ext λ b → traverse′-sound (σ ↓ˢ k ↑ k) C {m} {b}) =
        begin
            μ.at ⟦ B ⟧ₜ n
                (F-◇.fmap (⟦ C ⟧ᵐ ∘ ⟦subst⟧ (_↑_ {A = A now} (σ ↓ˢ k) k) ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                         (st ⟦ Δ ˢ ⟧ₓ ⟦ A ⟧ₜ n (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))))
        ≡⟨ cong (μ.at ⟦ B ⟧ₜ n) (F-◇.fmap-∘ {g = ⟦ C ⟧ᵐ} {⟦subst⟧ (_↑_ {A = A now} (σ ↓ˢ k) k) ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id}
                                         {n} {st ⟦ Δ ˢ ⟧ₓ ⟦ A ⟧ₜ n (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))}) ⟩
            μ.at ⟦ B ⟧ₜ n (F-◇.fmap (⟦ C ⟧ᵐ) n
                (F-◇.fmap (⟦subst⟧ (_↑_ {A = A now} (σ ↓ˢ k) k) ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                     (st ⟦ Δ ˢ ⟧ₓ ⟦ A ⟧ₜ n (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)))))
        ≡⟨ cong (λ x → μ.at ⟦ B ⟧ₜ n (F-◇.fmap ⟦ C ⟧ᵐ n x)) (
            begin
                F-◇.fmap (⌞ ⟦subst⟧ (_↑_ {A = A now} (σ ↓ˢ k) k) ⌟ ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                     (st ⟦ Δ ˢ ⟧ₓ ⟦ A ⟧ₜ n (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)))
            ≡⟨ cong! (ext λ m -> ext λ b → ⟦↑⟧ (A now) (σ ↓ˢ k) {m} {b}) ⟩
                F-◇.fmap (⟦subst⟧ (σ ↓ˢ k) * id ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                     (st ⟦ Δ ˢ ⟧ₓ ⟦ A ⟧ₜ n (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)))
            ≡⟨ F-◇.fmap-∘ ⟩
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (F-◇.fmap (F-□.fmap (⟦subst⟧ (σ ↓ˢ k)) * id) n
                    (st ⟦ Δ ˢ ⟧ₓ ⟦ A ⟧ₜ n ( ⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))))
            ≡⟨ cong (F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n)
                    (st-nat₁ (⟦subst⟧ (σ ↓ˢ k))) ⟩
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ ⟦ A ⟧ₜ n ( ⌞ F-□.fmap (⟦subst⟧ (σ ↓ˢ k)) n (⟦ Δ ˢ⟧□ n ⟦Δ⟧) ⌟
                                   , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)))
            ≡⟨ cong! (⟦↓ˢ⟧ σ) ⟩
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                    (st ⟦ Γ ˢ ⟧ₓ ⟦ A ⟧ₜ n ( ⟦ Γ ˢ⟧□ n (⟦subst⟧ σ n ⟦Δ⟧)
                                       , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)))
            ∎
        ) ⟩
            μ.at ⟦ B ⟧ₜ n (F-◇.fmap ⟦ C ⟧ᵐ n
                (F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ ⟦ A ⟧ₜ n ( ⟦ Γ ˢ⟧□ n (⟦subst⟧ σ n ⟦Δ⟧)
                                   , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧)))))
        ≡⟨ cong (μ.at ⟦ B ⟧ₜ n) (sym (F-◇.fmap-∘ {g = ⟦ C ⟧ᵐ}{ε.at ⟦ Γ ˢ ⟧ₓ * id}{n}
                            {st ⟦ Γ ˢ ⟧ₓ ⟦ A ⟧ₜ n ( ⟦ Γ ˢ⟧□ n (⟦subst⟧ σ n ⟦Δ⟧)
                                               , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))})) ⟩
            μ.at ⟦ B ⟧ₜ n (F-◇.fmap (⟦ C ⟧ᵐ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ ⟦ A ⟧ₜ n ( ⟦ Γ ˢ⟧□ n (⟦subst⟧ σ n ⟦Δ⟧)
                                   , ⟦ E ⟧ₘ n (⟦subst⟧ σ n ⟦Δ⟧))))
        ≡⟨⟩
            ⟦ letEvt E In C ⟧ᵐ n (⟦subst⟧ σ n ⟦Δ⟧)
        ∎

    traverse′-sound {_} {Δ} σ (select_↦_||_↦_||both↦_ {Γ} {A} {B} {C} E₁ C₁ E₂ C₂ C₃) {n} {⟦Δ⟧}
        rewrite traverse-sound σ E₁ {n} {⟦Δ⟧}
              | traverse-sound σ E₂ {n} {⟦Δ⟧} =
        begin
            μ.at ⟦ C ⟧ₜ n
                (F-◇.fmap (⌞ handle ⟦ traverse′ (σ ↓ˢ k ↑ k ↑ k) C₁ ⟧ᵐ
                                    ⟦ traverse′ (σ ↓ˢ k ↑ k ↑ k) C₂ ⟧ᵐ
                                    ⟦ traverse′ (σ ↓ˢ k ↑ k ↑ k) C₃ ⟧ᵐ ⌟ ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                (st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧)))
        ≡⟨ cong! (ext λ m → ext λ b → ind-hyp m b) ⟩
            μ.at ⟦ C ⟧ₜ n
                (F-◇.fmap (⌞ handle
                       (⟦ C₁ ⟧ᵐ ∘ (⟦subst⟧ (_↑_ {Event B now} (_↑_ {A now} (σ ↓ˢ k) k) k)))
                       (⟦ C₂ ⟧ᵐ ∘ (⟦subst⟧ (_↑_ {B now} (_↑_ {Event A now} (σ ↓ˢ k) k) k)))
                       (⟦ C₃ ⟧ᵐ ∘ (⟦subst⟧ (_↑_ {B now} (_↑_ {A now}       (σ ↓ˢ k) k) k))) ⌟
                       ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                (st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧)))
        ≡⟨ cong! (ext λ m → ext λ b →
            ⟦subst⟧-handle {Δ}{Γ}{A}{B}{C} σ {⟦ C₁ ⟧ᵐ}{⟦ C₂ ⟧ᵐ}{⟦ C₃ ⟧ᵐ}{n = m} {b}) ⟩
            μ.at ⟦ C ⟧ₜ n
                (F-◇.fmap (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ ∘ ⟦subst⟧ (σ ↓ˢ k) * id ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                (st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧)))
        ≡⟨ cong (μ.at ⟦ C ⟧ₜ n) (F-◇.fmap-∘ {g = handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ}
                      {f = ⟦subst⟧ (σ ↓ˢ k) * id ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id} {n}
                      {st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                      (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧)})
         ⟩
            μ.at ⟦ C ⟧ₜ n (F-◇.fmap (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ) n
              ⌞ (F-◇.fmap (⟦subst⟧ (σ ↓ˢ k) * id ∘ ε.at ⟦ Δ ˢ ⟧ₓ * id) n
                (st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧))) ⌟)
        ≡⟨ cong (λ x → μ.at ⟦ C ⟧ₜ n (F-◇.fmap (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ) n x)) (
            begin
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id ∘ F-□.fmap (⟦subst⟧ (σ ↓ˢ k)) * id) n
                (st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧))
            ≡⟨ F-◇.fmap-∘ ⟩
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (F-◇.fmap (F-□.fmap (⟦subst⟧ (σ ↓ˢ k)) * id) n
                (st ⟦ Δ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Δ ˢ⟧□ n ⟦Δ⟧ , ⟪ ⟦ E₁ ⟧ₘ ∘ ⟦subst⟧ σ , ⟦ E₂ ⟧ₘ ∘ ⟦subst⟧ σ ⟫ n ⟦Δ⟧)))
            ≡⟨ cong (F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n)
                    (st-nat₁ (⟦subst⟧ (σ ↓ˢ k))) ⟩
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⌞ F-□.fmap (⟦subst⟧ (σ ↓ˢ k)) n (⟦ Δ ˢ⟧□ n ⟦Δ⟧) ⌟ , ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫  n (⟦subst⟧ σ n ⟦Δ⟧)))
            ≡⟨ cong! (⟦↓ˢ⟧ σ) ⟩
                F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Γ ˢ⟧□  n (⟦subst⟧ σ n ⟦Δ⟧) , ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫  n (⟦subst⟧ σ n ⟦Δ⟧)))
            ∎
        ) ⟩
            μ.at ⟦ C ⟧ₜ n (F-◇.fmap (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ) n
                (F-◇.fmap (ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Γ ˢ⟧□  n (⟦subst⟧ σ n ⟦Δ⟧) , ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫  n (⟦subst⟧ σ n ⟦Δ⟧)))))
        ≡⟨ cong (μ.at ⟦ C ⟧ₜ n) (sym (F-◇.fmap-∘ {g = handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ}
            {ε.at ⟦ Γ ˢ ⟧ₓ * id}{n} {st ⟦ Γ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Γ ˢ⟧□  n (⟦subst⟧ σ n ⟦Δ⟧) , ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫  n (⟦subst⟧ σ n ⟦Δ⟧))})) ⟩
            μ.at ⟦ C ⟧ₜ n (F-◇.fmap (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (st ⟦ Γ ˢ ⟧ₓ (⟦ A ⟧ₜ ⊛ ⟦ B ⟧ₜ) n
                (⟦ Γ ˢ⟧□  n (⟦subst⟧ σ n ⟦Δ⟧) , ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫  n (⟦subst⟧ σ n ⟦Δ⟧))))
        ≡⟨⟩
            ⟦ select E₁ ↦ C₁ || E₂ ↦ C₂ ||both↦ C₃ ⟧ᵐ n (⟦subst⟧ σ n ⟦Δ⟧)
        ∎
        where
        ind-hyp : ∀ l c
            -> handle
                    ⟦ traverse′ (σ ↓ˢ k ↑ k ↑ k) C₁ ⟧ᵐ
                    ⟦ traverse′ (σ ↓ˢ k ↑ k ↑ k) C₂ ⟧ᵐ
                    ⟦ traverse′ (σ ↓ˢ k ↑ k ↑ k) C₃ ⟧ᵐ l c
             ≡ handle
                    (⟦ C₁ ⟧ᵐ ∘ (⟦subst⟧ (_↑_ {Event B now} (_↑_ {A now} (σ ↓ˢ k) k) k)))
                    (⟦ C₂ ⟧ᵐ ∘ (⟦subst⟧ (_↑_ {B now} (_↑_ {Event A now} (σ ↓ˢ k) k) k)))
                    (⟦ C₃ ⟧ᵐ ∘ (⟦subst⟧ (_↑_ {B now} (_↑_ {A now}       (σ ↓ˢ k) k) k))) l c
        ind-hyp l c rewrite ext (λ n -> (ext λ ⟦Δ⟧ -> (traverse′-sound (σ ↓ˢ k ↑ k ↑ k) C₁ {n} {⟦Δ⟧})))
                          | ext (λ n -> (ext λ ⟦Δ⟧ -> (traverse′-sound (σ ↓ˢ k ↑ k ↑ k) C₂ {n} {⟦Δ⟧})))
                          | ext (λ n -> (ext λ ⟦Δ⟧ -> (traverse′-sound (σ ↓ˢ k ↑ k ↑ k) C₃ {n} {⟦Δ⟧}))) = refl


------------------------------------------------------------------------
-- Parsing of mixfix operators
------------------------------------------------------------------------

-- This module defines a grammar for the precedence graph g.

open import RecursiveDescent.Hybrid.Mixfix.Expr

module RecursiveDescent.Hybrid.Mixfix (g : PrecedenceGraph) where

import Data.Vec as Vec
import Data.List as List
open List using (List; []; _∷_; foldr; foldl)
import Data.Vec1 as Vec1
open Vec1 using (Vec₁)
open import Data.Product renaming (_,_ to pair)
open import Data.Product.Record using (_,_)
open import Data.Bool
open import Data.Unit
open import Data.Nat
open import Data.Function hiding (_⟨_⟩_)
import Data.String as String

open import RecursiveDescent.Hybrid.Mixfix.Fixity
open import RecursiveDescent.Index
open import RecursiveDescent.Hybrid
open import RecursiveDescent.Hybrid.Simple
open import RecursiveDescent.Hybrid.Lib
open Token String.decSetoid

-- Note that, even though grammar below is not recursive, these
-- functions are (mutually). Fortunately the recursion is structural,
-- though. Note also that the reason for not using the implementation
--
--   grammar (nodes ts) = choiceMap (\t -> ! node t) ts
--
-- is that this would lead to a definition of node-corners which
-- was not structurally recursive.

nodes-corners : PrecedenceGraph -> Corners
nodes-corners []       = _
nodes-corners (p ∷ ps) = _

node-corners : PrecedenceTree -> Corners
node-corners (precedence ops ps) = _

-- Nonterminals.

data NT : ParserType where
  -- Expressions.
  expr : NT _ Expr

  -- Expressions corresponding to zero or more nodes in the precedence
  -- graph: operator applications where the outermost operator has one
  -- of the precedences ps. The graph g is used for internal
  -- expressions.
  nodes : (ps : PrecedenceGraph) -> NT (false , nodes-corners ps) Expr

  -- Expressions corresponding to one node in the precedence graph:
  -- operator applications where the outermost operator has
  -- precedence p. The graph g is used for internal expressions.
  node : (p : PrecedenceTree) -> NT (false , node-corners p) Expr

-- The parser type used in this module.

P : Index -> Set -> Set1
P = Parser NamePart NT

-- A vector containing parsers recognising the name parts of the
-- operator.

nameParts : forall {fix arity} -> Operator fix arity ->
            Vec₁ (P _ NamePart) (1 + arity)
nameParts (operator ns) = Vec1.map₀₁ sym ns

-- Internal parts (all name parts plus internal expressions) of
-- operators of the given precedence and fixity.

internal : forall {fix}
           (ops : List (∃ (Operator fix))) -> P _ (Internal fix)
internal =
  choiceMap (\op' -> let op = proj₂ op' in
                     _∙_ op <$> (! expr between nameParts op))

-- The grammar.

grammar : Grammar NamePart NT
grammar expr                       = ! nodes g
grammar (nodes [])                 = fail
grammar (nodes (p ∷ ps))           = ! node p ∣ ! nodes ps
grammar (node (precedence ops ps)) =
     ⟪_⟫              <$>      ⟦ closed   ⟧
  ∣ _⟨_⟩_             <$>  ↑ ⊛ ⟦ infx non ⟧ ⊛ ↑
  ∣ flip (foldr _$_)  <$>      preRight +   ⊛ ↑
  ∣ foldl (flip _$_)  <$>  ↑ ⊛ postLeft +
  where
  -- ⟦ fix ⟧ parses the internal parts of operators with the
  -- current precedence level and fixity fix.
  ⟦_⟧ = \(fix : Fixity) -> internal (ops fix)

  -- Operator applications where the outermost operator binds
  -- tighter than the current precedence level.
  ↑ = ! nodes ps

  -- Right associative and prefix operators.
  preRight =  ⟪_⟩_ <$> ⟦ prefx ⟧
           ∣ _⟨_⟩_ <$> ↑ ⊛ ⟦ infx right ⟧

  -- Left associative and postfix operators.
  postLeft = flip _⟨_⟫                   <$> ⟦ postfx ⟧
           ∣ (\op e₂ e₁ -> e₁ ⟨ op ⟩ e₂) <$> ⟦ infx left ⟧ ⊛ ↑

-- An expression parser.

parseExpr : List NamePart -> List Expr
parseExpr = parse-complete (! expr) grammar