-- MIT License

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

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

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

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

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

open import Size

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

open import Codata.Thunk

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_; _⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (Star; ε; _◅_; return)

open import Function.Base using (case_of_)

open import Common

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

open import Trace message
open import SessionType message
open import Transitions message
open import Session message
open import Compliance message
open import HasTrace message
open import TraceInclusion message
open import Convergence message
open import FairCompliance message

data FairSub : SessionType -> SessionType -> Size -> Set where
  nil<|any : ∀{T i} -> FairSub nil T i
  end<|def : ∀{T S i} (e : End T) (def : Defined S) -> FairSub T S i
  inp<|inp :
    ∀{f g i}
    (con : inp f ↓ inp g)
    (inc : dom f ⊆ dom g)
    (F : (x : ℙ) -> Thunk (FairSub (f x .force) (g x .force)) i) ->
    FairSub (inp f) (inp g) i
  out<|out :
    ∀{f g i}
    (con : out f ↓ out g)
    (W : Witness g)
    (inc : dom g ⊆ dom f)
    (F : ∀{x} (!x : x ∈ dom g) -> Thunk (FairSub (f x .force) (g x .force)) i) ->
    FairSub (out f) (out g) i

_<|_ : SessionType -> SessionType -> Set
_<|_ T S = FairSub T S ∞

-- sub-defined : ∀{T S} -> T <| S -> Defined T -> Defined S
-- sub-defined (end<|def _ def) _ = def
-- sub-defined (inp<|inp _ _) _   = inp
-- sub-defined (out<|out _ _ _) _ = out

fs->convergence : ∀{T S} -> T <| S -> T ↓ S
fs->convergence nil<|any = inclusion->convergence nil<=any
fs->convergence (end<|def e def) = inclusion->convergence (end<=def e def)
fs->convergence (inp<|inp con inc F) = con
fs->convergence (out<|out con W inc F) = con

fc-not-transition+end :
  ∀{R R' T α} ->
  FairComplianceS (R # T) ->
  Transition R α R' ->
  End T ->
  ⊥
fc-not-transition+end comp inp (inp U) with comp ε
... | _ , ε , win#def () _
... | _ , sync () inp ◅ _ , _
fc-not-transition+end comp inp (out U) with comp ε
... | _ , ε , win#def () _
... | _ , sync _ (out fx) ◅ _ , _ = ⊥-elim (U _ fx)
fc-not-transition+end comp (out fx) (inp V) with comp ε
... | _ , ε , win#def (out U) _ = ⊥-elim (U _ fx)
... | _ , sync (out _) inp ◅ reds , win#def w def =
  let _ , rr , tr = unzip-red* reds in
  ⊥-elim (V _ (transitions+defined->defined tr def))
fc-not-transition+end comp (out fx) (out _) with comp ε
... | _ , ε , win#def (out U) _ = ⊥-elim (U _ fx)
... | _ , sync () (out _) ◅ _ , _

sub-red :
  ∀{T S S' R R' α} ->
  FairComplianceS (R # T) ->
  T <| S ->
  Transition R (co-action α) R' ->
  Transition S α S' ->
  ∃[ T' ] (Transition T α T' × T' <| S')
sub-red comp nil<|any _ _ with comp ε
... | _ , ε , win#def _ ()
... | _ , sync _ () ◅ _ , _
sub-red comp (end<|def e _) r _ = ⊥-elim (fc-not-transition+end comp r e)
sub-red comp (inp<|inp con inc F) (out {h} hx) (inp {f}) = _ , inp , F _ .force
sub-red comp (out<|out con W inc F) inp (out fx) = _ , out (inc fx) , F fx .force

sub-red* :
  ∀{T S S' R R' φ} ->
  FairComplianceS (R # T) ->
  T <| S ->
  Transitions R (co-trace φ) R' ->
  Transitions S φ S' ->
  ∃[ T' ] (Transitions T φ T' × T' <| S')
sub-red* comp sub refl refl = _ , refl , sub
sub-red* comp sub (step r rr) (step s sr) =
  let _ , t , sub' = sub-red comp sub r s in
  let comp' = fc-transitions (step r refl) (step t refl) comp in
  let _ , tr , sub'' = sub-red* comp' sub' rr sr in
  _ , step t tr , sub''

sub-sound : ∀{T S R} -> FairComplianceS (R # T) -> T <| S -> FairComplianceS (R # S)
sub-sound comp sub {_ # _} reds =
  let _ , rr , sr = unzip-red* reds in
  let _ , tr , sub' = sub-red* comp sub rr sr in
  let comp' = fair-compliance-red* comp (zip-red* rr tr) in
  con-sound (fs->convergence sub') comp'


open import Everything

module Test.Class where

record ℭlass
  {ℓ}
  {𝔢}
  {CONSTRAINTS : Ø 𝔢}
  (constraints : CONSTRAINTS)
  : Ø ↑̂ ℓ
  where
  constructor ∁
  field
    type : Ø ℓ
  private
    record SET-CLASS
      ⦃ _ : Constraint constraints ⦄
      : Ø ℓ
      where
      constructor ∁
      field ⋆ : type
  open SET-CLASS public
  class : Ø _
  class = SET-CLASS
  method : ⦃ _ : class ⦄ → type
  method ⦃ ⌶ ⦄ = SET-CLASS.⋆ ⌶

mkClass : ∀
  {ℓ}
  {𝔢}
  {CONSTRAINTS : Ø 𝔢}
  (constraints : CONSTRAINTS)
  → Ø ℓ
  → ℭlass constraints
mkClass constraints set-method = ∁ set-method

module Unit-Unit/Unit/Unit
  {𝔬} (𝔒 : Ø 𝔬)
  = ℭlass (mkClass 𝔒 𝔒)

module PropSingle-Unit/Unit/Unit
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  (x : 𝔒)
  = Unit-Unit/Unit/Unit (𝔓 x)

module Prop-Unit/Unit/Unit
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  where
  private module M = PropSingle-Unit/Unit/Unit 𝔓
  class = ∀ {x} → M.class x
  type = ∀ x → M.type x
  method = λ ⦃ _ : class ⦄ x → M.method x

module RelSingle-Unit/Unit/Unit
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (ℜ : 𝔒 → 𝔒 → Ø 𝔯)
  (x : 𝔒)
  = Unit-Unit/Unit/Unit (ℜ x x)

module Rel-Unit/Unit/Unit
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (ℜ : 𝔒 → 𝔒 → Ø 𝔯)
  where
  private module M = RelSingle-Unit/Unit/Unit ℜ
  class = ∀ {x} → M.class x
  type = ∀ x → M.type x
  method = λ ⦃ _ : class ⦄ x → M.method x

module Prop-Rel-Unit/Unit/Unit
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  = Rel-Unit/Unit/Unit (Extension 𝔓)

module UnitLevel-Unit/Unit/Unit
  {𝔬} (𝔒 : Ø 𝔬) (𝔯 : Ł)
  where
  private module M = Rel-Unit/Unit/Unit {𝔒 = 𝔒} {𝔯 = 𝔯}
  class = ∀ {ℜ} → M.class ℜ
  type = ∀ {ℜ} → M.type ℜ
  method : ⦃ _ : class ⦄ → type
  method ⦃ ⌶ ⦄ {ℜ = ℜ} = M.method ℜ ⦃ ⌶ {ℜ} ⦄ -- FIXME

module RelSingle-RelSingle/Rel/RelSingle
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (ℜ : 𝔒 → 𝔒 → Ø 𝔯)
  (x : 𝔒)
  = ℭlass (mkClass ℜ (ℜ x x))

module Rel-RelSingle/Rel/RelSingle
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (ℜ : 𝔒 → 𝔒 → Ø 𝔯)
  where
  private module M = RelSingle-RelSingle/Rel/RelSingle ℜ
  class = ∀ {x} → M.class x
  type = ∀ {x} → M.type x
  method = λ ⦃ _ : class ⦄ {x} → M.method x

module Prop-Rel-RelSingle/Rel/RelSingle
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  = Rel-RelSingle/Rel/RelSingle (Extension 𝔓)

module All-Prop-Rel-RelSingle/Rel/RelSingle (𝔬 𝔭 : Ł) where
  private module M = Prop-Rel-RelSingle/Rel/RelSingle
  class = ∀ {𝔒 : Ø 𝔬} {𝔓 : 𝔒 → Ø 𝔭} → M.class 𝔓
  type = ∀ {𝔒 : Ø 𝔬} {𝔓 : 𝔒 → Ø 𝔭} → M.type 𝔓
  method : ⦃ _ : class ⦄ → type
  method {𝔓 = 𝔓} = M.method 𝔓

module UnitLevel-RelSingle/Rel/RelSingle
  {𝔬} (𝔒 : Ø 𝔬) (𝔯 : Ł)
  where
  private module M = Rel-RelSingle/Rel/RelSingle {𝔒 = 𝔒} {𝔯 = 𝔯}
  class = ∀ {ℜ} → M.class ℜ
  type = ∀ {ℜ} → M.type ℜ
  method : ⦃ _ : class ⦄ → type
  method {ℜ = ℜ} = M.method ℜ

module PropSingle-PropSingle/Prop/PropSingle
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  (x : 𝔒)
  where
  open ℭlass (mkClass 𝔓 (𝔓 x)) public

module Prop-PropSingle/Prop/PropSingle
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  where
  private module M = PropSingle-PropSingle/Prop/PropSingle 𝔓
  class = ∀ {x} → M.class x
  type = ∀ x → M.type x
  method = λ ⦃ _ : class ⦄ x → M.method x

module Asymmetric
  ℓ
  (𝔓' : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} (𝔓 : 𝔒 → Ø 𝔭) (x : 𝔒) → 𝔓 x → Ø ℓ)
  where
  module U = Unit-Unit/Unit/Unit
  test-class' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y : 𝔓 x} → U.class (𝔓' 𝔓 x y) ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y : 𝔓 x} → U.class (𝔓' 𝔓 x y)
  test-class' = !

module Symmetric
  ℓ
  (𝔓' : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} (𝔓 : 𝔒 → Ø 𝔭) (x : 𝔒) → 𝔓 x → 𝔓 x → Ø ℓ)
  where
  module U = Unit-Unit/Unit/Unit
  test-class' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} → U.class (𝔓' 𝔓 x y z → 𝔓' 𝔓 x y z) ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} → U.class (𝔓' 𝔓 x y z → 𝔓' 𝔓 x y z)
  test-class' ⦃ ⌶ ⦄ = !
  module V {𝔬} (𝔒 : Ø 𝔬) = ℭlass (mkClass 𝔒 (𝔒 → 𝔒))
  test-classV : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} → V.class (𝔓' 𝔓 x y z) ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} → V.class (𝔓' 𝔓 x y z)
  test-classV ⦃ ⌶ ⦄ = !
  test-methodV : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} → V.class (𝔓' 𝔓 x y z) ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} → V.type (𝔓' 𝔓 x y z)
  test-methodV ⦃ ⌶ ⦄ = V.method _
  module W {𝔬} {𝔒 : Ø 𝔬} (p : 𝔒) = ℭlass (mkClass p 𝔒)
  test-classW : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} {p : 𝔓' 𝔓 x y z} → W.class p ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} {p : 𝔓' 𝔓 x y z} → W.class p
  test-classW ⦃ ⌶ ⦄ = magic
  test-methodW : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} {p : 𝔓' 𝔓 x y z} → W.class p ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} {x : 𝔒} {y z : 𝔓 x} {p : 𝔓' 𝔓 x y z} → W.type p
  test-methodW {p = p} = W.method p

module Prop-
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  where
  module -Unit/Unit/Unit where
    module V = Prop-Unit/Unit/Unit 𝔓
    module H = Prop-Unit/Unit/Unit
    module X = Unit-Unit/Unit/Unit
    test-class' : ⦃ _ : {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓 ⦄ → {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓
    test-class' ⦃ ⌶ ⦄ {𝔓 = 𝔓} = magic -- ⌶ {𝔓 = 𝔓} -- FIXME
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V = V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H = H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X _ = X.method _ -- FIXME
  module -PropSingle/Prop/PropSingle where
    module V = Prop-PropSingle/Prop/PropSingle 𝔓
    module H = Prop-PropSingle/Prop/PropSingle
    module X = PropSingle-PropSingle/Prop/PropSingle
    test-class' : ⦃ _ : {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓 ⦄ → {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓
    test-class' ⦃ ⌶ ⦄ = magic
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V = V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H = H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X _ = X.method _ _ -- FIXME

module Rel-
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (ℜ : 𝔒 → 𝔒 → Ø 𝔯)
  where
  module -Unit/Unit/Unit where
    module V = Rel-Unit/Unit/Unit ℜ
    module H = Rel-Unit/Unit/Unit
    module X = Unit-Unit/Unit/Unit
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V = V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H = H.method ℜ -- FIXME
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X _ = X.method _ -- FIXME
  module -RelSingle/Rel/RelSingle where
    module V = Rel-RelSingle/Rel/RelSingle ℜ
    module H = Rel-RelSingle/Rel/RelSingle
    module X = RelSingle-RelSingle/Rel/RelSingle
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V = V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H = H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X = X.method _ _

module Prop-Rel-
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  where
  module -Unit/Unit/Unit where
    module V = Prop-Rel-Unit/Unit/Unit 𝔓
    module H = Prop-Rel-Unit/Unit/Unit
    module X = RelSingle-Unit/Unit/Unit
    test-class' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓 ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓
    test-class' ⦃ ⌶ ⦄ {ℜ} = magic -- ! -- FIXME
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V ⦃ ⌶ ⦄ = magic
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H ⦃ ⌶ ⦄ = magic -- H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X ⦃ ⌶ ⦄ = magic -- X.method _ _
  module -RelSingle/Rel/RelSingle where
    module V = Prop-Rel-RelSingle/Rel/RelSingle 𝔓
    module H = Prop-Rel-RelSingle/Rel/RelSingle
    module X = RelSingle-RelSingle/Rel/RelSingle
    test-class' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} → H.class 𝔓 ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} (𝔓 : 𝔒 → Ø 𝔭) → H.class 𝔓
    test-class' ⦃ ⌶ ⦄ = !
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V ⦃ ⌶ ⦄ = magic -- V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H ⦃ ⌶ ⦄ = magic -- H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X ⦃ ⌶ ⦄ = magic -- FIXME

module UnitLevel-
  {𝔬} (𝔒 : Ø 𝔬) ℓ
  where
  module -Unit/Unit/Unit where
    module V = UnitLevel-Unit/Unit/Unit 𝔒 ℓ
    module H = UnitLevel-Unit/Unit/Unit
    module X = RelSingle-Unit/Unit/Unit
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class ⦃ ⌶ ⦄ {ℜ} = ⌶ {ℜ} -- FIXME
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V ⦃ ⌶ ⦄ {ℜ} = magic
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H ⦃ ⌶ ⦄ {ℜ} = magic -- H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X ⦃ ⌶ ⦄ {ℜ} x = magic -- X.method _ _
  module -RelSingle/Rel/RelSingle where
    module V = UnitLevel-RelSingle/Rel/RelSingle 𝔒 ℓ
    module H = UnitLevel-RelSingle/Rel/RelSingle
    module X = RelSingle-RelSingle/Rel/RelSingle
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V ⦃ ⌶ ⦄ {ℜ} = magic -- V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H ⦃ ⌶ ⦄ {ℜ} = magic -- H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X ⦃ ⌶ ⦄ {ℜ} = X.method ℜ _ -- FIXME

module Rel-Extension
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  (let ℜ = Extension 𝔓)
  where
  module -Unit/Unit/Unit where
    module V = Rel-Unit/Unit/Unit ℜ
    module H = Rel-Unit/Unit/Unit
    module X = Unit-Unit/Unit/Unit
    test-class' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} (let ℜ = Extension 𝔓) → H.class ℜ ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} (let ℜ = Extension 𝔓) → H.class ℜ
    test-class' ⦃ ⌶ ⦄ {𝔓 = 𝔓} = magic -- ⌶ {𝔓 = 𝔓} -- FIXME
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V = V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H = H.method ℜ -- FIXME
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X _ = X.method _ -- FIXME
  module -RelSingle/Rel/RelSingle where
    module V = Rel-RelSingle/Rel/RelSingle ℜ
    module H = Rel-RelSingle/Rel/RelSingle
    module X = RelSingle-RelSingle/Rel/RelSingle
    test-class' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} (let ℜ = Extension 𝔓) → H.class ℜ ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} (let ℜ = Extension 𝔓) → H.class ℜ
    test-class' ⦃ ⌶ ⦄ = ! -- !
    test-class'' : ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} (let ℜ = λ x _ → 𝔓 x) → H.class ℜ ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} (let ℜ = λ x _ → 𝔓 x) → H.class ℜ
    test-class'' ⦃ ⌶ ⦄ = ! -- !
    test-class : ⦃ _ : V.class ⦄ → V.class
    test-class = !
    test-method-V : ⦃ _ : V.class ⦄ → V.type
    test-method-V = V.method
    test-method-H : ⦃ _ : V.class ⦄ → V.type
    test-method-H = H.method _
    test-method-X : ⦃ _ : V.class ⦄ → V.type
    test-method-X = X.method _ _

module AllUnitTest where
  test : ⦃ I : ∀ {𝔬} {𝔒 : Ø 𝔬} → Unit-Unit/Unit/Unit.class 𝔒 ⦄ → ∀ {𝔬} {𝔒 : Ø 𝔬} → Unit-Unit/Unit/Unit.class 𝔒
  test = !

module AllTest
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭}
  where

  testProp : ⦃ I : {𝔓 : 𝔒 → Ø 𝔭} → Prop-PropSingle/Prop/PropSingle.class 𝔓 ⦄ → {𝔓 : 𝔒 → Ø 𝔭} → Prop-PropSingle/Prop/PropSingle.class 𝔓
  testProp = !

  testUnitProp : ⦃ I : {𝔓 : 𝔒 → Ø 𝔭} → Prop-Unit/Unit/Unit.class 𝔓 ⦄ → {𝔓 : 𝔒 → Ø 𝔭} → Prop-Unit/Unit/Unit.class 𝔓
  testUnitProp ⦃ I ⦄ {𝔓} = I {𝔓}

module SinglePropTest
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔭} (𝔓 : 𝔒 → Ø 𝔭)
  where

  testProp : ⦃ _ : Prop-PropSingle/Prop/PropSingle.class 𝔓 ⦄ → Prop-PropSingle/Prop/PropSingle.class 𝔓
  testProp = !

  testUnitProp : ⦃ _ : Prop-Unit/Unit/Unit.class 𝔓 ⦄ → Prop-Unit/Unit/Unit.class 𝔓
  testUnitProp = !

module SingleRelTest
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (ℜ : 𝔒 → 𝔒 → Ø 𝔯)
  where
  testProp : ⦃ _ : Rel-RelSingle/Rel/RelSingle.class ℜ ⦄ → Rel-RelSingle/Rel/RelSingle.class ℜ
  testProp = !
  testUnit : ⦃ _ : Rel-Unit/Unit/Unit.class ℜ ⦄ → Rel-Unit/Unit/Unit.class ℜ
  testUnit = !


module Examples where

open import Data.List hiding (reverse)
open import Data.List.All
open import Data.Nat

open import Typing
open import Syntax

ex1 : Expr [] TUnit
ex1 =
  letbind [] (new [] (delay send!))
  (letpair (left []) (here [])
  (letbind (rght (left []))
           (fork (wait (here [])))
  (close (there UUnit (here [])))))

ex1dual : Expr [] TUnit
ex1dual =
  letbind [] (new [] (delay send!))
  (letpair (left []) (here [])
  (letbind (left (rght []))
           (fork (close (here [])))
  (wait (there UUnit (here [])))))

-- sending and receiving
ex2 : Expr [] TUnit
ex2 =
  letbind [] (new [] (delay (Typing.send TInt (delay send!))))
  (letpair (left []) (here [])
  (letbind (left (rght []))
           (fork (letbind (rght []) (nat [] 42)
                 (letbind (left (left [])) (Expr.send (rght (left [])) (here []) (here []))
                 (letbind (left []) (close (here []))
                 (var (here []))))))
  (letbind (rght (left [])) (Expr.recv (here []))
  (letpair (left (rght [])) (here [])
  (letbind (left (left (rght []))) (wait (here (UInt ∷ [])))
  (var (here (UUnit ∷ []))))))))

-- higher order sending and receiving
ex3 : Expr [] TUnit
ex3 =
  letbind [] (new [] (delay (Typing.send (TChan send!) (delay send!))))
  (letbind (rght []) (new [] (delay send!))
  (letpair (left (rght [])) (here [])
  (letpair (rght (rght (left []))) (here [])
  (letbind (left (rght (left (left []))))
           (fork (letbind (left (left (rght []))) (Expr.send (left (rght [])) (here []) (here []))
                 (letbind (left (rght [])) (close (here []))
                 (wait (there UUnit (here []))))))
  (letbind (left (left [])) (Expr.recv (there UUnit (here [])))
  (letpair (left []) (here [])
  (letbind (left (rght [])) (wait (here []))
  (letbind (left (left [])) (close (there UUnit (here [])))
  (var (here []))))))))))

-- branching
ex4 : Expr [] TUnit
ex4 =
  letbind [] (new [] (delay (sintern (delay send!) (delay send?))))
  (letpair (left []) (here [])
  (letbind (left (rght []))
           (fork (letbind (left []) (select Left (here []))
                 (close (here []))))
  (branch (left (left [])) (there UUnit (here []))
          (wait (here []))
          (close (here [])))))

-- simple lambda: (λx.x)()
ex5 : Expr [] TUnit
ex5 = letbind [] (llambda [] [] (var (here [])))
      (letbind (rght []) (unit [])
      (app (rght (left [])) (here []) (here [])))

-- lambda app: (λfx.fx) (λx.x)()
ex6 : Expr [] TUnit
ex6 = letbind [] (llambda [] [] (llambda (left []) [] (app (rght (left [])) (here []) (here []))))
      (letbind (rght []) (llambda [] [] (var (here [])))
      (letbind (rght (rght [])) (unit [])
      (letbind (rght (left (left []))) (app (rght (left [])) (here []) (here []))
      (app (left (rght [])) (here []) (here [])))))


record R₁ : Set₁ where
  field
    A : Set

open R₁ ⦃ … ⦄

record R₂ : Set₁ where
  field
    ⦃ r₁ ⦄ : R₁

  B : Set
  B = A


{-
  Copyright 2019 Lisandra Silva

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

open import Prelude
open import Data.Fin hiding (_≟_; _<?_; _≤?_ ;_+_; pred; lift)
                     renaming (_<_ to _<F_; _≤_ to _≤F_)
open import Data.List
open import Data.List.Properties
open import Data.Maybe.Base as Maybe using (Maybe; nothing; just)
open import Data.Vec.Base as Vec using (Vec)
open import Data.Bool hiding (_<_ ; _<?_; _≤_; _≤?_; _≟_)
open import Data.Vec.Any
open import Data.Vec.All hiding (lookup)

open import StateMachineModel
open import Stream

module DistributedSystem.Prototype
  {ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ : Level}
  (N : ℕ)
  (f : ℕ)
  (fta : N > 3 * f)
  (ClientRequest : Set ℓ₂)
  (Block : Set ℓ₃)
  (Vote : Set ℓ₄)
  (QC : Set ℓ₅)
  where

  -- Client can make a request at any moment

{-
    0 - Set node role
               LEADER                 ||           LEADER & FOLLOWER
    1 - block = getPoolReq
    2 - broadcast block
                                      ||    3 - receive block
                                      ||    4 - vote for block
    5 - while (#votes < N-f-1)
    6 -    reveive vote
    5 - broadcast QC
                                      ||    7 - receive QC
                                      ||    8 - check commit rule
                                      ||    9 - movenextview
-}

  -- QUESTION:
  -- To prove the liveness not only the sequence of honest leaders per view must be
  -- long enough but also the length of the requests must be greater than 3.
  -- If the sequence is smaller we don't have enough requests to ensure the commit rule

  -- A dishonest leader can deliberately left honest nodes behind, and these nodes
  -- won't move to the next view, unless they timeout. However, t if these nodes have
  -- moved for the next view for timeout, they will be missing a block and a qc
  -- in the RecordStore, how to fix this?
  --     1 - Whisper of proposed blocks and Qc's
  --     2 - Whisper only of QC's (if they have attached the proposed block)
  --     3 - Mechanism of asking records missing in the record store

  -----------------------------------------------------------------------------
  -- SPECIFICATION
  -----------------------------------------------------------------------------

  NodeID = Fin N
  HonestID = Fin (N ∸ f)
  Instruction = Fin 10

  Receiver = Fin N

  DishonestID : NodeID → Set
  DishonestID nId = N ∸ f ≤ toℕ nId

  data Message : Set (ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    blockM   : Block → Message
    voteM    : Vote  → Message
    qcM      : QC    → Message

  data Role : Set where
    leader   : Role
    follower : Role

  record NodeState : Set (ℓ₁ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    field
      nodeRole     : Role
      currNodeView : ℕ
      msgBuffer    : List Message
      readMessages : ℕ

      currProposal : Block
      votesforQC   : List Vote

      control      : Instruction

      -- id           : Node
      --recordTree    : RecordTree
      -- previousRound : ℕ
      -- lockedRound   : ℕ
      -- clock        : ℕ
      -- timeout      : ℕ
  open NodeState

  record State : Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    field
     -- I am not sure that we don't need the faulty Node States
     -- because we may need to express that we have at least (N ∸ f)
     -- nodes on the same view and it may be that the f nodes behave normally
     nodeStates    : Vec NodeState (N ∸ f)
     leaderPerView : Stream (Fin N)
     poolRequests  : List ClientRequest
     committedReq  : ℕ
  open State

  Honest? : Decidable ((_< N ∸ f) ∘ toℕ {N})
  Honest? x = toℕ x <? N ∸ f

  Dishonest? : Decidable ((N ∸ f ≤_) ∘ toℕ {N})
  Dishonest? x = N ∸ f ≤? toℕ x

  mkBlock : ClientRequest → NodeState → Block

  mkQC : NodeState → QC

  mkVote : NodeState → Vote

  validVote  : State → HonestID → Vote  → Set

  validBlock : State → HonestID → Block → Set

  validQC : State → HonestID → QC → Set

  ¬validMsg : State → HonestID → Message → Set

  data HonestEvent (nId : HonestID) : Set (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    setNodeRole  : HonestEvent nId
    getPoolReq   : ClientRequest → HonestEvent nId
    broadcastB   : Block → HonestEvent nId
    broadcastQC  : QC → HonestEvent nId
    wait         : HonestEvent nId
    receive      : Message → HonestEvent nId
    dropMsg      : Message → HonestEvent nId
    sendVote     : Vote → Receiver → HonestEvent nId
    commit       : HonestEvent nId
    moveNextView : HonestEvent nId

  data DSEvent : Set (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    newRequest     : ClientRequest → DSEvent -- A client add a request to the request pool
    honestEvent    : ∀ {nId} → HonestEvent nId → DSEvent
    dishonestEvent : Message → HonestID → DSEvent -- dishonest nodes can send any msg to honest nodes

  nodeSt : HonestID → State → NodeState
  nodeSt nId st = Vec.lookup (nodeStates st) nId

  -- Other option is to have a flag in the NodeState saying if it's leader or follower
  isLeader : State → HonestID → Set
  isLeader st nId = nodeRole (nodeSt nId st) ≡ leader

  getLeader : State → HonestID → Fin N
  getLeader st nId = get (leaderPerView st) (currNodeView (nodeSt nId st))

  {- Instruction is an abstraction for the number of intructions available for the node -}
  nextInstruction : State → HonestID → Instruction
  nextInstruction st nId = control (nodeSt nId st)

  data HonestEnabled (nId : HonestID) (st : State) : HonestEvent nId
       → Set (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    setRoleEn      :  nextInstruction st nId ≡ 0F
                    → HonestEnabled nId st setNodeRole

    getReqEn       :  ∀ {req}
                    → isLeader st nId
                    → nextInstruction st nId ≡ 1F
                    → (comm< : committedReq st < length (poolRequests st))
                    -- Maybe it's better to have a function:
                    -- fetchNextReq : List ClientRequests → Maybe (Index , Request)
                    → req ≡ lookup (poolRequests st) (fromℕ≤ comm<)
                    → HonestEnabled nId st (getPoolReq req)

    broadcastBEn   :  isLeader st nId
                    → nextInstruction st nId ≡ 2F
                    → HonestEnabled nId st (broadcastB (currProposal (nodeSt nId st)))

    receiveBlockEn :  ∀ {b : Block}
                    → nextInstruction st nId ≡ 3F
                    → (i : readMessages (nodeSt nId st) < length (msgBuffer (nodeSt nId st)))
                    → blockM b ≡ lookup (msgBuffer (nodeSt nId st)) (fromℕ≤ i)
                    → validBlock st nId b
                    → HonestEnabled nId st (receive (blockM b))

    voteBlockEn    :  nextInstruction st nId ≡ 4F
                    → HonestEnabled nId st (sendVote
                                            (mkVote (nodeSt nId st))
                                            (getLeader st nId))

    waitVotesEn    :  isLeader st nId
                    → nextInstruction st nId ≡ 5F
                    → length (votesforQC (nodeSt nId st)) < N ∸ f ∸ 1
                    → HonestEnabled nId st wait

    receiveVoteEn  :  ∀ {v : Vote}
                    → isLeader st nId
                    → nextInstruction st nId ≡ 6F
                    → (i : readMessages (nodeSt nId st) < length (msgBuffer (nodeSt nId st)))
                    → voteM v ≡ lookup (msgBuffer (nodeSt nId st)) (fromℕ≤ i)
                    → validVote st nId v
                    → HonestEnabled nId st (receive (voteM v))

    broadcastQCEn  :  isLeader st nId
                    → nextInstruction st nId ≡ 5F
                    → length (votesforQC (nodeSt nId st)) ≡ N ∸ f ∸ 1
                    → HonestEnabled nId st (broadcastQC (mkQC (nodeSt nId st)))

    receiveQCEn    :  ∀ {qc : QC}
                    → nextInstruction st nId ≡ 7F
                    → (i : readMessages (nodeSt nId st) < length (msgBuffer (nodeSt nId st)))
                    → qcM qc ≡ lookup (msgBuffer (nodeSt nId st)) (fromℕ≤ i)
                    → validQC st nId qc
                    → HonestEnabled nId st (receive (qcM qc))

    dropMsgEn      : ∀ {msg}
                    → (i : readMessages (nodeSt nId st) < length (msgBuffer (nodeSt nId st)))
                    → msg ≡ lookup (msgBuffer (nodeSt nId st)) (fromℕ≤ i)
                    → ¬validMsg st nId msg
                    → HonestEnabled nId st (dropMsg msg)

    commitEn       :  nextInstruction st nId ≡ 8F
                    -- TODO: check commit rule
                    → HonestEnabled nId st commit

    moveNextViewEn :  nextInstruction st nId ≡ 8F ⊎ DishonestID (getLeader st nId)
                    → HonestEnabled nId st moveNextView

  data Enabled : DSEvent → State → Set (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    newReqEn      : ∀ {st req}
                    → Enabled (newRequest req) st

    honestEvEn    : ∀ {st hId hEv}
                    → HonestEnabled hId st hEv
                    → Enabled (honestEvent hEv) st

    dishonestEvEn : ∀ {st dId msg hId}
                    → DishonestID dId
                    → Enabled (dishonestEvent msg hId) st
                    -- Maybe I need to postulate that dishonest nodes cannot
                    -- forge signatures (Node (N ∸ f))

  sendMsgToNode : Message → NodeState → NodeState
  sendMsgToNode msg nodeSt = record nodeSt { msgBuffer = msgBuffer nodeSt ++ [ msg ] }

  broadcast : State → Message → Vec NodeState (N ∸ f)
  broadcast st msg = Vec.map (λ n → sendMsgToNode msg n) (nodeStates st)

  Action : ∀ {preState} {event} → Enabled event preState → State

  Action {ps} {newRequest req} x =
    record ps
    { poolRequests = poolRequests ps ++ [ req ] }

  Action {ps} {honestEvent {nId} setNodeRole} x
    with toℕ nId ≟ toℕ (getLeader ps nId)
  ... | yes p
        = let updateNode = λ old → record old
                                   { nodeRole = leader
                                   ; control = 1F
                                   }
          in record ps
             { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }
  ... | no ¬p
        = let updateNode = λ old → record old
                               { nodeRole = follower
                               ; control = 3F
                               }
          in record ps
             { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  Action {ps} {honestEvent {nId} (getPoolReq req)} x
    = let updateNode = λ old → record old
                               { control = 2F
                               ; currProposal = mkBlock req old
                               }
      in record ps
         { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  -- QUESTION:
  -- Not sure if it's a good approach to consider a broadcast atomically,
  -- or have a different state transition to send to each node
  Action {ps} {honestEvent {nId} (broadcastB b)} x
    = let sendToAll = broadcast ps (blockM b)
          updateLeader = λ old → record old { control = 3F }
      in record ps
         { nodeStates = Vec.updateAt nId updateLeader sendToAll }

  Action {ps} {honestEvent {nId} (receive (blockM b))} x
    -- TODO : update RecordTree
    =  let updateNode = λ old → record old { readMessages = 1 + readMessages old
                                           ; currProposal = b
                                           ; control = 4F }
       in record ps
          { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  Action {ps} {honestEvent {nId} (sendVote v receiver)} x
    with toℕ receiver <? N ∸ f | nodeRole (nodeSt nId ps)
  -- If receiver is not honest → only updates the control variable of the sender
  ... | no ¬p | leader
        = let updateNode = λ old → record old { control = 5F }
          in record ps
             { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }
  ... | no ¬p | follower
        = let updateNode = λ old → record old { control = 7F }
          in record ps
             { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }
  -- If receiver is honest → update the message buffer of the receiver as well
  ... | yes p | leader
        = let updateReceiver = Vec.updateAt
                                 (fromℕ≤ p)
                                 (sendMsgToNode (voteM v))
                                 (nodeStates ps)
              updateNode = λ old → record old { control = 5F }
          in record ps
             { nodeStates = Vec.updateAt nId updateNode updateReceiver }
  ... | yes p | follower
        = let updateReceiver = Vec.updateAt
                                 (fromℕ≤ p)
                                 (sendMsgToNode (voteM v))
                                 (nodeStates ps)
              updateNode = λ old → record old { control = 7F }
          in record ps
             { nodeStates = Vec.updateAt nId updateNode updateReceiver }

  Action {ps} {honestEvent {nId} wait} x
    = let updateInst = λ old → record old { control = 6F }
      in record ps
         { nodeStates = Vec.updateAt nId updateInst (nodeStates ps) }

  Action {ps} {honestEvent {nId} (receive (voteM  v))} x
    = let updateNode = λ old → record old { readMessages = 1 + readMessages old
                                          ; control = 5F
                                          ; votesforQC =  v ∷ votesforQC old }
       in record ps
          { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  Action {ps} {honestEvent {nId} (broadcastQC q)} x
    = let sendToAll = broadcast ps (qcM q)
          updateLeader = λ old → record old { control = 7F }
       in record ps
          { nodeStates = Vec.updateAt nId updateLeader sendToAll }

  Action {ps} {honestEvent {nId} (receive (qcM qc))} x
    = let updateNode = λ old → record old { readMessages = 1 + readMessages old
                                          ; control = 8F }
      in record ps
         { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  Action {ps} {honestEvent {nId} (dropMsg msg)} x
    =  let updateNode = λ old → record old { readMessages = 1 + readMessages old }
       in record ps
          { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  Action {ps} {honestEvent commit} x = {!!}

  Action {ps} {honestEvent {nId} moveNextView} x
    = let updateNode = λ old → record old { currNodeView = 1 + currNodeView old
                                          ; control = 0F }
      in record ps
         { nodeStates = Vec.updateAt nId updateNode (nodeStates ps) }

  Action {ps} {dishonestEvent msg hId} x
    = record ps
      { nodeStates = Vec.updateAt hId (sendMsgToNode msg) (nodeStates ps) }

  nodeᵢ : NodeState → Set (ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅)
  nodeᵢ nSt =   nodeRole nSt ≡ follower
              × currNodeView nSt ≡ 0
              × msgBuffer nSt ≡ []
              × readMessages nSt ≡ 0
              × currProposal nSt ≡ {!!}
              × votesforQC nSt ≡ []
              × control nSt ≡ 0F

  stateᵢ : State → Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅)
  stateᵢ st = poolRequests st ≡ [] × committedReq st ≡ 0 × All nodeᵢ (nodeStates st)
    -- instantiate leaderPerView or maybe it's not necessary

  MyStateMachine : StateMachine State DSEvent
  MyStateMachine = record
                   { initial = stateᵢ
                   ; enabled = Enabled
                   ; action  = Action }

  NodeEvSet : HonestID → EventSet {Event = DSEvent}
  NodeEvSet nId (newRequest x) = ⊥
  NodeEvSet nId₁ (honestEvent {nId₂} x) = nId₁ ≡ nId₂
  NodeEvSet nId (dishonestEvent x x₁) = ⊥

  data MyWeakFairness : EventSet → Set (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅) where
    wf : (nId : HonestID) → MyWeakFairness (NodeEvSet nId)

  MySystem : System State DSEvent
  MySystem = record
             { stateMachine = MyStateMachine
             ; weakFairness = MyWeakFairness
             }


{-# OPTIONS --without-K #-}
module well-typed-syntax-context-helpers where
open import common
open import well-typed-syntax
open import well-typed-syntax-helpers

□_ : Typ ε → Set
□_ T = Term {Γ = ε} T


-- Andreas, 2020-03-26, issue #4481, reported by gallais

-- #952 unintentionally added named lambdas, but without updating the type-checker.

-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.term.expr.top:15 #-}
-- {-# OPTIONS -v tc.term.lambda:30 #-}

open import Agda.Primitive

-- In Agda 2.6.0 and 2.6.1, this is a fake inconsistency proof:

data ⊥ : Set where
record ⊤ : Set where

proj2 : ∀ a {A B : Set a} → Set a
proj2 = λ _ {B = B} → B

agdaIsInconsistent : proj2 lzero {⊤} {⊥}
agdaIsInconsistent = _  -- should be yellow in > 2.6.1

-- The following should complain about unexpected implicit argument:

_ : Set → {A B : Set} → Set
_ = λ _ {C = B} {A} → A  -- should fail


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Common syntax.

module BasicIS4.Syntax.Common where

open import Common.ContextPair public

-- Types, or propositions.

infixr 10 □_
infixl 9 _∧_
infixr 7 _▻_
data Ty : Set where
  α_  : Atom → Ty
  _▻_ : Ty → Ty → Ty
  □_  : Ty → Ty
  _∧_ : Ty → Ty → Ty
  ⊤  : Ty

-- Additional useful types.

infix 7 _▻◅_
_▻◅_ : Ty → Ty → Ty
A ▻◅ B = (A ▻ B) ∧ (B ▻ A)

infixr 7 _▻⋯▻_
_▻⋯▻_ : Cx Ty → Ty → Ty
∅       ▻⋯▻ B = B
(Ξ , A) ▻⋯▻ B = Ξ ▻⋯▻ (A ▻ B)

infixr 10 □⋆_
□⋆_ : Cx Ty → Cx Ty
□⋆ ∅       = ∅
□⋆ (Ξ , A) = □⋆ Ξ , □ A

dist□⋆₁ : ∀ Ξ Ξ′ → □⋆ (Ξ ⧺ Ξ′) ≡ (□⋆ Ξ) ⧺ (□⋆ Ξ′)
dist□⋆₁ Ξ ∅        = refl
dist□⋆₁ Ξ (Ξ′ , A) = cong² _,_ (dist□⋆₁ Ξ Ξ′) refl

lift⊆ : ∀ {Δ Δ′} → Δ ⊆ Δ′ → □⋆ Δ ⊆ □⋆ Δ′
lift⊆ done     = done
lift⊆ (skip θ) = skip (lift⊆ θ)
lift⊆ (keep θ) = keep (lift⊆ θ)

-- Inversion principles.

invα : ∀ {P P′} → α P ≡ α P′ → P ≡ P′
invα refl = refl

inv▻₁ : ∀ {A A′ B B′} → A ▻ B ≡ A′ ▻ B′ → A ≡ A′
inv▻₁ refl = refl

inv▻₂ : ∀ {A A′ B B′} → A ▻ B ≡ A′ ▻ B′ → B ≡ B′
inv▻₂ refl = refl

inv□ : ∀ {A A′} → □ A ≡ □ A′ → A ≡ A′
inv□ refl = refl

inv∧₁ : ∀ {A A′ B B′} → A ∧ B ≡ A′ ∧ B′ → A ≡ A′
inv∧₁ refl = refl

inv∧₂ : ∀ {A A′ B B′} → A ∧ B ≡ A′ ∧ B′ → B ≡ B′
inv∧₂ refl = refl

-- Decidable equality on types.

_≟ᵀ_ : (A A′ : Ty) → Dec (A ≡ A′)
(α P)   ≟ᵀ (α P′)    with P ≟ᵅ P′
(α P)   ≟ᵀ (α .P)    | yes refl = yes refl
(α P)   ≟ᵀ (α P′)    | no  P≢P′ = no (P≢P′ ∘ invα)
(α P)   ≟ᵀ (A′ ▻ B′) = no λ ()
(α P)   ≟ᵀ (□ A′)    = no λ ()
(α P)   ≟ᵀ (A′ ∧ B′) = no λ ()
(α P)   ≟ᵀ ⊤        = no λ ()
(A ▻ B) ≟ᵀ (α P′)    = no λ ()
(A ▻ B) ≟ᵀ (A′ ▻ B′) with A ≟ᵀ A′ | B ≟ᵀ B′
(A ▻ B) ≟ᵀ (.A ▻ .B) | yes refl | yes refl = yes refl
(A ▻ B) ≟ᵀ (A′ ▻ B′) | no  A≢A′ | _        = no (A≢A′ ∘ inv▻₁)
(A ▻ B) ≟ᵀ (A′ ▻ B′) | _        | no  B≢B′ = no (B≢B′ ∘ inv▻₂)
(A ▻ B) ≟ᵀ (□ A′)    = no λ ()
(A ▻ B) ≟ᵀ (A′ ∧ B′) = no λ ()
(A ▻ B) ≟ᵀ ⊤        = no λ ()
(□ A)   ≟ᵀ (α P′)    = no λ ()
(□ A)   ≟ᵀ (A′ ▻ B′) = no λ ()
(□ A)   ≟ᵀ (□ A′)    with A ≟ᵀ A′
(□ A)   ≟ᵀ (□ .A)    | yes refl = yes refl
(□ A)   ≟ᵀ (□ A′)    | no  A≢A′ = no (A≢A′ ∘ inv□)
(□ A)   ≟ᵀ (A′ ∧ B′) = no λ ()
(□ A)   ≟ᵀ ⊤        = no λ ()
(A ∧ B) ≟ᵀ (α P′)    = no λ ()
(A ∧ B) ≟ᵀ (A′ ▻ B′) = no λ ()
(A ∧ B) ≟ᵀ (□ A′)    = no λ ()
(A ∧ B) ≟ᵀ (A′ ∧ B′) with A ≟ᵀ A′ | B ≟ᵀ B′
(A ∧ B) ≟ᵀ (.A ∧ .B) | yes refl | yes refl = yes refl
(A ∧ B) ≟ᵀ (A′ ∧ B′) | no  A≢A′ | _        = no (A≢A′ ∘ inv∧₁)
(A ∧ B) ≟ᵀ (A′ ∧ B′) | _        | no  B≢B′ = no (B≢B′ ∘ inv∧₂)
(A ∧ B) ≟ᵀ ⊤        = no λ ()
⊤      ≟ᵀ (α P′)    = no λ ()
⊤      ≟ᵀ (A′ ▻ B′) = no λ ()
⊤      ≟ᵀ (□ A′)    = no λ ()
⊤      ≟ᵀ (A′ ∧ B′) = no λ ()
⊤      ≟ᵀ ⊤        = yes refl

open ContextEquality (_≟ᵀ_) public


-- Andreas, 2016-08-04, issue #964
-- Allow open metas and interaction points in imported files

{-# OPTIONS --allow-unsolved-metas #-}

-- {-# OPTIONS -v import:100 #-}
-- {-# OPTIONS -v meta.postulate:20 #-}
-- {-# OPTIONS -v tc.meta:25 #-}

-- Andreas, 2016-10-09, while working on issue #2223:
--
-- This module is an example that we can be in a context
-- that is shorter than the current section.
-- Typically, this would be the empty context.
--
-- {-# OPTIONS -v tc.constr.add:45 #-}

open import Common.Level

module Common.Issue964.UnsolvedMetas (A : Set₁) where

meta : Level
meta = {!!}  -- unsolved interaction point

module M (B : Set) where

  meta2 : Set meta
  meta2 = _  -- unsolved meta

  module N (C D : meta2) where

    meta3 : meta2
    meta3 = Set

-- EOF


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

data Vec (A : Set) : Nat → Set where

variable
  A  : Set
  x  : A
  n  : Nat
  xs : Vec A n

postulate
  IsHead : A → Vec A (suc n) → Set

-- Should also work if there is pruning
solve_==_by_ : (m n : Nat) → m ≡ n → Set
solve_==_by_ _ _ _ = Nat

mutual-block : Set

meta : Nat
meta = _

-- `n` gets pruned due to the meta == suc n constraint, so we can't generalize over it
module _ (X : Set) where
  tricky : let n = _
               _ = solve meta == suc n by refl
           in IsHead {n = n} x xs → Nat
  tricky h = 0

mutual-block = Nat


-- Andreas, 2017-11-14, issue #2849, reported by laMudri

-- Internal error, regression introduced by new pattern Internal.AbsurdP

{-# OPTIONS --allow-unsolved-metas #-}

-- {-# OPTIONS -v tc.with.strip:30 #-}

open import Agda.Builtin.Equality

data ⊥ : Set where

data Bool : Set where
  true false : Bool

data P : Bool → Set where
  pt : P true

postulate
  b : Bool
  eq : b ≡ false

works : P b → ⊥
works p with b | eq
works () | .false | refl

test : P b → ⊥
test () rewrite eq

-- WAS (2.5.3): Internal error

-- OK error:
-- Failed to solve the following constraints:
--   Is empty: P b

-- This could also succeed, but somehow the rewrite does not
-- apply to the IsEmpty constraint generated by the absurd pattern.
-- The rewrite should be happening before the absurd pattern split.


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

-- LBFT monad used by implementation,
-- and functions to facilitate reasoning about it.

module LibraBFT.ImplShared.LBFT where

open import Dijkstra.RWS
open import Haskell.Modules.RWS public
open import Haskell.Modules.RWS.Lens public
open import Haskell.Modules.RWS.RustAnyHow
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Interface.Output
open import Util.Prelude

----------------
-- LBFT Monad --
----------------

-- Global 'LBFT'; works over the whole state.
LBFT : Set → Set₁
LBFT = RWS Unit Output RoundManager

act : Output → LBFT Unit
act x = tell (x ∷ [])

LBFT-run : ∀ {A} → LBFT A → RoundManager → (A × RoundManager × List Output)
LBFT-run m = RWS-run m unit

LBFT-result : ∀ {A} → LBFT A → RoundManager → A
LBFT-result m rm = proj₁ (LBFT-run m rm)

LBFT-post : ∀ {A} → LBFT A → RoundManager → RoundManager
LBFT-post m rm = proj₁ (proj₂ (LBFT-run m rm))

LBFT-outs : ∀ {A} → LBFT A → RoundManager → List Output
LBFT-outs m rm = proj₂ (proj₂ (LBFT-run m rm))

LBFT-Pre  = RoundManager → Set
LBFT-Post = RWS-Post Output RoundManager

LBFT-Post-True : ∀ {A} → LBFT-Post A → LBFT A → RoundManager → Set
LBFT-Post-True Post m pre =
  let (x , post , outs) = LBFT-run m pre in
  Post x post outs

LBFT-weakestPre : ∀ {A} (m : LBFT A)
                  → LBFT-Post A → LBFT-Pre
LBFT-weakestPre m Post pre = RWS-weakestPre m Post unit pre

LBFT-Contract : ∀ {A} (m : LBFT A) → Set₁
LBFT-Contract{A} m =
  (Post : RWS-Post Output RoundManager A)
  → (pre : RoundManager) → LBFT-weakestPre m Post pre
  → LBFT-Post-True Post m pre

LBFT-contract : ∀ {A} (m : LBFT A) → LBFT-Contract m
LBFT-contract m Post pre pf = RWS-contract m Post unit pre pf

LBFT-⇒
  : ∀ {A} {P Q : LBFT-Post A}
  → ∀ m pre → LBFT-weakestPre m P pre
  → RWS-Post-⇒ P Q
  → LBFT-weakestPre m Q pre
LBFT-⇒ m pre pf f = RWS-⇒ m unit pre pf f

LBFT-⇒-bind
  : ∀ {A B} (P : LBFT-Post A) (Q : LBFT-Post B) (f : A → LBFT B)
  → (RWS-Post-⇒ P (RWS-weakestPre-bindPost unit f Q))
  → ∀ m st → LBFT-weakestPre m P st → LBFT-weakestPre (m >>= f) Q st
LBFT-⇒-bind Post Q f pf m st con = RWS-⇒-bind {P = Post} {Q} {f} m unit st con pf

LBFT-⇒-ebind
  : ∀ {A B C} {P : LBFT-Post (Either C A)} {Q : LBFT-Post (Either C B)}
  → {f : A → LBFT (Either C B)}
  → ∀ m st → LBFT-weakestPre m P st
  → RWS-Post-⇒ P (RWS-weakestPre-ebindPost unit f Q)
  → LBFT-weakestPre (m ∙?∙ f) Q st
LBFT-⇒-ebind {P = Post} {Q} {f} m st con pf =
  RWS-⇒-ebind m unit st con pf


module Compilation.Encode.Core where

open import Context
open import Type.Core
open import Compilation.Data

open import Function
open import Data.List.Base as List

{- Note [Compilation]
We compile data descriptions to System Fωμ in two steps:

1. Lambda-bind
     a) a tag to distinguish between the data types from the family
     b) a variable for each of the data types from the family
   then apply the tag to all of the data types after Scott-encoding them in order to be able to
   choose one particular data type from the family later. This way we get a valid System Fωμ type,
   but it's not a legal pattern functor yet, as it binds one tag and `n` variables responsible for
   recursion and we need to have only one variable responsible for recursion and one tag in order
   to be able to feed a type function to `μ` and actually tie the knot. Thus the next step is
2. Instantiate all the variables responsible for recursion using a single variable applied to
   distinct tags. This way we transform `1` (tag) + `n` (recursion) variables into
   `1` (recursion) + `1` (tag) variables, i.e. just two variables of right kinds, thus the result
   can be passed to `μ`.

We can now look at the `ProdTree`/`Tree` example.

After the first step (which is performed by the `encodeDataN` function, which calls `scottEncode`
internally) we get the following type (I'll save you from the De Bruijn reverse Turing test and
use the Agda notation instead, but note that this is still a System Fωμ type):

> prodTreeTreeReprN =
>   λ (tag : (Set -> Set -> Set) -> (Set -> Set) -> Set)
>       (prodTree : Set -> Set -> Set) (tree : Set -> Set) ->
>         ∀ (R : Set) ->                                     -- Binding the result variable.
>           tag                                              -- Choosing between the two data types.
>             (λ A B                                         -- The two types that `ProdTree` binds.
>                -> (tree (∀ Q -> (A -> B -> Q) -> Q) -> R)  -- Case over the `Prod` constructor.
>                -> R)
>             (λ A                                           -- The type that `Tree` binds.
>                -> (A -> R)                                 -- Case over the `Leaf` constructor.
>                -> (prodTree A A -> R)                      -- Case over the `Fork` constructor.
>                -> R)

Here we lambda-bind `prodTree` and `tree` directly, Scott-encode the definition of the data types
and use `tag` in order to choose between the two data types.

At the next step we instantiate `prodTree` and `tree` (`instantiations` computes the instantiations)
using a single `rec` (`packEncodedDataN` does this):

> prodTreeTreeRepr1 =
>   λ (rec : ((Set -> Set -> Set) -> (Set -> Set) -> Set) -> Set)
>       (tag : (Set -> Set -> Set) -> (Set -> Set) -> Set) ->
>         prodTreeTreeReptN
>           tag
>           (λ A B -> rec λ prodTree tree -> prodTree A B)
>           (λ A   -> rec λ prodTree tree -> tree A)

It only remains to take the fixed point of this pattern functor:

> prodTreeTree = λ tag -> μ prodTreeTreeRepr1 tag

And that's it, `prodTreeTree` is a valid System Fωμ type that encodes the `ProdTree`/`Tree` family.
-}

{- Note [Data description denotations]
Once we compile a data description to a System Fωμ type, we could already take the denotation of
the latter, but then we'd just get an Agda type that encodes the whole family of mutually recursive
data types, while what we really want is getting all the separate data types, not the whole family
at once.

Hence rather than take the denotation directly, we first instantiate the resulting System Fωμ type
using the tags that the data types from the family correspond to. I.e. we call `instantiations` once
again, get an environment of System Fωμ types and take denotations of those. The result then is an
environment of Agda types, each of which represents a data type from the original family of data
types. We only need to extract them from the environment. Unfortunately, Agda lacks top-level
matches, so we do it like this:

>  ProdTreeTree′ = Encoded.⟦ prodTreeTree ⟧ᵈ
>
>  ProdTree′ : Set -> Set -> Set
>  ProdTree′ with ProdTreeTree′
>  ... | ∅ ▷ PT′ ▷ T′ = PT′
>
>  Tree′ : Set -> Set
>  Tree′ with ProdTreeTree′
>  ... | ∅ ▷ PT′ ▷ T′ = T′
-}

-- | Get the kind of tags from the context of a data description.
--
-- > dataConToTagKind (ε ▻ (σ¹₁ ▻ … ▻ σ¹ₙ₁) ▻ … ▻ (σ¹ₘ ▻ … ▻ σᵐₙₘ)) τ =
-- >   (σ¹₁ ⇒ᵏ … ⇒ᵏ σ¹ₙ₁ ⇒ᵏ ⋆) ⇒ᵏ … ⇒ᵏ (σ¹₁ ⇒ᵏ … ⇒ᵏ σᵐₙₘ ⇒ᵏ ⋆) ⇒ᵏ τ
dataConToTagKind : Con Conᵏ -> Kind -> Kind
dataConToTagKind = conToKindBy $ λ Θ -> conToKind Θ ⋆

-- | Scott-encode a single data type. The type variable (denoted as `ρ`) that represents
-- the result is assumed to be in scope, because we Scott-encode a bunch of data types
-- at the same time and hence the resulting type variable has to be bound outside of all of them,
-- which is why we keep it implicit while encoding a single data type.
--
-- > scottEncode (ε ▻ α₁ ▻ … ▻ αₙ) [(β¹₁ ⇒ᶜ … ⇒ᶜ β¹ₙ₁ ⇒ᶜ endᶜ) , … , (βᵐ₁ ⇒ᶜ … ⇒ᶜ βᵐₙₘ ⇒ᶜ endᶜ)] =
-- >     λ α₁ … αₙ → (β¹₁ ⇒ … ⇒ β¹ₙ₁ ⇒ ρ) ⇒ … ⇒ (βᵐ₁ ⇒ … ⇒ βᵐₙₘ ⇒ ρ) ⇒ ρ
scottEncode : ∀ {Ξ} Θ -> List (Cons (Ξ ▻▻ Θ)) -> Ξ ▻ ⋆ ⊢ᵗ conToKind Θ ⋆
scottEncode Θ = Lamⁿ' Θ ∘ foldr (λ ξ γ -> consToType (renᶜ (keepⁿ Θ topᵒ) ξ) ρ ⇒ γ) ρ where
  ρ = renᵗ (extʳ Θ) $ Var vz

-- | Encode a `Data` description as an n-ary type function.
--
-- > encodeDataN (PackData [data¹ , … , dataᵐ]) =
-- >    λ tag δ¹ … δᵐ → tag (scott data¹) … (scott dataᵐ)
--
-- (`δᵢ` is the name of `dataᵢ` that is potentially used internally in any `dataⱼ`,
-- because the data types are allowed to be mutually recursive).
encodeDataN : ∀ {Ξ Θs} -> Data Ξ Θs -> Ξ ⊢ᵗ dataConToTagKind Θs ⋆ ⇒ᵏ dataConToTagKind Θs ⋆
encodeDataN {Ξ} {Θs} (PackData datas) =
  Lam_ ∘′ Lamⁿ Θs ∘′ π ⋆ $′
    applyᵗⁿ Θs
      (Var ∘ vsⁿ $ mapᶜ _ Θs ▻ ⋆)
      (mapˢ (λ {Θ} -> renᵗ (keepⁿ (mapᶜ _ Θs ▻ ⋆) topᵒ) ∘ scottEncode Θ) datas)

-- | Compute all instantiations of a thing of kind `dataConToTagKind Θs ⋆ ⇒ᵏ ⋆`, which is either
-- the first variable that a packed pattern functor binds (i.e. the one responsible for recursion)
-- or the final data type representing a family of mutually recursive data types.
-- "Instantiations" then are particular data types from a family of mutually recursive data types
-- (or represent them if we're are inside a pattern functor).
-- For example, the instantiations of `treeForest` are `tree` and `forest`, i.e. precisely those
-- data types that form the family.
--
-- > instantiations ψ
-- >     = ∅
-- >     ▷ (λ α¹₁ … α¹ₙ₁ → ψ λ β¹ … βᵐ → β¹ α¹₁ … α¹ₙ₁)
-- >     ▷ …
-- >     ▷ (λ αᵐ₁ … αᵐₙₘ → ψ λ β¹ … βᵐ → βᵐ αᵐ₁ … αᵐₙₘ)
instantiations : ∀ {Θs Ξ} -> Ξ ⊢ᵗ dataConToTagKind Θs ⋆ ⇒ᵏ ⋆ -> Seq (λ Θ -> Ξ ⊢ᵗ conToKind Θ ⋆) Θs
instantiations {ε}      ψ = ø
instantiations {Θs ▻ Θ} ψ
  = instantiations {Θs} (Lam_ $ shiftᵗ ψ ∙
      Lamⁿ (Θs ▻ Θ) (applyᵗⁿ Θs (Var (vsⁿ (mapᶜ _ (Θs ▻ Θ)))) (mapˢ shiftᵗ subVars)))
  ▶ Lamⁿ' Θ (shiftᵗⁿ Θ ψ ∙
      Lamⁿ (Θs ▻ Θ) (applyᵗⁿ Θ (Var vz) (mapˢ (shiftᵗⁿ (mapᶜ _ $ Θs ▻ Θ)) subVars')))

-- | Pack an encoded family of mutually recursive data types as an 1-ary pattern functor.
-- The encoded family is of this form (see `encodeDataN`):
--
-- > φ : ((σ¹₁ ⇒ᵏ … ⇒ᵏ σ¹ₙ₁ ⇒ᵏ ⋆) ⇒ᵏ … ⇒ᵏ (σᵐ₁ ⇒ᵏ … ⇒ᵏ σᵐₙₘ ⇒ᵏ ⋆) ⇒ᵏ ⋆)
-- >   ⇒ᵏ (σ¹₁ ⇒ᵏ … ⇒ᵏ σ¹ₙ₁ ⇒ᵏ ⋆) ⇒ᵏ … ⇒ᵏ (σᵐ₁ ⇒ᵏ … ⇒ᵏ σᵐₙₘ ⇒ᵏ ⋆) ⇒ᵏ ⋆
-- > φ = λ tag δ¹ … δᵐ → <body>
--
-- Where `tag` is a tag and `δʲ` is a variable that stands for a data type from the family.
--
-- The definition of `packEncodedDataN` then is
--
-- > packEncodedDataN _ φ =
-- >     λ rec tag → φ tag
-- >         (λ α¹₁ … α¹ₙ₁ → rec λ ψ¹ … ψᵐ → ψ¹ α¹₁ … α¹ₙ₁)
-- >         …
-- >         (λ αᵐ₁ … αᵐₙₘ → rec λ ψ¹ … ψᵐ → ψᵐ αᵐ₁ … αᵐₙₘ)
--
-- where `αʲᵢ` is a parameter of a data type and `λ ψ¹ … ψᵐ → ψʲ αʲ₁ … αʲᵢ` is the tag of
-- the data type. That is, we put parameters of data types into their corresponding tags.
--
-- So we instantiate each data type argument of `φ` as `rec` applied to an appropriate tag. This
-- way we represent all of the data types using just a single `rec` applied to different tags.
packEncodedDataN
  : ∀ {Ξ} Θs
  -> Ξ ⊢ᵗ dataConToTagKind Θs ⋆ ⇒ᵏ dataConToTagKind Θs ⋆
  -> Ξ ⊢ᵗ (dataConToTagKind Θs ⋆ ⇒ᵏ ⋆) ⇒ᵏ dataConToTagKind Θs ⋆ ⇒ᵏ ⋆
packEncodedDataN Θs φ =
  Lam_ ∘′ Lam_ ∘′ applyᵗⁿ Θs (shiftᵗⁿ (ε ▻ _ ▻ _) φ ∙ Var vz) ∘′ instantiations $ Var (vs vz)

-- | Encode a `Data` as a 1-ary pattern functor.
encodeData1
  : ∀ {Ξ Θs} -> Data Ξ Θs -> Ξ ⊢ᵗ (dataConToTagKind Θs ⋆ ⇒ᵏ ⋆) ⇒ᵏ dataConToTagKind Θs ⋆ ⇒ᵏ ⋆
encodeData1 {Θs = Θs} = packEncodedDataN Θs ∘ encodeDataN

-- | Compile a `Data` to System Fωμ.
compileData : ∀ {Ξ Θs} -> Data Ξ Θs -> Ξ ⊢ᵗ dataConToTagKind Θs ⋆ ⇒ᵏ ⋆
compileData d = Lam μ (shiftᵗ $ encodeData1 d) (Var vz)

compileDatas : ∀ {Ξ Θs} -> Data Ξ Θs -> Seq (λ Θ -> Ξ ⊢ᵗ conToKind Θ ⋆) Θs
compileDatas = instantiations ∘ compileData

-- | Return the denotations of all the data types from a family of mutually recursive data types
-- encoded as a `Data`.
⟦_⟧ᵈ : ∀ {Θs} -> Data ε Θs -> Seq (λ Θ -> ⟦ conToKind Θ ⋆ ⟧ᵏ) Θs
⟦_⟧ᵈ = mapˢ ⟦_⟧ᵗ ∘ compileDatas

module Unused where
  constructorTypes : ∀ {Θs Ξ} -> Data Ξ Θs -> Con (Star (Ξ ▻▻ mapᶜ (λ Θᵢ -> conToKind Θᵢ ⋆) Θs))
  constructorTypes {Θs} {Ξ} (PackData constructors) =
    joinᶜ ∘′ eraseˢ $′ mapElˢ consesToCon constructors where
      consesToCon
        : ∀ {Θ}
        -> Θ ∈ Θs
        -> List (Cons (Ξ ▻▻ mapᶜ (λ Θᵢ -> conToKind Θᵢ ⋆) Θs ▻▻ Θ))
        -> Con (Star (Ξ ▻▻ mapᶜ (λ Θᵢ -> conToKind Θᵢ ⋆) Θs))
      consesToCon {Θ} v = listToCon ∘ List.map (λ ξ -> πⁿ' Θ $ consToType ξ ρ) where
        ρ = applyᵗⁿ Θ (Var ∘ renᵛ (skipⁿ Θ extˡ) $ mapᵛ v) subVars'

  constructorFullTypes : ∀ {Θs Ξ} -> Data Ξ Θs -> Con (Star Ξ)
  constructorFullTypes δ = mapᶜ (instᵗⁿ $ compileDatas δ) $ constructorTypes δ


-- Andreas, 2015-09-18, issue reported by Guillaume Brunerie

{-# OPTIONS --rewriting #-}

data _==_ {A : Set} (a : A) : A → Set where
  idp : a == a
{-# BUILTIN REWRITE _==_ #-}

postulate
  A : Set
  a b : A

r : a == b
{-# REWRITE r #-}
r = idp

-- Should not work, as this behavior is confusing the users.
-- Instead, should give an error that rewrite rule
-- can only be added after function body.


-- Andreas, 2019-01-20, re #2597.
-- Undocumented language change introduced by patch 31a5982f38 (released in 2.5.3):
-- Hiding of argument now treated as part of name when inserting implicits.

-- Patch introduced in src/full/Agda/TypeChecking/Implicit.hs
--
-- ... | x == y && sameHiding hidingx a = impInsert $ reverse hs
--     | x == y && sameHiding hidingx a = BadImplicits
--
-- Intended was most likely
--     | x == y && not (sameHiding hidingx a) = BadImplicits
--
-- The patch makes this code legal:

test : {{X : Set}} {X : Set} → Set
test {X = X} = X

-- Succeeds in 2.5.3.
-- Fails in 2.5.2 with error:
-- Unexpected implicit argument
-- when checking that the clause test {X = X} = X has type
-- {{X : Set}} {X = X₁ : Set} → Set


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Expressions(x : X) where
  import OutsideIn.TypeSchema as TS
  open TS(x)
  open X(x)

  {- SYNTAX -}
  data Name (n : Set) : NameType → Set where
    N : n → Name n Regular
    DC : ∀ {x} → dc x → Name n (Datacon x)

  mutual
    data Alternative (ev tv : Set) : Shape → Set where
      _→′_ : ∀ {n : ℕ}{r : Shape}→ Name ev (Datacon n) → Expression (ev ⨁ n) tv r
           → Alternative ev tv (Unary r)

    infixr 5 _∣_

    data Alternatives (ev tv : Set) : Shape → Set where
      esac : Alternatives ev tv Nullary
      _∣_  : ∀ {r₁ r₂} → Alternative ev tv r₁ → Alternatives ev tv r₂
           → Alternatives ev tv (Binary r₁ r₂)

    data Expression (ev tv : Set) : Shape → Set where
      Var : ∀ {x} → Name ev x → Expression ev tv Nullary
      λ′_ : ∀ {a} → Expression (Ⓢ ev) tv a → Expression ev tv (Unary a)
      _·_ : ∀ {a a′} → Expression ev tv a → Expression ev tv a′ → Expression ev tv (Binary a a′)
      let₁_in′_ : ∀ {a a′} → Expression ev tv a → Expression (Ⓢ ev) tv a′
                → Expression ev tv (Binary a a′)
      let₂_∷_in′_ : ∀ {a a′} → Expression ev tv a → Type tv → Expression (Ⓢ ev) tv a′
                  → Expression ev tv (Binary a a′)
      let₃_·_∷_⇒_in′_ : ∀ {a a′} → (n : ℕ) → Expression ev (tv ⨁ n) a
                                  → QConstraint (tv ⨁ n)
                                  → Type (tv ⨁ n)
                                  → Expression (Ⓢ ev) tv a′
                                  → Expression ev tv (Binary a a′)
      case_of_ : ∀ {r₁ r₂} → Expression ev tv r₁ → Alternatives ev tv r₂
               → Expression ev tv (Binary r₁ r₂)

  private
    module PlusN-f n        = Functor (Monad.is-functor (PlusN-is-monad {n}))
    module Ⓢ-f             = Functor Ⓢ-is-functor
    module Type-f           = Functor (type-is-functor)
    module TypeSchema-f {n} = Functor (type-schema-is-functor {n})
    module QC-f             = Functor (qconstraint-is-functor)

  private
    fmap-alt₁ : ∀ {a b tv}{r} → (a → b) → Alternative a tv r → Alternative b tv r
    fmap-exp₁ : ∀ {a b tv}{r} → (a → b) → Expression a tv r → Expression b tv r
    map-fmap-alt₁ : ∀ {a b tv}{r} → (a → b) → Alternatives a tv r → Alternatives b tv r
    fmap-alt₁ f (_→′_ {n} (DC c) expr) = DC c →′ fmap-exp₁ (pn.map f) expr
       where module pn = PlusN-f n
    fmap-exp₁ f (Var (DC c)) = Var (DC c)
    fmap-exp₁ f (Var (N x)) = Var (N (f x))
    fmap-exp₁ f (λ′ x) = λ′ (fmap-exp₁ (Ⓢ-f.map f) x)
    fmap-exp₁ f (x · y) = (fmap-exp₁ f x) · (fmap-exp₁ f y)
    fmap-exp₁ f (let₁ x in′ y) = let₁ (fmap-exp₁ f x) in′ (fmap-exp₁ (Ⓢ-f.map f) y)
    fmap-exp₁ f (let₂ x ∷ τ in′ y) = let₂ (fmap-exp₁ f x) ∷ τ in′ (fmap-exp₁ (Ⓢ-f.map f) y)
    fmap-exp₁ f (let₃ n · x ∷ Q ⇒ τ in′ y) = let₃  n · fmap-exp₁ f x ∷ Q ⇒ τ
                                              in′ fmap-exp₁ (Ⓢ-f.map f) y
    fmap-exp₁ f (case x of alts) = case (fmap-exp₁ f x) of map-fmap-alt₁ f alts
    map-fmap-alt₁ f esac = esac
    map-fmap-alt₁ f (x ∣ xs) = fmap-alt₁ f x ∣ map-fmap-alt₁ f xs

  private
    fmap-alt₂ : ∀ {a b ev}{r} → (a → b) → Alternative ev a r → Alternative ev b r
    fmap-exp₂ : ∀ {a b ev}{r} → (a → b) → Expression ev a r → Expression ev b r
    map-fmap-alt₂ : ∀ {a b ev}{r} → (a → b) → Alternatives ev a r → Alternatives ev b r
    fmap-alt₂ f (p →′ expr) = p →′ fmap-exp₂ f expr
    fmap-exp₂ f (Var x) = Var x
    fmap-exp₂ f (λ′ x) = λ′ (fmap-exp₂ f x)
    fmap-exp₂ f (x · y) = fmap-exp₂ f x · fmap-exp₂ f y
    fmap-exp₂ f (let₁ x in′ y) = let₁ fmap-exp₂ f x in′ fmap-exp₂ f y
    fmap-exp₂ f (let₂ x ∷ τ in′ y) = let₂ fmap-exp₂ f x ∷ Type-f.map f τ in′ fmap-exp₂ f y
    fmap-exp₂ f (let₃ n · x ∷ Q ⇒ τ in′ y) = let₃ n · fmap-exp₂ (pn.map f) x
                                                ∷ QC-f.map (pn.map f) Q ⇒ Type-f.map (pn.map f) τ
                                               in′ fmap-exp₂ f y
      where module pn = PlusN-f n
    fmap-exp₂ f (case x of alts) = case (fmap-exp₂ f x) of map-fmap-alt₂ f alts
    map-fmap-alt₂ f esac = esac
    map-fmap-alt₂ f (x ∣ xs) = fmap-alt₂ f x ∣ map-fmap-alt₂ f xs

  private
    fmap-alt-id₁ : {A tv : Set} {f : A → A}{r : Shape}
                 → isIdentity f → isIdentity (fmap-alt₁ {A}{A}{tv}{r} f)
    map-fmap-alt-id₁ : ∀ {a}{tv}{f : a → a}{r : Shape}
                     → isIdentity f → isIdentity (map-fmap-alt₁  {a}{a}{tv}{r} f)
    fmap-exp-id₁ : ∀{A tv : Set}{r : Shape} {f : A → A} → isIdentity f
                 → isIdentity (fmap-exp₁ {A}{A}{tv}{r} f)
    fmap-alt-id₁ {A}{f} f-is-id {_→′_ {n} (DC p) x} = cong (_→′_ (DC p)) (fmap-exp-id₁ (pn.identity f-is-id))
      where module pn = PlusN-f n
    map-fmap-alt-id₁ {r = Unary _} f-is-id {}
    map-fmap-alt-id₁ {r = Nullary} f-is-id {esac} = refl
    map-fmap-alt-id₁ {r = Binary r₁ r₂} f-is-id {x ∣ xs} = cong₂ _∣_ (fmap-alt-id₁ f-is-id)
                                                                     (map-fmap-alt-id₁ f-is-id)
    fmap-exp-id₁ {r = Nullary} f-is-id {Var (DC x)} = refl
    fmap-exp-id₁ {r = Nullary} f-is-id {Var (N x)} = cong Var (cong N f-is-id)
    fmap-exp-id₁ {r = Unary r′} f-is-id {λ′ x} = cong λ′_ (fmap-exp-id₁ (Ⓢ-f.identity f-is-id))
    fmap-exp-id₁ {r = Binary r₁ r₂} f-is-id {x · y} = cong₂ _·_ (fmap-exp-id₁ f-is-id)
                                                                (fmap-exp-id₁ f-is-id)
    fmap-exp-id₁ {r = Binary r₁ r₂} f-is-id {let₁ x in′ y}
      = cong₂ let₁_in′_ (fmap-exp-id₁ f-is-id) (fmap-exp-id₁ (Ⓢ-f.identity f-is-id))
    fmap-exp-id₁ {r = Binary r₁ r₂} f-is-id {let₂ x ∷ τ in′ y}
      = cong₂ (λ a b → let₂ a ∷ τ in′ b) (fmap-exp-id₁ f-is-id)
                                         (fmap-exp-id₁ (Ⓢ-f.identity f-is-id))
    fmap-exp-id₁ {r = Binary r₁ r₂} f-is-id {let₃ n · x ∷ Q ⇒ τ in′ y}
      = cong₂ (λ a b → let₃ n · a ∷ Q ⇒ τ in′ b) (fmap-exp-id₁ f-is-id)
                                                 (fmap-exp-id₁ (Ⓢ-f.identity f-is-id))
    fmap-exp-id₁ {r = Binary r₁ r₂} f-is-id {case x of alts}
      = cong₂ case_of_ (fmap-exp-id₁ f-is-id) (map-fmap-alt-id₁ f-is-id)

  private
    fmap-alt-id₂ : {A ev : Set}{r : Shape}{f : A → A}
                 → isIdentity f → isIdentity (fmap-alt₂ {A}{A}{ev}{r} f)
    map-fmap-alt-id₂ : ∀ {a}{ev}{r : Shape}{f : a → a}
                     → isIdentity f → isIdentity (map-fmap-alt₂  {a}{a}{ev}{r} f)
    fmap-exp-id₂ : ∀{A ev : Set}{r : Shape} {f : A → A}
                 → isIdentity f → isIdentity (fmap-exp₂ {A}{A}{ev}{r} f)
    fmap-alt-id₂ f-is-id {_→′_ {n} p x} = cong (_→′_ p) (fmap-exp-id₂ f-is-id)
    map-fmap-alt-id₂ f-is-id {esac} = refl
    map-fmap-alt-id₂ f-is-id {x ∣ xs} = cong₂ _∣_ (fmap-alt-id₂ f-is-id) (map-fmap-alt-id₂ f-is-id)
    fmap-exp-id₂ {r = Nullary}      f-is-id {Var x} = refl
    fmap-exp-id₂ {r = Unary r′}     f-is-id {λ′ x} = cong λ′_ (fmap-exp-id₂ f-is-id)
    fmap-exp-id₂ {r = Binary r₁ r₂} f-is-id {x · y} = cong₂ _·_ (fmap-exp-id₂ f-is-id)
                                                                (fmap-exp-id₂ f-is-id)
    fmap-exp-id₂ {r = Binary r₁ r₂} f-is-id {let₁ x in′ y} = cong₂ let₁_in′_ (fmap-exp-id₂ f-is-id)
                                                                             (fmap-exp-id₂ f-is-id)
    fmap-exp-id₂ {r = Binary r₁ r₂} f-is-id {let₂ x ∷ τ in′ y} = cong₃ let₂_∷_in′_
                                                                       (fmap-exp-id₂ f-is-id)
                                                                       (Type-f.identity f-is-id)
                                                                       (fmap-exp-id₂ f-is-id)
    fmap-exp-id₂ {r = Binary r₁ r₂} f-is-id {let₃ n · x ∷ Q ⇒ τ in′ y}
      = cong₄ (let₃_·_∷_⇒_in′_ n) (fmap-exp-id₂ (pn.identity f-is-id))
                                  (QC-f.identity (pn.identity f-is-id))
                                  (Type-f.identity (pn.identity f-is-id))
                                  (fmap-exp-id₂ f-is-id)
      where module pn = PlusN-f n
    fmap-exp-id₂ {r = Binary r₁ r₂} f-is-id {case x of alts}
      = cong₂ case_of_ (fmap-exp-id₂ f-is-id) (map-fmap-alt-id₂ f-is-id)

  private
    fmap-alt-comp₁ : {r : Shape} {A B C tv : Set} {f : A → B}{g : B → C} {x : Alternative A tv r}
                   → fmap-alt₁ (g ∘ f) x ≡ fmap-alt₁ g (fmap-alt₁ f x)
    fmap-exp-comp₁ : {r : Shape}{tv A B C : Set} {f : A → B} {g : B → C} {x : Expression A tv r}
                   → fmap-exp₁ (g ∘ f) x ≡ fmap-exp₁ g (fmap-exp₁ f x)
    map-fmap-alt-comp₁ : {r : Shape}{A B C tv : Set}{f : A → B}{g : B → C}{l : Alternatives A tv r}
                       → map-fmap-alt₁ (g ∘ f) l ≡ map-fmap-alt₁ g (map-fmap-alt₁ f l)
    fmap-alt-comp₁ {Nullary}   {x = ()}
    fmap-alt-comp₁ {Binary _ _}{x = ()}
    fmap-alt-comp₁ {Unary r}{f = f}{g}{x = _→′_ {n} (DC p) expr}
      = cong (_→′_ (DC p))
             (combine-composite′ ⦃ Monad.is-functor (PlusN-is-monad {n}) ⦄ {expr}
                                 fmap-exp₁
                                 (fmap-exp-comp₁ {f = pn.map f}{g = pn.map g}{expr}))
      where module pn = PlusN-f n
    map-fmap-alt-comp₁ {l = esac} = refl
    map-fmap-alt-comp₁ {Binary a b}{A}{B}{C}{tv}{l = x ∣ xs} = cong₂ _∣_ (fmap-alt-comp₁ {x = x}) (map-fmap-alt-comp₁)

    fmap-exp-comp₁ {x = Var (N x)} = cong Var (cong N (refl))
    fmap-exp-comp₁ {x = Var (DC x)} = refl
    fmap-exp-comp₁ {f = f}{g}{x = λ′ x }
      = cong λ′_ (combine-composite′ ⦃ Monad.is-functor (Ⓢ-is-monad) ⦄ {x}
                                     fmap-exp₁
                                     (fmap-exp-comp₁ {f = Ⓢ-f.map f}{g = Ⓢ-f.map g}{x}))
    fmap-exp-comp₁ {f = f}{g}{x = x · y } = cong₂ _·_ (fmap-exp-comp₁ {f = f}{g}{x})
                                                      (fmap-exp-comp₁ {f = f}{g}{y})
    fmap-exp-comp₁ {f = f}{g}{x = let₁ x in′ y }
      = cong₂ let₁_in′_ (fmap-exp-comp₁ {f = f}{g}{x})
                        (combine-composite′ ⦃ Monad.is-functor (Ⓢ-is-monad) ⦄ {y}
                                     fmap-exp₁
                                     (fmap-exp-comp₁ {f = Ⓢ-f.map f}{g = Ⓢ-f.map g}{y}))
    fmap-exp-comp₁ {f = f}{g}{x = let₂ x ∷ τ in′ y}
      = cong₂ (λ a b → let₂ a ∷ τ in′ b) (fmap-exp-comp₁ {f = f}{g}{x})
                                         (combine-composite′ ⦃ Monad.is-functor (Ⓢ-is-monad) ⦄ {y}
                                                             fmap-exp₁
                                                             (fmap-exp-comp₁ {f = Ⓢ-f.map f}
                                                                             {g = Ⓢ-f.map g}{y}))
    fmap-exp-comp₁ {f = f}{g}{x = let₃ n · x ∷ Q ⇒ τ in′ y}
      = cong₂ (λ a b → let₃ n · a ∷ Q ⇒ τ in′ b)
              (fmap-exp-comp₁ {f = f}{g}{x})
              (combine-composite′ ⦃ Monad.is-functor (Ⓢ-is-monad) ⦄ {y}
                                  fmap-exp₁
                                  (fmap-exp-comp₁ {f = Ⓢ-f.map f}{g = Ⓢ-f.map g}{y}))
    fmap-exp-comp₁ {f = f}{g}{x = case x of alts } = cong₂ case_of_
                                                           (fmap-exp-comp₁ {f = f}{g}{x})
                                                           map-fmap-alt-comp₁

  private
    fmap-alt-comp₂ : {A B C ev : Set}{r : Shape} {f : A → B} {g : B → C} {x : Alternative ev A r}
                   → fmap-alt₂ (g ∘ f) x ≡ fmap-alt₂ g (fmap-alt₂ f x)
    fmap-exp-comp₂ : {A B C ev : Set}{r : Shape} {f : A → B} {g : B → C} {x : Expression ev A r}
                   → fmap-exp₂ (g ∘ f) x ≡ fmap-exp₂ g (fmap-exp₂ f x)
    map-fmap-alt-comp₂ : ∀{r}{A B C ev : Set} {f : A → B} {g : B → C} {alts : Alternatives ev A r}
                       → map-fmap-alt₂ (g ∘ f) alts ≡ map-fmap-alt₂ g (map-fmap-alt₂ f alts)
    fmap-alt-comp₂ {x = _→′_ {n} p expr} = cong (_→′_ p) fmap-exp-comp₂
    map-fmap-alt-comp₂ {alts = esac} = refl
    map-fmap-alt-comp₂ {alts = x ∣ xs} = cong₂ _∣_ fmap-alt-comp₂ map-fmap-alt-comp₂

    fmap-exp-comp₂ {x = Var a} = refl
    fmap-exp-comp₂ {x = λ′ x } = cong λ′_ fmap-exp-comp₂
    fmap-exp-comp₂ {x = x · y } = cong₂ _·_ fmap-exp-comp₂ fmap-exp-comp₂
    fmap-exp-comp₂ {x = let₁ x in′ y } = cong₂ let₁_in′_ fmap-exp-comp₂ fmap-exp-comp₂
    fmap-exp-comp₂ {x = let₂ x ∷ τ in′ y } = cong₃ let₂_∷_in′_ fmap-exp-comp₂ Type-f.composite fmap-exp-comp₂
    fmap-exp-comp₂ {x = let₃ n · x ∷ Q ⇒ τ in′ y }
      = cong₄ (λ a b c d → let₃ n · a ∷ b ⇒ c in′ d)
              (combine-composite′ ⦃ pnf ⦄ fmap-exp₂ fmap-exp-comp₂)
              (combine-composite ⦃ qconstraint-is-functor ⦄ ⦃ pnf ⦄)
              (combine-composite ⦃ type-is-functor        ⦄ ⦃ pnf ⦄)
              fmap-exp-comp₂
      where pnf = Monad.is-functor (PlusN-is-monad {n})
    fmap-exp-comp₂ {x = case x of alts } = cong₂ case_of_ fmap-exp-comp₂ map-fmap-alt-comp₂

  alternatives-is-functor₁ : ∀{tv}{r} → Functor (λ x → Alternatives x tv r)
  alternatives-is-functor₁ = record { map = map-fmap-alt₁
                                    ; identity = map-fmap-alt-id₁
                                    ; composite = map-fmap-alt-comp₁
                                    }
  alternatives-is-functor₂ : ∀{ev}{r} → Functor (λ x → Alternatives ev x r)
  alternatives-is-functor₂ = record { map = map-fmap-alt₂
                                    ; identity = map-fmap-alt-id₂
                                    ; composite = map-fmap-alt-comp₂
                                    }
  alternative-is-functor₁ : ∀{tv}{r} → Functor (λ x → Alternative x tv r)
  alternative-is-functor₁ = record { map = fmap-alt₁
                                   ; identity = fmap-alt-id₁
                                   ; composite = λ { {x = x} → fmap-alt-comp₁ {x = x} }
                                   }
  alternative-is-functor₂ : ∀{ev}{r} → Functor (λ x → Alternative ev x r)
  alternative-is-functor₂ = record { map = fmap-alt₂
                                   ; identity = fmap-alt-id₂
                                   ; composite = fmap-alt-comp₂
                                   }
  expression-is-functor₁ : ∀{tv}{r} → Functor (λ x → Expression x tv r)
  expression-is-functor₁ {tv}{r} = record { map = fmap-exp₁
                                          ; identity = fmap-exp-id₁
                                          ; composite = λ {A}{B}{C}{f}{g}{x}
                                                        → fmap-exp-comp₁ {r}{tv}{A}{B}{C}{f}{g}{x}
                                          }
  expression-is-functor₂ : ∀{ev}{r} → Functor (λ x → Expression ev x r)
  expression-is-functor₂ = record { map = fmap-exp₂
                                  ; identity = fmap-exp-id₂
                                  ; composite = fmap-exp-comp₂
                                  }


open import Prelude

module Implicits.Semantics.Context where

open import Implicits.Syntax
open import Implicits.Semantics.Type
open import SystemF.Everything as F using ()

open import Data.Vec

⟦_⟧ctx→ : ∀ {ν n} → Ctx ν n → F.Ctx ν n
⟦ Γ ⟧ctx→ = map ⟦_⟧tp→ Γ


module Imports.ImportedDisplayForms where

open import Agda.Builtin.Nat

postulate
  _plus_ : Set

{-# DISPLAY _+_ a b = a plus b #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pretty Printing
-- This module is based on Jean-Philippe Bernardy's functional pearl
-- "A Pretty But Not Greedy Printer"
------------------------------------------------------------------------

{-# OPTIONS --with-K #-}

module Text.Pretty.Core where

import Level

open import Data.Bool.Base using (Bool)
open import Data.Erased    as Erased using (Erased) hiding (module Erased)
open import Data.List.Base as List   using (List; []; _∷_)
open import Data.Nat.Base            using (ℕ; zero; suc; _+_; _⊔_; _≤_; z≤n)
open import Data.Nat.Properties
open import Data.Product as Prod using (_×_; _,_; uncurry; proj₁; proj₂)
import Data.Product.Relation.Unary.All as Allᴾ

open import Data.Tree.Binary as Tree using (Tree; leaf; node)
open import Data.Tree.Binary.Relation.Unary.All as Allᵀ using (leaf; node)
import Data.Tree.Binary.Relation.Unary.All.Properties as Allᵀₚ
import Data.Tree.Binary.Properties as Treeₚ

open import Data.Maybe.Base as Maybe using (Maybe; nothing; just; maybe′)
open import Data.Maybe.Relation.Unary.All as Allᴹ using (nothing; just)

open import Data.String.Base as String
open import Data.String.Unsafe as Stringₚ
open import Function.Base
open import Relation.Nullary using (Dec)
open import Relation.Unary using (IUniversal; _⇒_)
open import Relation.Binary.PropositionalEquality

open import Data.Refinement hiding (map)
import Data.Refinement.Relation.Unary.All as Allᴿ

------------------------------------------------------------------------
-- Block of text

-- Content is a representation of the first line and the middle of the block.
-- We use a tree rather than a list for the middle of the block so that we can
-- extend it with lines on the left and on the line for free. We will ultimately
-- render the block by traversing the tree left to right in a depth-first manner.

Content : Set
Content = Maybe (String × Tree String)

size : Content → ℕ
size = maybe′ (suc ∘ Tree.size ∘ proj₂) 0

All : ∀ {p} (P : String → Set p) → (Content → Set p)
All P = Allᴹ.All (Allᴾ.All P (Allᵀ.All P))

All≤ : ℕ → Content → Set
All≤ n = All (λ s → length s ≤ n)

record Block : Set where
  field
    height    : ℕ
    block     : [ xs ∈ Content ∣ size xs ≡ height ]
  -- last line
    lastWidth : ℕ
    last      : [ s ∈ String ∣ length s ≡ lastWidth ]
  -- max of all the widths
    maxWidth  : [ n ∈ ℕ ∣ lastWidth ≤ n × All≤ n (block .value) ]

------------------------------------------------------------------------
-- Raw string

text : String → Block
text s = record
  { height    = 0
  ; block     = nothing , ⦇ refl ⦈
  ; lastWidth = width
  ; last      = s , ⦇ refl ⦈
  ; maxWidth  = width , ⦇ (≤-refl , nothing) ⦈
  } where width = length s; open Erased

------------------------------------------------------------------------
-- Empty

empty : Block
empty = text ""

------------------------------------------------------------------------
-- Helper functions

node? : Content → String → Tree String → Content
node? (just (x , xs)) y ys = just (x , node xs y ys)
node? nothing         y ys = just (y , ys)

∣node?∣ : ∀ b y ys → size (node? b y ys)
                   ≡ size b + suc (Tree.size ys)
∣node?∣ (just (x , xs)) y ys = refl
∣node?∣ nothing         y ys = refl

≤-Content : ∀ {m n} {b : Content} → m ≤ n → All≤ m b → All≤ n b
≤-Content {m} {n} m≤n = Allᴹ.map (Prod.map step (Allᵀ.map step))

  where

  step : ∀ {p} → p ≤ m → p ≤ n
  step = flip ≤-trans m≤n

All≤-node? : ∀ {l m r n} →
             All≤ n l → length m ≤ n → Allᵀ.All (λ s → length s ≤ n) r →
             All≤ n (node? l m r)
All≤-node? nothing           py pys = just (py , pys)
All≤-node? (just (px , pxs)) py pys = just (px , node pxs py pys)

------------------------------------------------------------------------
-- Appending two documents

private
  module append (x y : Block) where

    module x = Block x
    module y = Block y

    blockx = x.block .value
    blocky = y.block .value

    widthx = x.maxWidth .value
    widthy = y.maxWidth .value

    lastx = x.last .value
    lasty = y.last .value

    height : ℕ
    height = (_+_ on Block.height) x y

    lastWidth : ℕ
    lastWidth = (_+_ on Block.lastWidth) x y

    pad : Maybe String
    pad with x.lastWidth
    ... | 0 = nothing
    ... | l = just (replicate l ' ')

    size-pad : maybe′ length 0 pad ≡ x.lastWidth
    size-pad with x.lastWidth
    ... | 0         = refl
    ... | l@(suc _) = length-replicate l

    indent : Maybe String → String → String
    indent = maybe′ _++_ id

    size-indent : ∀ ma str → length (indent ma str)
                ≡ maybe′ length 0 ma + length str
    size-indent nothing    str = refl
    size-indent (just pad) str = length-++ pad str

    indents : Maybe String → Tree String → Tree String
    indents = maybe′ (Tree.map ∘ _++_) id

    size-indents : ∀ ma t → Tree.size (indents ma t) ≡ Tree.size t
    size-indents nothing    t = refl
    size-indents (just pad) t = Treeₚ.size-map (pad ++_) t

    unfold-indents : ∀ ma t → indents ma t ≡ Tree.map (indent ma) t
    unfold-indents nothing    t = sym (Treeₚ.map-id t)
    unfold-indents (just pad) t = refl

    vContent : Content × String
    vContent with blocky
    ... | nothing        = blockx
                         , lastx ++ lasty
    ... | just (hd , tl) = node?
      {-,--------------,-}
      {-|-} blockx   {-|-}
      {-|-}          {-'---,-}    {-,------------------,-}
      {-|-} (lastx       {-|-} ++ {-|-}  hd)         {-|-}
      {-'------------------'-}    {-|-}              {-|-}
      (indents pad                {-|-}  tl)    {-,----'-}
      , indent pad                {-|-} lasty   {-|-}
                                  {-'-------------'-}

    vBlock = proj₁ vContent
    vLast  = proj₂ vContent

    isBlock : size blockx ≡ x.height → size blocky ≡ y.height →
              size vBlock ≡ height
    isBlock ∣x∣ ∣y∣ with blocky
    ... | nothing        = begin
      size blockx         ≡⟨ ∣x∣ ⟩
      x.height            ≡˘⟨ +-identityʳ x.height ⟩
      x.height + 0        ≡⟨ cong (_ +_) ∣y∣ ⟩
      x.height + y.height ∎ where open ≡-Reasoning
    ... | just (hd , tl) = begin
      ∣node∣                          ≡⟨ ∣node?∣ blockx middle rest ⟩
      ∣blockx∣ + suc (Tree.size rest) ≡⟨ cong ((size blockx +_) ∘′ suc) ∣rest∣ ⟩
      ∣blockx∣ + suc (Tree.size tl)   ≡⟨ cong₂ _+_ ∣x∣ ∣y∣ ⟩
      x.height + y.height             ∎ where

      open ≡-Reasoning
      ∣blockx∣ = size blockx
      middle   = lastx ++ hd
      rest     = indents pad tl
      ∣rest∣   = size-indents pad tl
      ∣node∣   = size (node? blockx middle rest)

    block : [ xs ∈ Content ∣ size xs ≡ height ]
    block .value = vBlock
    block .proof = ⦇ isBlock (Block.block x .proof) (Block.block y .proof) ⦈
      where open Erased

    isLastLine : length lastx ≡ x.lastWidth →
                 length lasty ≡ y.lastWidth →
                 length vLast ≡ lastWidth
    isLastLine ∣x∣ ∣y∣ with blocky
    ... | nothing        = begin
      length (lastx ++ lasty)       ≡⟨ length-++ lastx lasty ⟩
      length lastx + length lasty   ≡⟨ cong₂ _+_ ∣x∣ ∣y∣ ⟩
      x.lastWidth + y.lastWidth     ∎ where open ≡-Reasoning
    ... | just (hd , tl) = begin
      length (indent pad lasty)          ≡⟨ size-indent pad lasty ⟩
      maybe′ length 0 pad + length lasty ≡⟨ cong₂ _+_ size-pad ∣y∣ ⟩
      x.lastWidth + y.lastWidth          ∎ where open ≡-Reasoning

    last : [ s ∈ String ∣ length s ≡ lastWidth ]
    last .value = vLast
    last .proof = ⦇ isLastLine (Block.last x .proof) (Block.last y .proof) ⦈
      where open Erased

    vMaxWidth : ℕ
    vMaxWidth = widthx ⊔ (x.lastWidth + widthy)

    isMaxWidth₁ : y.lastWidth ≤ widthy → lastWidth ≤ vMaxWidth
    isMaxWidth₁ p = begin
      lastWidth            ≤⟨ +-monoʳ-≤ x.lastWidth p ⟩
      x.lastWidth + widthy ≤⟨ n≤m⊔n _ _ ⟩
      vMaxWidth            ∎ where open ≤-Reasoning

    isMaxWidth₂ : length lastx ≡ x.lastWidth →
                  x.lastWidth ≤ widthx →
                  All≤ widthx blockx →
                  All≤ widthy blocky →
                  All≤ vMaxWidth vBlock
    isMaxWidth₂ ∣x∣≡ ∣x∣≤ ∣xs∣ ∣ys∣ with blocky
    ... | nothing        = ≤-Content (m≤m⊔n _ _) ∣xs∣
    isMaxWidth₂ ∣x∣≡ ∣x∣≤ ∣xs∣ (just (∣hd∣ , ∣tl∣))
        | just (hd , tl) =
      All≤-node? (≤-Content (m≤m⊔n _ _) ∣xs∣)
                 middle
                 (subst (Allᵀ.All _) (sym $ unfold-indents pad tl)
                 $ Allᵀₚ.map⁺ (indent pad) (Allᵀ.map (indented _) ∣tl∣))
      where

      middle : length (lastx ++ hd) ≤ vMaxWidth
      middle = begin
        length (lastx ++ hd)     ≡⟨ length-++ lastx hd ⟩
        length lastx + length hd ≡⟨ cong (_+ _) ∣x∣≡ ⟩
        x.lastWidth + length hd  ≤⟨ +-monoʳ-≤ x.lastWidth ∣hd∣ ⟩
        x.lastWidth + widthy     ≤⟨ n≤m⊔n _ _ ⟩
        vMaxWidth                ∎ where open ≤-Reasoning

      indented : ∀ s → length s ≤ widthy →
                 length (indent pad s) ≤ vMaxWidth
      indented s ∣s∣ = begin
        length (indent pad s)          ≡⟨ size-indent pad s ⟩
        maybe′ length 0 pad + length s ≡⟨ cong (_+ _) size-pad ⟩
        x.lastWidth + length s         ≤⟨ +-monoʳ-≤ x.lastWidth ∣s∣ ⟩
        x.lastWidth + widthy           ≤⟨ n≤m⊔n (widthx) _ ⟩
        vMaxWidth                      ∎ where open ≤-Reasoning

    maxWidth : [ n ∈ ℕ ∣ lastWidth ≤ n × All≤ n vBlock ]
    maxWidth .value = vMaxWidth
    maxWidth .proof =
      ⦇ _,_ ⦇ isMaxWidth₁ (map proj₁ (Block.maxWidth y .proof)) ⦈
            ⦇ isMaxWidth₂ (Block.last x .proof)
                          (map proj₁ (Block.maxWidth x .proof))
                          (map proj₂ (Block.maxWidth x .proof))
                          (map proj₂ (Block.maxWidth y .proof))
            ⦈
      ⦈ where open Erased

infixl 4 _<>_
_<>_ : Block → Block → Block
x <> y = record { append x y }

------------------------------------------------------------------------
-- Flush (introduces a new line)

private
  module flush (x : Block) where

    module x = Block x
    blockx  = x.block .value
    lastx   = x.last .value
    widthx  = x.maxWidth .value
    heightx = x.height

    height    = suc heightx
    lastWidth = 0
    vMaxWidth = widthx

    last : [ s ∈ String ∣ length s ≡ lastWidth ]
    last = "" , ⦇ refl ⦈ where open Erased

    vContent = node? blockx lastx leaf

    isBlock : size blockx ≡ heightx → size vContent ≡  height
    isBlock ∣x∣ = begin
      size vContent   ≡⟨ ∣node?∣ blockx lastx leaf ⟩
      size blockx + 1 ≡⟨ cong (_+ 1) ∣x∣ ⟩
      heightx + 1     ≡⟨ +-comm heightx 1 ⟩
      height          ∎ where open ≡-Reasoning

    block : [ xs ∈ Content ∣ size xs ≡ height ]
    block .value = vContent
    block .proof = Erased.map isBlock $ Block.block x .proof

    maxWidth : [ n ∈ ℕ ∣ lastWidth ≤ n × All≤ n vContent ]
    maxWidth .value = widthx
    maxWidth .proof = map (z≤n ,_)
      ⦇ All≤-node? ⦇ proj₂ (Block.maxWidth x .proof) ⦈
                   ⦇ middle (Block.last x .proof) ⦇ proj₁ (Block.maxWidth x .proof) ⦈ ⦈
                   (pure leaf)
      ⦈ where

      open Erased

      middle : length lastx ≡ x.lastWidth → x.lastWidth ≤ vMaxWidth →
               length lastx ≤ vMaxWidth
      middle p q = begin
        length lastx ≡⟨ p ⟩
        x.lastWidth  ≤⟨ q ⟩
        vMaxWidth    ∎ where open ≤-Reasoning

flush : Block → Block
flush x = record { flush x }

------------------------------------------------------------------------
-- Other functions

render : Block → String
render x = unlines
  $ maybe′ (uncurry (λ hd tl → hd ∷ Tree.Infix.toList tl)) []
  $ node? (Block.block x .value) (Block.last x .value) leaf

valid : (width : ℕ) (b : Block) → Dec (Block.maxWidth b .value ≤ width)
valid width b = Block.maxWidth b .value ≤? width


module Examples.Syntax where

open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.String using (_++_)
open import Luau.Syntax using (var; _$_; return; nil; function_⟨_⟩_end; done; _∙_)
open import Luau.Syntax.ToString using (exprToString; blockToString)

f = var "f"
x = var "x"

ex1 : exprToString(f $ x) ≡
  "f(x)"
ex1 = refl

ex2 : blockToString(return nil ∙ done) ≡
  "return nil"
ex2 = refl

ex3 : blockToString(function "f" ⟨ "x" ⟩ return x ∙ done end ∙ return f ∙ done) ≡
  "local function f(x)\n" ++
  "  return x\n" ++
  "end\n" ++
  "return f"
ex3 = refl


------------------------------------------------------------------------
-- The two methods used to specify the grammars are (language)
-- equivalent (for acyclic graphs)
------------------------------------------------------------------------

open import Mixfix.Expr
open import Mixfix.Acyclic.PrecedenceGraph
  using (acyclic; precedence)

module Mixfix.Equivalence
  (g : PrecedenceGraphInterface.PrecedenceGraph acyclic)
  where

open import Function using (_∘_)
open import Data.List using (List; []; _∷_)
open import Data.List.NonEmpty using (_∷_)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Product
open import Data.Vec using (Vec; []; _∷_)

open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics
open import TotalParserCombinators.Semantics.Continuation as ContSem
import StructurallyRecursiveDescentParsing.Simplified as Simplified
import StructurallyRecursiveDescentParsing.Simplified.Semantics as SSem

open import Mixfix.Fixity
open import Mixfix.Operator
import Mixfix.Acyclic.Grammar
import Mixfix.Cyclic.Grammar
import Mixfix.Acyclic.Lemma
private
  module Acyclic = Mixfix.Acyclic.Grammar        g
  module ALemma  = Mixfix.Acyclic.Lemma          g
  module Cyclic  = Mixfix.Cyclic.Grammar acyclic g
open import Mixfix.Acyclic.Lib as ALib
open ALib.Semantics-⊕ renaming (_⊕_∈⟦_⟧·_ to _⊕_∈⟦_⟧A·_)
open import Mixfix.Cyclic.Lib as CLib renaming (⟦_⟧ to ⟦_⟧C)
open CLib.Semantics-⊕ renaming (_⊕_∈⟦_⟧·_ to _⊕_∈⟦_⟧C·_)

open PrecedenceCorrect acyclic g

⟦_⟧A : ∀ {R} → ALib.ParserProg R → Parser NamePart R []
⟦ p ⟧A = Simplified.⟦_⟧ (ALib.⟦_⟧ p)

module AcyclicToCyclic where

  mutual

    precs : ∀ ps {s s′ e} →
            e ⊕ s′ ∈⟦ Acyclic.precs ps ⟧A· s →
            e ⊕ s′ ∈⟦  Cyclic.precs ps ⟧C· s
    precs []       ()
    precs (p ∷ ps) (∣ˡ (<$> e∈p))  = ∣ˡ (<$> prec  p  e∈p)
    precs (p ∷ ps) (∣ʳ (<$> e∈ps)) = ∣ʳ (<$> precs ps e∈ps)

    prec : ∀ p {s s′ e} →
           e ⊕ s′ ∈⟦ Acyclic.prec p ⟧A· s →
           e ⊕ s′ ∈⟦  Cyclic.prec p ⟧C· s
    prec (precedence ops sucs) e∈ = prec′ e∈
      where
      p = precedence ops sucs

      module A = Acyclic.Prec ops sucs
      module C =  Cyclic.Prec p

      preRight : ∀ {s s′ f} →
                 f ⊕ s′ ∈⟦ A.preRight ⟧A· s →
                 f ⊕ s′ ∈⟦ C.preRight ⟧C· s
      preRight (∣ˡ (<$>      i∈)) = ∣ˡ (<$>              inner _ i∈)
      preRight (∣ʳ (<$> ↑∈ ⊛ i∈)) = ∣ʳ (<$> precs _ ↑∈ ⊛ inner _ i∈)

      preRight⁺ : ∀ {s s′ s″ fs e} →
                 fs          ⊕ s′ ∈⟦ A.preRight +       ⟧A· s  →
                 e           ⊕ s″ ∈⟦ Acyclic.precs sucs ⟧A· s′ →
                 A.appʳ fs e ⊕ s″ ∈⟦ C.preRight⁺        ⟧C· s
      preRight⁺ {fs = _ ∷ ._} (+-[] f∈)     ↑∈ = preRight f∈ ⊛∞ ∣ʳ (<$> precs _ ↑∈)
      preRight⁺ {fs = _ ∷ ._} (+-∷  f∈ fs∈) ↑∈ = preRight f∈ ⊛∞ ∣ˡ (<$> preRight⁺ fs∈ ↑∈)

      postLeft : ∀ {s s′ f} →
                 f ⊕ s′ ∈⟦ A.postLeft ⟧A· s →
                 f ⊕ s′ ∈⟦ C.postLeft ⟧C· s
      postLeft (∣ˡ (<$> i∈     )) = ∣ˡ (<$> inner _ i∈)
      postLeft (∣ʳ (<$> i∈ ⊛ ↑∈)) = ∣ʳ (<$> inner _ i∈ ⊛ precs _ ↑∈)

      postLeft⁺ : ∀ {s s′ s″ o fs} →
                  o                ⊕ s′ ∈⟦ similar <$> C.postLeft⁺
                                         ∣ tighter <$> C.p↑ ⟧C· s →
                  fs               ⊕ s″ ∈⟦ A.postLeft +       ⟧A· s′ →
                  ALemma.appˡ o fs ⊕ s″ ∈⟦ C.postLeft⁺        ⟧C· s
      postLeft⁺ {fs = _ ∷ ._} o∈ (+-[] f∈)     =                     <$> o∈ ⊛∞ postLeft f∈
      postLeft⁺ {fs = _ ∷ ._} o∈ (+-∷  f∈ fs∈) = postLeft⁺ (∣ˡ (<$> (<$> o∈ ⊛∞ postLeft f∈))) fs∈

      prec′ : ∀ {s s′ assoc} {e : ExprIn p assoc} →
              (-, e) ⊕ s′ ∈⟦ Acyclic.prec p ⟧A· s →
              (-, e) ⊕ s′ ∈⟦  Cyclic.prec p ⟧C· s
      prec′ (∥ˡ (<$> i∈))                      = ∥ˡ (<$> inner _ i∈)
      prec′ (∥ʳ (∥ˡ (<$> ↑₁∈ ⊛ i∈ ⊛ ↑₂∈)))     = ∥ʳ (∥ˡ (<$> precs _ ↑₁∈ ⊛ inner _ i∈ ⊛∞ precs _ ↑₂∈ ))
      prec′ (∥ʳ (∥ʳ (∥ˡ (<$> fs∈ ⊛ ↑∈))))      = ∥ʳ (∥ʳ (∥ˡ (preRight⁺ fs∈ ↑∈)))
      prec′ (∥ʳ (∥ʳ (∥ʳ (∥ˡ (<$> ↑∈ ⊛ fs∈))))) = ∥ʳ (∥ʳ (∥ʳ (∥ˡ (postLeft⁺ (∣ʳ (<$> precs _ ↑∈)) fs∈))))
      prec′ (∥ʳ (∥ʳ (∥ʳ (∥ʳ ()))))

    inner : ∀ {fix} (ops : List (∃ (Operator fix))) {s s′ i} →
            i ⊕ s′ ∈⟦ Acyclic.inner ops ⟧A· s →
            i ⊕ s′ ∈⟦  Cyclic.inner ops ⟧C· s
    inner []               ()
    inner ((_ , op) ∷ ops) (∣ˡ (<$> i∈)) = ∣ˡ (<$> inner′ _ i∈)
    inner ((_ , op) ∷ ops) (∣ʳ (<$> i∈)) = ∣ʳ (<$> inner ops i∈)

    inner′ : ∀ {arity} (ns : Vec NamePart (1 + arity)) {s s′ i} →
             i ⊕ s′ ∈⟦ Acyclic.expr between ns ⟧A· s →
             i ⊕ s′ ∈⟦  Cyclic.expr between ns ⟧C· s
    inner′ (n ∷ .[]) between-[]           = between-[]
    inner′ (n ∷ ns)  (between-∷ e∈g es∈g) =
      between-∷ (precs g e∈g) (inner′ ns es∈g)

module CyclicToAcyclic where

  mutual

    precs : ∀ ps {s s′ e} →
            e ⊕ s′ ∈⟦  Cyclic.precs ps ⟧C· s →
            e ⊕ s′ ∈⟦ Acyclic.precs ps ⟧A· s
    precs []       ()
    precs (p ∷ ps) (∣ˡ (<$> e∈p))  = ∣ˡ (<$> prec  p  e∈p)
    precs (p ∷ ps) (∣ʳ (<$> e∈ps)) = ∣ʳ (<$> precs ps e∈ps)

    prec : ∀ p {s s′ e} →
           e ⊕ s′ ∈⟦  Cyclic.prec p ⟧C· s →
           e ⊕ s′ ∈⟦ Acyclic.prec p ⟧A· s
    prec (precedence ops sucs) e∈ = prec′ e∈
      where
      p = precedence ops sucs

      module A = Acyclic.Prec ops sucs
      module C =  Cyclic.Prec p

      preRight : ∀ {s s′ f} →
                 f ⊕ s′ ∈⟦ C.preRight ⟧C· s →
                 f ⊕ s′ ∈⟦ A.preRight ⟧A· s
      preRight (∣ˡ (<$>      i∈)) = ∣ˡ (<$>              inner _ i∈)
      preRight (∣ʳ (<$> ↑∈ ⊛ i∈)) = ∣ʳ (<$> precs _ ↑∈ ⊛ inner _ i∈)

      preRight⁺ : ∀ {s s′ e} →
                  e ⊕ s′ ∈⟦ C.preRight⁺                    ⟧C· s →
                  e ⊕ s′ ∈⟦ A.appʳ <$> A.preRight + ⊛ A.p↑ ⟧A· s
      preRight⁺ (f∈ ⊛∞ ∣ˡ (<$> pre∈)) with preRight⁺ pre∈
      preRight⁺ (f∈ ⊛∞ ∣ˡ (<$> pre∈)) | <$> fs∈ ⊛ ↑∈ = <$> +-∷  (preRight f∈) fs∈ ⊛ ↑∈
      preRight⁺ (f∈ ⊛∞ ∣ʳ (<$> ↑∈)  ) =                <$> +-[] (preRight f∈)     ⊛ precs _ ↑∈

      postLeft : ∀ {s s′ f} →
                 f ⊕ s′ ∈⟦ C.postLeft ⟧C· s →
                 f ⊕ s′ ∈⟦ A.postLeft ⟧A· s
      postLeft (∣ˡ (<$> i∈     )) = ∣ˡ (<$> inner _ i∈)
      postLeft (∣ʳ (<$> i∈ ⊛ ↑∈)) = ∣ʳ (<$> inner _ i∈ ⊛ precs _ ↑∈)

      postLeft⁺ : ∀ {s s′ e} →
                  e ⊕ s′ ∈⟦ C.postLeft⁺                    ⟧C· s →
                  e ⊕ s′ ∈⟦ A.appˡ <$> A.p↑ ⊛ A.postLeft + ⟧A· s
      postLeft⁺ (<$> ∣ˡ (<$> post∈) ⊛∞ f∈) with postLeft⁺ post∈
      postLeft⁺ (<$> ∣ˡ (<$> post∈) ⊛∞ f∈)
        | _⊛_ {x = fs} (<$> ↑∈) fs∈ = AS.cast∈ (ALemma.appˡ-∷ʳ _ fs _) (
                                             <$>         ↑∈ ⊛ AS.+-∷ʳ fs∈ (postLeft f∈))
        where module AS = ALib.Semantics-⊕
      postLeft⁺ (<$> ∣ʳ (<$> ↑∈)    ⊛∞ f∈) = <$> precs _ ↑∈ ⊛    +-[]     (postLeft f∈)

      prec′ : ∀ {s s′ assoc} {e : ExprIn p assoc} →
              (-, e) ⊕ s′ ∈⟦  Cyclic.prec p ⟧C· s →
              (-, e) ⊕ s′ ∈⟦ Acyclic.prec p ⟧A· s
      prec′ (∥ˡ (<$> i∈))                   = ∥ˡ (<$> inner _ i∈)
      prec′ (∥ʳ (∥ˡ (<$> ↑₁∈ ⊛ i∈ ⊛∞ ↑₂∈))) = ∥ʳ (∥ˡ (<$> precs _ ↑₁∈ ⊛ inner _ i∈ ⊛ precs _ ↑₂∈ ))
      prec′ (∥ʳ (∥ʳ (∥ˡ pre∈)))             = ∥ʳ (∥ʳ (∥ˡ (preRight⁺ pre∈)))
      prec′ (∥ʳ (∥ʳ (∥ʳ (∥ˡ post∈))))       = ∥ʳ (∥ʳ (∥ʳ (∥ˡ (postLeft⁺ post∈))))
      prec′ (∥ʳ (∥ʳ (∥ʳ (∥ʳ ()))))

    inner : ∀ {fix} (ops : List (∃ (Operator fix))) {s s′ i} →
            i ⊕ s′ ∈⟦  Cyclic.inner ops ⟧C· s →
            i ⊕ s′ ∈⟦ Acyclic.inner ops ⟧A· s
    inner []               ()
    inner ((_ , op) ∷ ops) (∣ˡ (<$> i∈)) = ∣ˡ (<$> inner′ _ i∈)
    inner ((_ , op) ∷ ops) (∣ʳ (<$> i∈)) = ∣ʳ (<$> inner ops i∈)

    inner′ : ∀ {arity} (ns : Vec NamePart (1 + arity)) {s s′ i} →
             i ⊕ s′ ∈⟦  Cyclic.expr between ns ⟧C· s →
             i ⊕ s′ ∈⟦ Acyclic.expr between ns ⟧A· s
    inner′ (n ∷ .[]) between-[]           = between-[]
    inner′ (n ∷ ns)  (between-∷ e∈g es∈g) =
      between-∷ (precs g e∈g) (inner′ ns es∈g)

acyclicToCyclic
  : ∀ {e s} → e ∈ Simplified.⟦_⟧ Acyclic.expression · s →
              e ∈                 Cyclic.expression · s
acyclicToCyclic =
  ContSem.sound               ∘
  CLib.Semantics-⊕.sound      ∘
  AcyclicToCyclic.precs _     ∘
  ALib.Semantics-⊕.complete _ ∘
  SSem.⊕-complete             ∘
  SSem.complete _

cyclicToAcyclic
  : ∀ {e s} → e ∈                 Cyclic.expression · s →
              e ∈ Simplified.⟦_⟧ Acyclic.expression · s
cyclicToAcyclic =
  SSem.sound                  ∘
  SSem.⊕-sound                ∘
  ALib.Semantics-⊕.sound      ∘
  CyclicToAcyclic.precs _     ∘
  CLib.Semantics-⊕.complete _ ∘
  ContSem.complete


module CoprodMonad where

open import functor
open import monad

data PlusT (t₁ t₂ : Set → Set) (a : Set) (p₁ : Triple t₁)(p₂ : Triple t₂) : Set where
  T₁ : (t₁ (PlusT t₁ t₂ a p₁ p₂)) → PlusT t₁ t₂ a p₁ p₂


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

open import lib.Basics
open import lib.NType2
open import lib.types.Bool
open import lib.types.Empty
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Sigma

{-
This file contains various lemmas that rely on lib.types.Paths or
functional extensionality for pointed maps.
-}

module lib.types.Pointed where

{- Pointed maps -}

⊙app= : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  → f == g → f ⊙∼ g
⊙app= {X = X} {Y = Y} p =
  app= (fst= p) , ↓-ap-in (_== pt Y) (λ u → u (pt X)) (snd= p)

-- function extensionality for pointed maps
⊙λ= : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  → f ⊙∼ g → f == g
⊙λ= {g = g} (p , α) = pair= (λ= p)
  (↓-app=cst-in (↓-idf=cst-out α ∙ ap (_∙ snd g) (! (app=-β p _))))

⊙λ=' : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  (p : fst f ∼ fst g)
  (α : snd f == snd g [ (λ y → y == pt Y) ↓ p (pt X) ])
  → f == g
⊙λ=' {g = g} = curry ⊙λ=

-- associativity of pointed maps
⊙∘-assoc-pt : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  {a₁ a₂ : A} (f : A → B) {b : B} (g : B → C) {c : C}
  (p : a₁ == a₂) (q : f a₂ == b) (r : g b == c)
  → ⊙∘-pt (g ∘ f) p (⊙∘-pt g q r) == ⊙∘-pt g (⊙∘-pt f p q) r
⊙∘-assoc-pt _ _ idp _ _ = idp

⊙∘-assoc : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (h : Z ⊙→ W) (g : Y ⊙→ Z) (f : X ⊙→ Y)
  → ((h ⊙∘ g) ⊙∘ f) ⊙∼ (h ⊙∘ (g ⊙∘ f))
⊙∘-assoc (h , hpt) (g , gpt) (f , fpt) = (λ _ → idp) , ⊙∘-assoc-pt g h fpt gpt hpt

⊙∘-cst-l : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  → (f : X ⊙→ Y) → (⊙cst :> (Y ⊙→ Z)) ⊙∘ f ⊙∼ ⊙cst
⊙∘-cst-l {Z = Z} f = (λ _ → idp) , ap (_∙ idp) (ap-cst (pt Z) (snd f))

⊙∘-cst-r : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  → (f : Y ⊙→ Z) → f ⊙∘ (⊙cst :> (X ⊙→ Y)) ⊙∼ ⊙cst
⊙∘-cst-r {X = X} f = (λ _ → snd f) , ↓-idf=cst-in' idp

{- Pointed equivalences -}

-- Extracting data from an pointed equivalence
module _ {i j} {X : Ptd i} {Y : Ptd j} (⊙e : X ⊙≃ Y) where

  ⊙≃-to-≃ : de⊙ X ≃ de⊙ Y
  ⊙≃-to-≃ = fst (fst ⊙e) , snd ⊙e

  ⊙–> : X ⊙→ Y
  ⊙–> = fst ⊙e

  ⊙–>-pt = snd ⊙–>

  ⊙<– : Y ⊙→ X
  ⊙<– = is-equiv.g (snd ⊙e) , lemma ⊙e where
    lemma : {Y : Ptd j} (⊙e : X ⊙≃ Y) → is-equiv.g (snd ⊙e) (pt Y) == pt X
    lemma ((f , idp) , f-ise) = is-equiv.g-f f-ise (pt X)

  ⊙<–-pt = snd ⊙<–

  infix 120 _⊙⁻¹
  _⊙⁻¹ : Y ⊙≃ X
  _⊙⁻¹ = ⊙<– , is-equiv-inverse (snd ⊙e)

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  ⊙<–-inv-l : (⊙e : X ⊙≃ Y) → ⊙<– ⊙e ⊙∘ ⊙–> ⊙e ⊙∼ ⊙idf _
  ⊙<–-inv-l ⊙e = <–-inv-l (⊙≃-to-≃ ⊙e) , ↓-idf=cst-in' (lemma ⊙e) where
    lemma : {Y : Ptd j} (⊙e : X ⊙≃ Y)
      → snd (⊙<– ⊙e ⊙∘ ⊙–> ⊙e) == is-equiv.g-f (snd ⊙e) (pt X)
    lemma ((f , idp) , f-ise) = idp

  ⊙<–-inv-r : (⊙e : X ⊙≃ Y) → ⊙–> ⊙e ⊙∘ ⊙<– ⊙e ⊙∼ ⊙idf _
  ⊙<–-inv-r ⊙e = <–-inv-r (⊙≃-to-≃ ⊙e) , ↓-idf=cst-in' (lemma ⊙e) where
    lemma : {Y : Ptd j} (⊙e : X ⊙≃ Y)
      → snd (⊙–> ⊙e ⊙∘ ⊙<– ⊙e) == is-equiv.f-g (snd ⊙e) (pt Y)
    lemma ((f , idp) , f-ise) = ∙-unit-r _ ∙ is-equiv.adj f-ise (pt X)

module _ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} (⊙e : X ⊙≃ Y) where

  post⊙∘-is-equiv : is-equiv (λ (k : Z ⊙→ X) → ⊙–> ⊙e ⊙∘ k)
  post⊙∘-is-equiv = is-eq (⊙–> ⊙e ⊙∘_) (⊙<– ⊙e ⊙∘_) (to-from ⊙e) (from-to ⊙e) where
    abstract
      to-from : ∀ {Y} (⊙e : X ⊙≃ Y) (k : Z ⊙→ Y) → ⊙–> ⊙e ⊙∘ (⊙<– ⊙e ⊙∘ k) == k
      to-from ((f , idp) , f-ise) (k , k-pt) = ⊙λ=' (f.f-g ∘ k) (↓-idf=cst-in' $ lemma k-pt)
        where
          module f = is-equiv f-ise
          lemma : ∀ {y₀} (k-pt : y₀ == f (pt X))
            → ⊙∘-pt f (⊙∘-pt f.g k-pt (f.g-f _)) idp == f.f-g y₀ ∙' k-pt
          lemma idp = ∙-unit-r _ ∙ f.adj _

      from-to : ∀ {Y} (⊙e : X ⊙≃ Y) (k : Z ⊙→ X) → ⊙<– ⊙e ⊙∘ (⊙–> ⊙e ⊙∘ k) == k
      from-to ((f , idp) , f-ise) (k , idp) = ⊙λ=' (f.g-f ∘ k) $ ↓-idf=cst-in' idp
        where module f = is-equiv f-ise

  post⊙∘-equiv : (Z ⊙→ X) ≃ (Z ⊙→ Y)
  post⊙∘-equiv = _ , post⊙∘-is-equiv

  pre⊙∘-is-equiv : is-equiv (λ (k : Y ⊙→ Z) → k ⊙∘ ⊙–> ⊙e)
  pre⊙∘-is-equiv = is-eq (_⊙∘ ⊙–> ⊙e) (_⊙∘ ⊙<– ⊙e) (to-from ⊙e) (from-to ⊙e) where
    abstract
      to-from : ∀ {Z} (⊙e : X ⊙≃ Y) (k : X ⊙→ Z) → (k ⊙∘ ⊙<– ⊙e) ⊙∘ ⊙–> ⊙e == k
      to-from ((f , idp) , f-ise) (k , idp) = ⊙λ=' (ap k ∘ f.g-f) $ ↓-idf=cst-in' $ ∙-unit-r _
        where module f = is-equiv f-ise

      from-to : ∀ {Z} (⊙e : X ⊙≃ Y) (k : Y ⊙→ Z) → (k ⊙∘ ⊙–> ⊙e) ⊙∘ ⊙<– ⊙e == k
      from-to ((f , idp) , f-ise) (k , idp) = ⊙λ=' (ap k ∘ f.f-g) $ ↓-idf=cst-in' $
        ∙-unit-r _ ∙ ap-∘ k f (f.g-f (pt X)) ∙ ap (ap k) (f.adj (pt X))
        where module f = is-equiv f-ise

  pre⊙∘-equiv : (Y ⊙→ Z) ≃ (X ⊙→ Z)
  pre⊙∘-equiv = _ , pre⊙∘-is-equiv

{- Pointed maps out of bool -}

-- intuition : [f true] is fixed and the only changable part is [f false].

⊙Bool→-to-idf : ∀ {i} {X : Ptd i}
  → ⊙Bool ⊙→ X → de⊙ X
⊙Bool→-to-idf (h , _) = h false

⊙Bool→-equiv-idf : ∀ {i} (X : Ptd i)
  → (⊙Bool ⊙→ X) ≃ de⊙ X
⊙Bool→-equiv-idf {i} X = equiv ⊙Bool→-to-idf g f-g g-f
  where
  g : de⊙ X → ⊙Bool ⊙→ X
  g x = Bool-rec (pt X) x , idp

  abstract
    f-g : ∀ x → ⊙Bool→-to-idf (g x) == x
    f-g x = idp

    g-f : ∀ H → g (⊙Bool→-to-idf H) == H
    g-f (h , hpt) = pair=
      (λ= lemma)
      (↓-app=cst-in $
        idp
          =⟨ ! (!-inv-l hpt) ⟩
        ! hpt ∙ hpt
          =⟨ ! (app=-β lemma true) |in-ctx (λ w → w ∙ hpt) ⟩
        app= (λ= lemma) true ∙ hpt
          =∎)
      where lemma : ∀ b → fst (g (h false)) b == h b
            lemma true = ! hpt
            lemma false = idp

⊙Bool→-equiv-idf-nat : ∀ {i j} {X : Ptd i} {Y : Ptd j} (F : X ⊙→ Y)
  → CommSquareEquiv
      (F ⊙∘_)
      (fst F)
      ⊙Bool→-to-idf
      ⊙Bool→-to-idf
⊙Bool→-equiv-idf-nat F = (comm-sqr λ _ → idp) ,
  snd (⊙Bool→-equiv-idf _) , snd (⊙Bool→-equiv-idf _)


-- Andreas, 2016-06-03, bug found by Ulf
-- {-# OPTIONS -v tc.cover:20 #-}

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field fst : A
        snd : B fst
open Σ

record ⊤ : Set where
data ⊥ : Set where

T : Bool → Set
T true = ⊤
T false = ⊥

p : Σ Bool T
fst p = false
p = true , _

loop : ⊥
loop = snd p