module sn-calculus-compatconf where

open import sn-calculus
open import utility renaming (_U̬_ to _∪_)
open import context-properties
  using (get-view ; ->E-view ; ->pot-view)

open import sn-calculus-compatconf.eview
  using (1-steplρ-E-view)
open import sn-calculus-compatconf.pot
  using (1-steplρ-pot)
open import sn-calculus-confluence
  using (R-confluent)

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ)

open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; cong ; trans ; subst ; module ≡-Reasoning)
open import Data.Bool
  using (Bool ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; _∷_ ; [] ; _++_)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using ()
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; _×_ ; ∃)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function using (_∘_ ; id ; _∋_)

open import Data.OrderedListMap Signal Signal.unwrap Signal.Status as SigM
open import Data.OrderedListMap SharedVar SharedVar.unwrap (Σ SharedVar.Status (λ _ → ℕ)) as ShrM
open import Data.OrderedListMap SeqVar SeqVar.unwrap ℕ as SeqM

open ->E-view
open ->pot-view

open EvaluationContext1
open _≐_⟦_⟧e
open Context1
open _≐_⟦_⟧c

open ListSet Data.Nat._≟_

1-step-sn⟶₁ : ∀{p q r BV FV} →
  CorrectBinding p BV FV →
  p sn⟶₁ q →
  p sn⟶₁ r →
  Σ[ p' ∈ Term ] (q sn⟶* p'  ×  r sn⟶* p')
1-step-sn⟶₁ cb psn⟶₁q psn⟶₁r with R-confluent cb psn⟶₁q psn⟶₁r
... | inj₁ refl = _ , rrefl ,′ rrefl
... | inj₂ (inj₁ (_ , qsn⟶₁s , rsn⟶₁s)) =
  _ , sn⟶*-inclusion (sn⟶-inclusion qsn⟶₁s) ,′ sn⟶*-inclusion (sn⟶-inclusion rsn⟶₁s)
... | inj₂ (inj₂ (inj₁ qsn⟶₁r)) =
  _ , sn⟶*-inclusion (sn⟶-inclusion qsn⟶₁r) ,′ rrefl
... | inj₂ (inj₂ (inj₂ rsn⟶₁q)) =
  _ , rrefl ,′ sn⟶*-inclusion (sn⟶-inclusion rsn⟶₁q)

1-steplρ : ∀{p q r θ θq BV FV A Aq} →
  CorrectBinding (ρ⟨ θ , A ⟩· p) BV FV →
  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θq , Aq ⟩· q →
  p sn⟶ r →
  Σ[ p' ∈ Term ] ((ρ⟨ θq , Aq ⟩· q) sn⟶* p'   ×    (ρ⟨ θ , A ⟩· r) sn⟶* p')
1-steplρ {p} {q} {r} cb
  ρθ·psn⟶₁ρθq·q psn⟶r@(rcontext {.p} {rin} {ro} C p≐C⟦rin⟧ rinsn⟶₁ro)
  with get-view ρθ·psn⟶₁ρθq·q
... | inj₂ (refl , refl , pot) =
  _ ,   1-steplρ-pot cb pot psn⟶r
... | inj₁ (E , qin , qo , p≐E⟦qin⟧ , q≐E⟦qo⟧ , e-view) =
  _ ,  proj₂ (1-steplρ-E-view cb p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ rinsn⟶₁ro)

1-stepl : ∀{p q r BV FV} →
  CorrectBinding p BV FV →
  p sn⟶₁ q →
  p sn⟶ r →
  Σ[ p' ∈ Term ] (q sn⟶* p'  ×  r sn⟶* p')
1-stepl cb psn⟶₁q
        (rcontext [] dchole psn⟶₁r) =
  1-step-sn⟶₁ cb psn⟶₁q psn⟶₁r
1-stepl cb (rpar-done-right p' q')
        (rcontext (ceval (epar₁ _) ∷ crs) (dcpar₁ dcr) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶ p' (rcontext _ dcr psn⟶₁r))
1-stepl cb (rpar-done-left (dhalted p') q')
        (rcontext (ceval (epar₁ _) ∷ crs) (dcpar₁ dcr) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶ p' (rcontext _ dcr psn⟶₁r))
1-stepl cb (rpar-done-left (dpaused p') hnothin)
        (rcontext (ceval (epar₁ _) ∷ crs) (dcpar₁ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ dcr psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ dchole
                   (rpar-done-left
                    (dpaused (paused-sn⟶ p' (rcontext _ dcr psn⟶₁r)))
                    hnothin))
1-stepl cb (rpar-done-left (dpaused p') (hexit n))
        (rcontext (ceval (epar₁ _) ∷ crs) (dcpar₁ dcr) psn⟶₁r) =
  _ ,
  rrefl  ,′
  sn⟶*-inclusion (rcontext _ dchole
                   (rpar-done-left
                    (dpaused (paused-sn⟶ p' (rcontext _ dcr psn⟶₁r)))
                    (hexit n)))
1-stepl cb (rpar-done-right p' (dhalted q'))
        (rcontext (ceval (epar₂ p₁) ∷ crs) (dcpar₂ dcr) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶ q' (rcontext _ dcr psn⟶₁r))
1-stepl cb (rpar-done-right hnothin (dpaused q'))
        (rcontext (ceval (epar₂ .nothin) ∷ crs) (dcpar₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ dcr psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ dchole
                   (rpar-done-right
                    hnothin
                    (dpaused (paused-sn⟶ q' (rcontext _ dcr psn⟶₁r)))))
1-stepl cb (rpar-done-right (hexit n) (dpaused q'))
        (rcontext (ceval (epar₂ .(exit n)) ∷ crs) (dcpar₂ dcr) psn⟶₁r) =
  _ ,
  rrefl  ,′
  sn⟶*-inclusion (rcontext _ dchole
                   (rpar-done-right
                    (hexit n)
                    (dpaused (paused-sn⟶ q' (rcontext _ dcr psn⟶₁r)))))
1-stepl cb (rpar-done-left p' q')
        (rcontext (ceval (epar₂ p₁) ∷ crs) (dcpar₂ dcr) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶ q' (rcontext _ dcr psn⟶₁r))
1-stepl cb rseq-done
        (rcontext _ (dcseq₁ dchole) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶₁ hnothin psn⟶₁r)
1-stepl cb rseq-exit
        (rcontext _ (dcseq₁ dchole) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶₁ (hexit _) psn⟶₁r)
1-stepl cb rloopˢ-exit
        (rcontext _ (dcloopˢ₁ dchole) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶₁ (hexit _) psn⟶₁r)
1-stepl cb (rsuspend-done p')
        (rcontext (ceval (esuspend S) ∷ crs) (dcsuspend dcr) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶₁ (halted-⟦⟧c p' dcr) psn⟶₁r)
1-stepl cb (rtrap-done p')
        (rcontext (ceval etrap ∷ crs) (dctrap dcr) psn⟶₁r) =
  ⊥-elim (halted-¬sn⟶₁ (halted-⟦⟧c p' dcr) psn⟶₁r)
1-stepl cb rraise-signal (rcontext (csignl S ∷ crs) (dcsignl dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcenv dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ dchole rraise-signal)
1-stepl cb rloop-unroll
        (rcontext (cloop ∷ crs) (dcloop dcr) psn⟶₁r) =

  _ ,
  rstep (rcontext _ (dcloopˢ₁ dcr) psn⟶₁r)
        (rstep (rcontext _ (dcloopˢ₂ dcr) psn⟶₁r) rrefl) ,′
  sn⟶*-inclusion (rcontext [] dchole rloop-unroll)

1-stepl cb rseq-done
        (rcontext (cseq₂ .nothin ∷ crs) (dcseq₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ dcr psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ dchole rseq-done)
1-stepl cb rseq-exit
        (rcontext (cseq₂ .(exit _) ∷ crs) (dcseq₂ dcr) psn⟶₁r) =
  _ ,
  rrefl  ,′
  sn⟶*-inclusion (rcontext _ dchole rseq-exit)
1-stepl cb rloopˢ-exit
        (rcontext (cloopˢ₂ .(exit _) ∷ crs) (dcloopˢ₂ dcr) psn⟶₁r) =
  _ ,
  rrefl  ,′
  sn⟶*-inclusion (rcontext _ dchole rloopˢ-exit)
1-stepl {ρ⟨ .θ , .A ⟩· p} cb
        ρθpsn⟶₁q
        ρθpsn⟶r@(rcontext {p = p₂} {p' = r} (cenv θ A ∷ crs) (dcenv p≐crs⟦p₂⟧) p₂sn⟶₁r)
  with ρ-stays-ρ-sn⟶₁ ρθpsn⟶₁q
... | θ' , A' , qin , refl =
  1-steplρ cb ρθpsn⟶₁q (rcontext crs p≐crs⟦p₂⟧ p₂sn⟶₁r)

1-step : ∀{p q r BV FV} →
  CorrectBinding p BV FV →
  p sn⟶ q →
  p sn⟶ r →
  Σ[ p' ∈ Term ] (q  sn⟶* p'  ×  r sn⟶* p')
1-step cb   (rcontext [] dchole psn⟶₁q) psn⟶r =  1-stepl cb psn⟶₁q psn⟶r
1-step cb
       psn⟶q@(rcontext (_ ∷ _) _ _) (rcontext [] dchole psn⟶₁r) with 1-stepl cb psn⟶₁r psn⟶q
... | _ , rsn⟶*p' , qsn⟶*p' =  _ , qsn⟶*p' ,′ rsn⟶*p'
1-step cb@(CBpar cbp cbq _ _ _ _)
       (rcontext (cq ∷ cqs) (dcpar₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpar₁ dcr) psn⟶₁r)
  with 1-step cbp (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBpar cbp cbq _ _ _ _)
       (rcontext (cq ∷ cqs) (dcpar₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpar₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcpar₂ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcpar₁ dcq) psn⟶₁q)
1-step cb@(CBpar cbp cbq _ _ _ _)
       (rcontext (cq ∷ cqs) (dcpar₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpar₁ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcpar₁ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcpar₂ dcq) psn⟶₁q)
1-step cb@(CBpar cbp cbq _ _ _ _)
       (rcontext (cq ∷ cqs) (dcpar₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpar₂ dcr) psn⟶₁r)
  with 1-step cbq (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBseq cbp cbq _)
       (rcontext (cq ∷ cqs) (dcseq₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcseq₁ dcr) psn⟶₁r)
  with 1-step cbp (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb
       (rcontext (cq ∷ cqs) (dcseq₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcseq₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcseq₂ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcseq₁ dcq) psn⟶₁q)
1-step cb
       (rcontext (cq ∷ cqs) (dcseq₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcseq₁ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcseq₁ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcseq₂ dcq) psn⟶₁q)
1-step cb@(CBseq cbp cbq _)
       (rcontext (cq ∷ cqs) (dcseq₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcseq₂ dcr) psn⟶₁r)
  with 1-step cbq (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBloopˢ cbp cbq _ _)
       (rcontext (cq ∷ cqs) (dcloopˢ₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcloopˢ₁ dcr) psn⟶₁r)
  with 1-step cbp (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''

1-step cb
       (rcontext (cq ∷ cqs) (dcloopˢ₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcloopˢ₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcloopˢ₂ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcloopˢ₁ dcq) psn⟶₁q)
1-step cb
       (rcontext (cq ∷ cqs) (dcloopˢ₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcloopˢ₁ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcloopˢ₁ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcloopˢ₂ dcq) psn⟶₁q)
1-step cb@(CBloopˢ cbp cbq _ _)
       (rcontext (cq ∷ cqs) (dcloopˢ₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcloopˢ₂ dcr) psn⟶₁r)
  with 1-step cbq (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''

1-step cb@(CBsusp cb' _)
       (rcontext (cq ∷ cqs) (dcsuspend dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcsuspend dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBtrap cb')
       (rcontext (cq ∷ cqs) (dctrap dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dctrap dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBsig cb')
       (rcontext (cq ∷ cqs) (dcsignl dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcsignl dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBpresent cbp cbq)
       (rcontext (cq ∷ cqs) (dcpresent₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpresent₁ dcr) psn⟶₁r)
  with 1-step cbp (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb
       (rcontext (cq ∷ cqs) (dcpresent₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpresent₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcpresent₂ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcpresent₁ dcq) psn⟶₁q)
1-step cb
       (rcontext (cq ∷ cqs) (dcpresent₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpresent₁ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcpresent₁ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcpresent₂ dcq) psn⟶₁q)
1-step cb@(CBpresent cbp cbq)
       (rcontext (cq ∷ cqs) (dcpresent₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcpresent₂ dcr) psn⟶₁r)
  with 1-step cbq (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBloop cb' _)
       (rcontext (cq ∷ cqs) (dcloop dcq) psn⟶₁q) (rcontext (cr ∷ crs) (dcloop dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBshared cb')
       (rcontext (cq ∷ cqs) (dcshared dcq) psn⟶₁q) (rcontext (cr ∷ crs) (dcshared dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBvar cb')
       (rcontext (cq ∷ cqs) (dcvar dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcvar dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBif cbp cbq)
       (rcontext (cq ∷ cqs) (dcif₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcif₁ dcr) psn⟶₁r)
  with 1-step cbp (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb
       (rcontext (cq ∷ cqs) (dcif₁ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcif₂ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcif₂ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcif₁ dcq) psn⟶₁q)
1-step cb
       (rcontext (cq ∷ cqs) (dcif₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcif₁ dcr) psn⟶₁r) =
  _ ,
  sn⟶*-inclusion (rcontext _ (dcif₁ dcr) psn⟶₁r) ,′
  sn⟶*-inclusion (rcontext _ (dcif₂ dcq) psn⟶₁q)
1-step cb@(CBif cbp cbq)
       (rcontext (cq ∷ cqs) (dcif₂ dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcif₂ dcr) psn⟶₁r)
  with 1-step cbq (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''
1-step cb@(CBρ cb')
       (rcontext (cq ∷ cqs) (dcenv dcq) psn⟶₁q)
       (rcontext (cr ∷ crs) (dcenv dcr) psn⟶₁r)
  with 1-step cb' (rcontext cqs dcq psn⟶₁q) (rcontext crs dcr psn⟶₁r)
... | p'' , q'sn⟶*p'' , r'sn⟶*p'' = _ , Context1-sn⟶* cq q'sn⟶*p'' ,′ Context1-sn⟶* cr r'sn⟶*p''


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

module Definition.Conversion.Stability where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Conversion
open import Definition.Conversion.Soundness
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Equality of contexts.
data ⊢_≡_ : (Γ Δ : Con Term) → Set where
  ε : ⊢ ε ≡ ε
  _∙_ : ∀ {Γ Δ A B} → ⊢ Γ ≡ Δ → Γ ⊢ A ≡ B → ⊢ Γ ∙ A ≡ Δ ∙ B

mutual
  -- Syntactic validity and conversion substitution of a context equality.
  contextConvSubst : ∀ {Γ Δ} → ⊢ Γ ≡ Δ → ⊢ Γ × ⊢ Δ × Δ ⊢ˢ idSubst ∷ Γ
  contextConvSubst ε = ε , ε , id
  contextConvSubst (_∙_ {Γ} {Δ} {A} {B} Γ≡Δ A≡B) =
    let ⊢Γ , ⊢Δ , [σ] = contextConvSubst Γ≡Δ
        ⊢A , ⊢B = syntacticEq A≡B
        Δ⊢B = stability Γ≡Δ ⊢B
    in  ⊢Γ ∙ ⊢A , ⊢Δ ∙ Δ⊢B
        , (wk1Subst′ ⊢Γ ⊢Δ Δ⊢B [σ]
        , conv (var (⊢Δ ∙ Δ⊢B) here)
               (PE.subst (λ x → _ ⊢ _ ≡ x)
                         (wk1-tailId A)
                         (wkEq (step id) (⊢Δ ∙ Δ⊢B) (stabilityEq Γ≡Δ (sym A≡B)))))

  -- Stability of types under equal contexts.
  stability : ∀ {A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A → Δ ⊢ A
  stability Γ≡Δ A =
    let ⊢Γ , ⊢Δ , σ = contextConvSubst Γ≡Δ
        q = substitution A σ ⊢Δ
    in  PE.subst (λ x → _ ⊢ x) (subst-id _) q

  -- Stability of type equality.
  stabilityEq : ∀ {A B Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ≡ B → Δ ⊢ A ≡ B
  stabilityEq Γ≡Δ A≡B =
    let ⊢Γ , ⊢Δ , σ = contextConvSubst Γ≡Δ
        q = substitutionEq A≡B (substRefl σ) ⊢Δ
    in  PE.subst₂ (λ x y → _ ⊢ x ≡ y) (subst-id _) (subst-id _) q

-- Reflexivity of context equality.
reflConEq : ∀ {Γ} → ⊢ Γ → ⊢ Γ ≡ Γ
reflConEq ε = ε
reflConEq (⊢Γ ∙ ⊢A) = reflConEq ⊢Γ ∙ refl ⊢A

-- Symmetry of context equality.
symConEq : ∀ {Γ Δ} → ⊢ Γ ≡ Δ → ⊢ Δ ≡ Γ
symConEq ε = ε
symConEq (Γ≡Δ ∙ A≡B) = symConEq Γ≡Δ ∙ stabilityEq Γ≡Δ (sym A≡B)

-- Stability of terms.
stabilityTerm : ∀ {t A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t ∷ A → Δ ⊢ t ∷ A
stabilityTerm Γ≡Δ t =
  let ⊢Γ , ⊢Δ , σ = contextConvSubst Γ≡Δ
      q = substitutionTerm t σ ⊢Δ
  in  PE.subst₂ (λ x y → _ ⊢ x ∷ y) (subst-id _) (subst-id _) q

-- Stability of term reduction.
stabilityRedTerm : ∀ {t u A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t ⇒ u ∷ A → Δ ⊢ t ⇒ u ∷ A
stabilityRedTerm Γ≡Δ (conv d x) =
  conv (stabilityRedTerm Γ≡Δ d) (stabilityEq Γ≡Δ x)
stabilityRedTerm Γ≡Δ (app-subst d x) =
  app-subst (stabilityRedTerm Γ≡Δ d) (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (fst-subst ⊢F ⊢G t⇒) =
  fst-subst (stability Γ≡Δ ⊢F)
            (stability (Γ≡Δ ∙ refl ⊢F) ⊢G)
            (stabilityRedTerm Γ≡Δ t⇒)
stabilityRedTerm Γ≡Δ (snd-subst ⊢F ⊢G t⇒) =
  snd-subst (stability Γ≡Δ ⊢F)
            (stability (Γ≡Δ ∙ refl ⊢F) ⊢G)
            (stabilityRedTerm Γ≡Δ t⇒)
stabilityRedTerm Γ≡Δ (Σ-β₁ ⊢F ⊢G ⊢t ⊢u) =
  Σ-β₁ (stability Γ≡Δ ⊢F)
       (stability (Γ≡Δ ∙ refl ⊢F) ⊢G)
       (stabilityTerm Γ≡Δ ⊢t)
       (stabilityTerm Γ≡Δ ⊢u)
stabilityRedTerm Γ≡Δ (Σ-β₂ ⊢F ⊢G ⊢t ⊢u) =
  Σ-β₂ (stability Γ≡Δ ⊢F)
       (stability (Γ≡Δ ∙ refl ⊢F) ⊢G)
       (stabilityTerm Γ≡Δ ⊢t)
       (stabilityTerm Γ≡Δ ⊢u)
stabilityRedTerm Γ≡Δ (β-red x x₁ x₂) =
  β-red (stability Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl x) x₁)
        (stabilityTerm Γ≡Δ x₂)
stabilityRedTerm Γ≡Δ (natrec-subst x x₁ x₂ d) =
  let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
  in  natrec-subst (stability (Γ≡Δ ∙ refl (ℕⱼ ⊢Γ)) x) (stabilityTerm Γ≡Δ x₁)
                   (stabilityTerm Γ≡Δ x₂) (stabilityRedTerm Γ≡Δ d)
stabilityRedTerm Γ≡Δ (natrec-zero x x₁ x₂) =
  let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
  in  natrec-zero (stability (Γ≡Δ ∙ refl (ℕⱼ ⊢Γ)) x) (stabilityTerm Γ≡Δ x₁)
                  (stabilityTerm Γ≡Δ x₂)
stabilityRedTerm Γ≡Δ (natrec-suc x x₁ x₂ x₃) =
  let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
  in  natrec-suc (stabilityTerm Γ≡Δ x) (stability (Γ≡Δ ∙ refl (ℕⱼ ⊢Γ)) x₁)
                 (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
stabilityRedTerm Γ≡Δ (Emptyrec-subst x d) =
  Emptyrec-subst (stability Γ≡Δ x) (stabilityRedTerm Γ≡Δ d)

-- Stability of type reductions.
stabilityRed : ∀ {A B Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ⇒ B → Δ ⊢ A ⇒ B
stabilityRed Γ≡Δ (univ x) = univ (stabilityRedTerm Γ≡Δ x)

-- Stability of type reduction closures.
stabilityRed* : ∀ {A B Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ⇒* B → Δ ⊢ A ⇒* B
stabilityRed* Γ≡Δ (id x) = id (stability Γ≡Δ x)
stabilityRed* Γ≡Δ (x ⇨ D) = stabilityRed Γ≡Δ x ⇨ stabilityRed* Γ≡Δ D

-- Stability of term reduction closures.
stabilityRed*Term : ∀ {t u A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t ⇒* u ∷ A → Δ ⊢ t ⇒* u ∷ A
stabilityRed*Term Γ≡Δ (id x) = id (stabilityTerm Γ≡Δ x)
stabilityRed*Term Γ≡Δ (x ⇨ d) = stabilityRedTerm Γ≡Δ x ⇨ stabilityRed*Term Γ≡Δ d

mutual
  -- Stability of algorithmic equality of neutrals.
  stability~↑ : ∀ {k l A Γ Δ}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ k ~ l ↑ A
              → Δ ⊢ k ~ l ↑ A
  stability~↑ Γ≡Δ (var-refl x x≡y) =
    var-refl (stabilityTerm Γ≡Δ x) x≡y
  stability~↑ Γ≡Δ (app-cong k~l x) =
    app-cong (stability~↓ Γ≡Δ k~l) (stabilityConv↑Term Γ≡Δ x)
  stability~↑ Γ≡Δ (fst-cong p~r) =
    fst-cong (stability~↓ Γ≡Δ p~r)
  stability~↑ Γ≡Δ (snd-cong p~r) =
    snd-cong (stability~↓ Γ≡Δ p~r)
  stability~↑ Γ≡Δ (natrec-cong x₁ x₂ x₃ k~l) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in natrec-cong (stabilityConv↑ (Γ≡Δ ∙ (refl (ℕⱼ ⊢Γ))) x₁)
                   (stabilityConv↑Term Γ≡Δ x₂)
                   (stabilityConv↑Term Γ≡Δ x₃)
                   (stability~↓ Γ≡Δ k~l)
  stability~↑ Γ≡Δ (Emptyrec-cong x₁ k~l) =
    Emptyrec-cong (stabilityConv↑ Γ≡Δ x₁)
                (stability~↓ Γ≡Δ k~l)

  -- Stability of algorithmic equality of neutrals of types in WHNF.
  stability~↓ : ∀ {k l A Γ Δ}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ k ~ l ↓ A
              → Δ ⊢ k ~ l ↓ A
  stability~↓ Γ≡Δ ([~] A D whnfA k~l) =
    [~] A (stabilityRed* Γ≡Δ D) whnfA (stability~↑ Γ≡Δ k~l)

  -- Stability of algorithmic equality of types.
  stabilityConv↑ : ∀ {A B Γ Δ}
                 → ⊢ Γ ≡ Δ
                 → Γ ⊢ A [conv↑] B
                 → Δ ⊢ A [conv↑] B
  stabilityConv↑ Γ≡Δ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    [↑] A′ B′ (stabilityRed* Γ≡Δ D) (stabilityRed* Γ≡Δ D′) whnfA′ whnfB′
        (stabilityConv↓ Γ≡Δ A′<>B′)

  -- Stability of algorithmic equality of types in WHNF.
  stabilityConv↓ : ∀ {A B Γ Δ}
                 → ⊢ Γ ≡ Δ
                 → Γ ⊢ A [conv↓] B
                 → Δ ⊢ A [conv↓] B
  stabilityConv↓ Γ≡Δ (U-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  U-refl ⊢Δ
  stabilityConv↓ Γ≡Δ (ℕ-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  ℕ-refl ⊢Δ
  stabilityConv↓ Γ≡Δ (Empty-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  Empty-refl ⊢Δ
  stabilityConv↓ Γ≡Δ (Unit-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  Unit-refl ⊢Δ
  stabilityConv↓ Γ≡Δ (ne x) =
    ne (stability~↓ Γ≡Δ x)
  stabilityConv↓ Γ≡Δ (Π-cong F A<>B A<>B₁) =
    Π-cong (stability Γ≡Δ F) (stabilityConv↑ Γ≡Δ A<>B)
           (stabilityConv↑ (Γ≡Δ ∙ refl F) A<>B₁)
  stabilityConv↓ Γ≡Δ (Σ-cong F A<>B A<>B₁) =
    Σ-cong (stability Γ≡Δ F) (stabilityConv↑ Γ≡Δ A<>B)
           (stabilityConv↑ (Γ≡Δ ∙ refl F) A<>B₁)

  -- Stability of algorithmic equality of terms.
  stabilityConv↑Term : ∀ {t u A Γ Δ}
                     → ⊢ Γ ≡ Δ
                     → Γ ⊢ t [conv↑] u ∷ A
                     → Δ ⊢ t [conv↑] u ∷ A
  stabilityConv↑Term Γ≡Δ ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    [↑]ₜ B t′ u′ (stabilityRed* Γ≡Δ D) (stabilityRed*Term Γ≡Δ d)
                 (stabilityRed*Term Γ≡Δ d′) whnfB whnft′ whnfu′
                 (stabilityConv↓Term Γ≡Δ t<>u)

  -- Stability of algorithmic equality of terms in WHNF.
  stabilityConv↓Term : ∀ {t u A Γ Δ}
                     → ⊢ Γ ≡ Δ
                     → Γ ⊢ t [conv↓] u ∷ A
                     → Δ ⊢ t [conv↓] u ∷ A
  stabilityConv↓Term Γ≡Δ (ℕ-ins x) =
    ℕ-ins (stability~↓ Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (Empty-ins x) =
    Empty-ins (stability~↓ Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (Unit-ins x) =
    Unit-ins (stability~↓ Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (ne-ins t u neN x) =
    ne-ins (stabilityTerm Γ≡Δ t) (stabilityTerm Γ≡Δ u) neN (stability~↓ Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (univ x x₁ x₂) =
    univ (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁) (stabilityConv↓ Γ≡Δ x₂)
  stabilityConv↓Term Γ≡Δ (zero-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  zero-refl ⊢Δ
  stabilityConv↓Term Γ≡Δ (suc-cong t<>u) = suc-cong (stabilityConv↑Term Γ≡Δ t<>u)
  stabilityConv↓Term Γ≡Δ (η-eq x x₁ y y₁ t<>u) =
    let ⊢F , ⊢G = syntacticΠ (syntacticTerm x)
    in  η-eq (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
             y y₁ (stabilityConv↑Term (Γ≡Δ ∙ refl ⊢F) t<>u)
  stabilityConv↓Term Γ≡Δ (Σ-η ⊢p ⊢r pProd rProd fstConv sndConv) =
    Σ-η (stabilityTerm Γ≡Δ ⊢p) (stabilityTerm Γ≡Δ ⊢r)
        pProd rProd
        (stabilityConv↑Term Γ≡Δ fstConv) (stabilityConv↑Term Γ≡Δ sndConv)
  stabilityConv↓Term Γ≡Δ (η-unit [t] [u] tUnit uUnit) =
    let [t] = stabilityTerm Γ≡Δ [t]
        [u] = stabilityTerm Γ≡Δ [u]
    in  η-unit [t] [u] tUnit uUnit


------------------------------------------------------------------------------
-- Agda internal syntax
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- Tested with Agda development version on 25 February 2013.

module InternalSyntax where

------------------------------------------------------------------------------
-- Sets

postulate A B C : Set

-- El {getSort = Type (Max [ClosedLevel 1]), unEl = Sort (Type (Max []))}

postulate A₁ : Set₁

-- El {getSort = Type (Max [ClosedLevel 2]), unEl = Sort (Type (Max [ClosedLevel 1]))}

------------------------------------------------------------------------------
-- The term is Def

postulate def : A

-- El {getSort = Type (Max []), unEl = Def InternalSyntax.A []}

------------------------------------------------------------------------------
-- The term is Pi

postulate fun₁ : A → B

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--              (NoAbs "_" El {getSort = Type (Max []), unEl = Def InternalSyntax.B []})}

postulate fun₂ : A → B → C

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--           (NoAbs "_" El {getSort = Type (Max []),
--                      unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.B []})
--                            (NoAbs "_" El {getSort = Type (Max []), unEl = Def InternalSyntax.C []})})}

postulate fun₃ : (a : A) → B

-- El (Type (Max []))
--    (Pi r(El (Type (Max []))
--             (Def InternalSyntax.A []))
--        (Abs "a" El (Type (Max []))
--                 (Def InternalSyntax.B [])))

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--              (NoAbs "a" El {getSort = Type (Max []), unEl = Def InternalSyntax.B []})}

postulate P : A → Set

-- El {getSort = Type (Max [ClosedLevel 1]),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--              (NoAbs "_" El {getSort = Type (Max [ClosedLevel 1]), unEl = Sort (Type (Max []))})}

postulate fun₅ : (a : A) → P a

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--             (Abs "a" El {getSort = Type (Max []), unEl = Def InternalSyntax.P [[]r(Var 0 [])]})}


module datatype-util where
open import constants
open import ctxt
open import syntax-util
open import general-util
open import type-util
open import cedille-types
open import subst
open import rename
open import free-vars

{-# TERMINATING #-}
decompose-arrows : ctxt → type → params × type
decompose-arrows Γ (TpAbs me x atk T) =
  let x' = fresh-var-new Γ x in
  case decompose-arrows (ctxt-var-decl x' Γ) (rename-var Γ x x' T) of λ where
    (ps , T') → Param me x' atk :: ps , T'
decompose-arrows Γ T = [] , T

decompose-ctr-type : ctxt → type → type × params × 𝕃 tmtp
decompose-ctr-type Γ T with decompose-arrows Γ T
...| ps , Tᵣ with decompose-tpapps Tᵣ
...| Tₕ , as = Tₕ , ps , as

{-# TERMINATING #-}
kind-to-indices : ctxt → kind → indices
kind-to-indices Γ (KdAbs x atk k) =
  let x' = fresh-var-new Γ x in
  Index x' atk :: kind-to-indices (ctxt-var-decl x' Γ) (rename-var Γ x x' k)
kind-to-indices Γ _ = []

rename-indices-h : ctxt → renamectxt → indices → 𝕃 tmtp → indices
rename-indices-h Γ ρ (Index x atk :: is) (ty :: tys) =
  Index x' atk' ::
    rename-indices-h (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') is tys
  where
  x' = fresh-var-renamectxt Γ ρ (maybe-else x id (is-var-unqual ty))
  atk' = subst-renamectxt Γ ρ -tk atk
rename-indices-h Γ ρ (Index x atk :: is) [] =
  let x' = fresh-var-renamectxt Γ ρ x in
  Index x' (subst-renamectxt Γ ρ -tk atk) ::
    rename-indices-h (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') is []
rename-indices-h _ _ [] _ = []

rename-indices : ctxt → indices → 𝕃 tmtp → indices
rename-indices Γ = rename-indices-h Γ empty-renamectxt

positivity : Set
positivity = 𝔹 × 𝔹 -- occurs positively × occurs negatively

pattern occurs-nil = ff , ff
pattern occurs-pos = tt , ff
pattern occurs-neg = ff , tt
pattern occurs-all = tt , tt

--positivity-inc : positivity → positivity
--positivity-dec : positivity → positivity
positivity-neg : positivity → positivity
positivity-add : positivity → positivity → positivity

--positivity-inc = map-fst λ _ → tt
--positivity-dec = map-snd λ _ → tt
positivity-neg = uncurry $ flip _,_
positivity-add (+ₘ , -ₘ) (+ₙ , -ₙ) = (+ₘ || +ₙ) , (-ₘ || -ₙ)

data ctorCheckT : Set where
  ctorOk : ctorCheckT
  ctorNotInReturnType : ctorCheckT
  ctorNegative : ctorCheckT

posₒ = fst
negₒ = snd

occurs : positivity → ctorCheckT
occurs p = if (negₒ p) then ctorNegative else ctorOk

or-ctorCheckT : ctorCheckT → ctorCheckT → ctorCheckT
or-ctorCheckT ctorOk r = r
or-ctorCheckT ctorNegative  _ = ctorNegative
or-ctorCheckT ctorNotInReturnType _ = ctorNotInReturnType

posM : Set → Set
posM A = 𝕃 tpkd → A × 𝕃 tpkd

run-posM : ∀{A : Set} → posM A → A × 𝕃 tpkd
run-posM p = p []

extract-pos : ∀{A : Set} → posM A → A
extract-pos = fst ∘ run-posM

instance
  posM-monad : monad posM
  return ⦃ posM-monad ⦄ a = λ l → a , l
  _>>=_ ⦃ posM-monad ⦄ p ap l with p l
  _>>=_ ⦃ posM-monad ⦄ p ap l | a , l' = ap a l'

  posM-functor : functor posM
  fmap ⦃ posM-functor ⦄ g m l with m l
  fmap ⦃ posM-functor ⦄ g m l | a , l' = g a , l'

  posM-applicative : applicative posM
  pure ⦃ posM-applicative ⦄ = return
  _<*>_ ⦃ posM-applicative ⦄ mab ma l with mab l
  _<*>_ ⦃ posM-applicative ⦄ mab ma l | f , l' with ma l'
  _<*>_ ⦃ posM-applicative ⦄ mab ma l | f , l' | a , l'' =
    f a , l''

add-posM : tpkd → posM ⊤
add-posM x = λ l → triv , x :: l

module positivity (x : var) where

  open import conversion

  if-free : ∀ {ed} → ⟦ ed ⟧ → positivity
  if-free t with is-free-in x t
  ...| f = f , f

  if-free-args : args → positivity
  if-free-args as =
    let c = stringset-contains (free-vars-args as) x in c , c

  hnf' : ∀ {ed} → ctxt → ⟦ ed ⟧ → ⟦ ed ⟧
  hnf' Γ T = hnf Γ unfold-no-defs T

  mtt = maybe-else tt id
  mff = maybe-else ff id

  {-# TERMINATING #-}
  type+ : ctxt → type → posM positivity
  kind+ : ctxt → kind → posM positivity
  tpkd+ : ctxt → tpkd → posM positivity
  tpapp+ : ctxt → type → posM positivity
  type+h : ctxt → type → posM positivity
  kind+h : ctxt → kind → posM positivity
  tpkd+h : ctxt → tpkd → posM positivity
  tpapp+h : ctxt → type → posM positivity

  type+ Γ T = type+h Γ T -- >>= λ p → add-posM (Tkt T) >> return p
  kind+ Γ k = kind+h Γ k
  tpkd+ Γ x = tpkd+h Γ x
  tpapp+ Γ T = tpapp+h Γ T

  type+h Γ (TpAbs me x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
      pure positivity-add <*>
        (fmap positivity-neg $ tpkd+ Γ $ hnf' Γ -tk atk) <*>
        (type+ Γ' $ hnf' Γ' T)
  type+h Γ (TpIota x' T T') =
    let Γ' = ctxt-var-decl x' Γ in
      pure positivity-add <*>
        (type+ Γ $ hnf' Γ T) <*>
        (type+ Γ' $ hnf' Γ' T')
  type+h Γ (TpApp T tT) = tpapp+ Γ $ hnf' Γ $ TpApp T tT
  type+h Γ (TpEq tₗ tᵣ) = pure occurs-nil
  type+h Γ (TpHole _) = pure occurs-nil
  type+h Γ (TpLam x' atk T)=
    let Γ' = ctxt-var-decl x' Γ in
      pure positivity-add <*>
        (fmap positivity-neg $ tpkd+ Γ $ hnf' Γ -tk atk) <*>
        (type+ Γ' (hnf' Γ' T))
  type+h Γ (TpVar x') = pure $ x =string x' , ff

  kind+h Γ (KdAbs x' atk k) =
    let Γ' = ctxt-var-decl x' Γ in
      pure positivity-add <*>
      (fmap positivity-neg $ tpkd+ Γ $ hnf' Γ -tk atk) <*>
      (kind+ Γ' k)
  kind+h Γ _ = pure occurs-nil

  tpkd+h Γ (Tkt T) = type+ Γ (hnf' Γ T)
  tpkd+h Γ (Tkk k) = kind+ Γ k

  tpapp+h Γ T with decompose-tpapps T
  tpapp+h Γ T | TpVar x' , as =
    let f = if-free-args (tmtps-to-args NotErased as) in
    if x =string x'
      then pure (positivity-add occurs-pos f)
      else maybe-else' (data-lookup Γ x' as) (pure f)
        λ {(mk-data-info x'' xₒ'' asₚ asᵢ ps kᵢ k cs csₚₛ eds gds) →
          let s = (inst-type Γ ps asₚ (hnf' Γ $ TpAbs tt x'' (Tkk k) $ foldr (uncurry λ cₓ cₜ → TpAbs ff ignored-var (Tkt cₜ)) (TpVar x'') cs)) in
          add-posM (Tkt s) >>
          type+ Γ s }
  tpapp+h Γ T | _ , _ = pure $ if-free T

  {-# TERMINATING #-}
  arrs+ : ctxt → type → posM ctorCheckT

  arrs+ Γ (TpAbs me x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
     pure or-ctorCheckT <*>
       (fmap occurs (tpkd+ Γ $ hnf' Γ -tk atk)) <*>
       (arrs+ Γ' (hnf' Γ' T))
  arrs+ Γ (TpApp T tT) = fmap occurs (tpapp+ Γ $ hnf' Γ (TpApp T tT))
  arrs+ Γ (TpLam x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
      pure or-ctorCheckT <*>
        (fmap occurs (tpkd+ Γ $ hnf' Γ -tk atk)) <*>
        (arrs+ Γ' (hnf' Γ' T))
  arrs+ Γ (TpVar x') = return $ if (x =string x') then ctorOk else ctorNotInReturnType

  arrs+ _ _ = return ctorNegative

  ctr-positive : ctxt → type → posM ctorCheckT
  ctr-positive Γ = (arrs+ Γ ∘ hnf' Γ)

-- build the evidence for a sigma-term, given datatype X with associated info μ
sigma-build-evidence : var → datatype-info → term
sigma-build-evidence X μ =
  if datatype-info.name μ =string X then recompose-apps (datatype-info.asₚ μ) (Var (data-is/ X)) else Var (mu-isType/' X)


module Properties.Base where

open import Data.Maybe hiding (All)
open import Data.List
open import Data.List.All
open import Data.Product
open import Data.Sum

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Typing
open import Global
open import Values
open import Session
open import Schedule

one-step : ∀ {G} → (∃ λ G' → ThreadPool (G' ++ G)) → Event × (∃ λ G → ThreadPool G)
one-step{G} (G1 , tp)
  with ssplit-refl-left-inactive (G1 ++ G)
... | G' , ina-G' , ss-GG'
  with Alternative.step ss-GG' tp (tnil ina-G')
... | ev , tp' = ev , ( _ , tp')

restart : ∀ {G} → Command G → Command G
restart (Ready ss v κ) = apply-cont ss κ v
restart cmd = cmd

-- auxiliary lemmas

lift-unrestricted :
  ∀ {t G} (unrt : Unr t) (v : Val G t)
  → unrestricted-val unrt (lift-val v) ≡ ::-inactive (unrestricted-val unrt v)
lift-unrestricted-venv :
  ∀ {Φ G} (unrt : All Unr Φ) (ϱ : VEnv G Φ)
  → unrestricted-venv unrt (lift-venv ϱ) ≡ ::-inactive (unrestricted-venv unrt ϱ)

lift-unrestricted UUnit (VUnit inaG) = refl
lift-unrestricted UInt (VInt i inaG) = refl
lift-unrestricted (UPair unrt unrt₁) (VPair ss-GG₁G₂ v v₁)
  rewrite lift-unrestricted unrt v | lift-unrestricted unrt₁ v₁
  = refl
lift-unrestricted UFun (VFun (inj₁ ()) ϱ e)
lift-unrestricted UFun (VFun (inj₂ y) ϱ e) = lift-unrestricted-venv y ϱ

lift-unrestricted-venv [] (vnil ina) = refl
lift-unrestricted-venv (px ∷ unrt) (vcons ssp v ϱ)
  rewrite lift-unrestricted px v | lift-unrestricted-venv unrt ϱ
  = refl

unrestricted-empty : ∀ {t} → (unrt : Unr t) (v : Val [] t) → unrestricted-val unrt v ≡ []-inactive
unrestricted-empty-venv : ∀ {t} → (unrt : All Unr t) (v : VEnv [] t) → unrestricted-venv unrt v ≡ []-inactive

unrestricted-empty UUnit (VUnit []-inactive) = refl
unrestricted-empty UInt (VInt i []-inactive) = refl
unrestricted-empty (UPair unrt unrt₁) (VPair ss-[] v v₁)
  rewrite unrestricted-empty unrt v | unrestricted-empty unrt₁ v₁
  = refl
unrestricted-empty UFun (VFun (inj₁ ()) ϱ e)
unrestricted-empty UFun (VFun (inj₂ y) ϱ e) = unrestricted-empty-venv y ϱ

unrestricted-empty-venv [] (vnil []-inactive) = refl
unrestricted-empty-venv (px ∷ unrt) (vcons ss-[] v v₁)
  rewrite unrestricted-empty px v | unrestricted-empty-venv unrt v₁
  = refl

split-env-lemma :
  ∀ { Φ Φ₁ Φ₂ }
  (sp : Split Φ Φ₁ Φ₂)
  (ϱ : VEnv [] Φ)
  → ∃ λ ϱ₁ → ∃ λ ϱ₂ →
             split-env sp (lift-venv ϱ) ≡
             (((nothing ∷ []) , (nothing ∷ [])) , (ss-both ss-[]) , lift-venv ϱ₁ , lift-venv ϱ₂)

split-env-lemma [] (vnil []-inactive) =
  (vnil []-inactive) , ((vnil []-inactive) , refl)
split-env-lemma (dupl unrt sp) (vcons ss-[] v ϱ)
  with split-env-lemma sp ϱ | unrestricted-val unrt v
... | ϱ₁ , ϱ₂ , spe==  | unr-v
  rewrite inactive-left-ssplit ss-[] unr-v | lift-unrestricted unrt v | unrestricted-empty unrt v | spe==
  with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[])
... | ssc3
  = (vcons ss-[] v ϱ₁)
  , (vcons ss-[] v ϱ₂)
  , refl
split-env-lemma (Split.drop unrt sp) (vcons ss-[] v ϱ)
  with split-env-lemma sp ϱ | unrestricted-val unrt v
... | ϱ₁ , ϱ₂ , spe== | unr-v
  rewrite lift-unrestricted unrt v | unrestricted-empty unrt v
  = ϱ₁ , ϱ₂ , spe==
split-env-lemma (left sp) (vcons ss-[] v ϱ)
  with split-env-lemma sp ϱ
... | ϱ₁ , ϱ₂ , spe==
  rewrite spe==
  with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[])
... | ssc3
  = (vcons ss-[] v ϱ₁) , (ϱ₂ , refl)
split-env-lemma (rght sp) (vcons ss-[] v ϱ)
  with split-env-lemma sp ϱ
... | ϱ₁ , ϱ₂ , spe==
  rewrite spe==
  with ssplit-compose4 (ss-both ss-[]) (ss-both ss-[])
... | ssc4
  = ϱ₁ , (vcons ss-[] v ϱ₂) , refl

split-env-right-lemma :
  ∀ {Φ} (ϱ : VEnv [] Φ) →
  split-env (split-all-right Φ) (lift-venv ϱ)
  ≡
  (((nothing ∷ []) , (nothing ∷ [])) , (ss-both ss-[]) , vnil (::-inactive []-inactive) , lift-venv ϱ)
split-env-right-lemma (vnil []-inactive) = refl
split-env-right-lemma (vcons ss-[] v ϱ)
  with split-env-right-lemma ϱ
... | sperl
  rewrite sperl
  with ssplit-compose4 (ss-both ss-[]) (ss-both ss-[])
... | ssc4
  = refl

split-env-right-lemma0 :
  ∀ {Φ} (ϱ : VEnv [] Φ) →
  split-env (split-all-right Φ) ϱ
  ≡
  (([] , []) , ss-[] , vnil []-inactive , ϱ)
split-env-right-lemma0 (vnil []-inactive) = refl
split-env-right-lemma0 (vcons ss-[] v ϱ)
  rewrite split-env-right-lemma0 ϱ
  = refl

split-env-left-lemma0 :
  ∀ {Φ} (ϱ : VEnv [] Φ) →
  split-env (split-all-left Φ) ϱ
  ≡
  (([] , []) , ss-[] , ϱ , vnil []-inactive)
split-env-left-lemma0 (vnil []-inactive) = refl
split-env-left-lemma0 (vcons ss-[] v ϱ)
  rewrite split-env-left-lemma0 ϱ
  = refl

split-env-lemma-2T : Set
split-env-lemma-2T =
  ∀ { Φ Φ₁ Φ₂ }
  (sp : Split Φ Φ₁ Φ₂)
  (ϱ : VEnv [] Φ)
  → ∃ λ ϱ₁ → ∃ λ ϱ₂ →
             split-env sp (lift-venv ϱ) ≡
             (_ , (ss-both ss-[]) , lift-venv ϱ₁ , lift-venv ϱ₂)
             ×
             split-env sp ϱ ≡
             (_ , ss-[] , ϱ₁ , ϱ₂)

split-env-lemma-2 : split-env-lemma-2T
split-env-lemma-2 [] (vnil []-inactive)
  = (vnil []-inactive) , ((vnil []-inactive) , (refl , refl))
split-env-lemma-2 (dupl unrt sp) (vcons ss-[] v ϱ)
  with split-env-lemma-2 sp ϱ
... | ϱ₁ , ϱ₂ , selift-ind , se-ind
  rewrite se-ind | lift-unrestricted unrt v
  with unrestricted-val unrt v
... | []-inactive
  rewrite selift-ind
  with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[])
... | ssc3
  = (vcons ss-[] v ϱ₁) , (vcons ss-[] v ϱ₂) , refl , refl
split-env-lemma-2 (Split.drop unrt sp) (vcons ss-[] v ϱ)
  with split-env-lemma-2 sp ϱ
... | ϱ₁ , ϱ₂ , selift-ind , se-ind
  rewrite se-ind | lift-unrestricted unrt v
  with unrestricted-val unrt v
... | []-inactive
  = ϱ₁ , ϱ₂ , selift-ind , se-ind
split-env-lemma-2 (left sp) (vcons ss-[] v ϱ)
  with split-env-lemma-2 sp ϱ
... | ϱ₁ , ϱ₂ , selift-ind , se-ind
  rewrite se-ind | selift-ind
  with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[])
... | ssc3
  = (vcons ss-[] v ϱ₁) , ϱ₂ , refl , refl
split-env-lemma-2 (rght sp) (vcons ss-[] v ϱ)
  with split-env-lemma-2 sp ϱ
... | ϱ₁ , ϱ₂ , selift-ind , se-ind
  rewrite se-ind | selift-ind
  with ssplit-compose4 (ss-both ss-[]) (ss-both ss-[])
... | ssc4
  = ϱ₁ , (vcons ss-[] v ϱ₂) , refl , refl

split-rotate-lemma : ∀ {Φ} →
  split-rotate (split-all-left Φ) (split-all-right Φ)
  ≡
  (Φ , split-all-right Φ , split-all-left Φ)

split-rotate-lemma {[]} = refl
split-rotate-lemma {x ∷ Φ}
  rewrite split-rotate-lemma {Φ}
  = refl

split-rotate-lemma' :  ∀ {Φ Φ₁ Φ₂}
  (sp : Split Φ Φ₁ Φ₂) →
  split-rotate (split-all-left Φ) sp
  ≡
  (Φ₂ , sp , split-all-left Φ₂)

split-rotate-lemma' {[]} [] = refl
split-rotate-lemma' {x ∷ Φ} (dupl un-x sp)
  rewrite split-rotate-lemma' {Φ} sp
  = refl
split-rotate-lemma' {x ∷ Φ} {Φ₁} {Φ₂} (Split.drop un-x sp)
  rewrite split-rotate-lemma' {Φ} sp
  = refl
split-rotate-lemma' {x ∷ Φ} (left sp)
  rewrite split-rotate-lemma' {Φ} sp
  = refl
split-rotate-lemma' {x ∷ Φ} (rght sp)
  rewrite split-rotate-lemma' {Φ} sp
  = refl

ssplit-compose-lemma : ∀ ss →
  ssplit-compose ss-[] ss ≡ ([] , ss-[] , ss-[])
ssplit-compose-lemma ss-[] = refl


module sn-calculus-compatconf.pot where

open import can-function-preserve
  using (canₖ-monotonic ; canₛ-monotonic ; canₛₕ-monotonic)

open import sn-calculus
open import utility renaming (_U̬_ to _∪_)
open import context-properties
  using (->pot-view)

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.CanFunction
  using (Can ; Canₛ ; Canₛₕ ; Canₖ ; Canθ ; Canθₛ ; Canθₛₕ ; Canθₖ)
open import Esterel.Lang.CanFunction.Properties
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Context.Properties
  using (unplugc)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ)

open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; cong ; trans ; subst ; module ≡-Reasoning)
open import Data.Bool
  using (Bool ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; _∷_ ; [] ; _++_)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using ()
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; _×_ ; ∃)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function using (_∘_ ; id ; _∋_)

open import Data.OrderedListMap Signal Signal.unwrap Signal.Status as SigM
open import Data.OrderedListMap SharedVar SharedVar.unwrap (Σ SharedVar.Status (λ _ → ℕ)) as ShrM
open import Data.OrderedListMap SeqVar SeqVar.unwrap ℕ as SeqM

open ->pot-view

open Context1
open _≐_⟦_⟧c

{-
       (p)
  ρθ. C⟦pin⟧   -- sn⟶₁ ->    ρθ' C⟦pin⟧
 (ρθ) C⟦pin⟧   -- sn⟶₁ ->   (ρθ) C⟦qin⟧
-}
1-steplρ-pot-lemma : ∀{C θ p pin qin θ' BV FV A} →
  {ρθpsn⟶₁ρθ'p  :  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ' , A ⟩· p} →

  ->pot-view  ρθpsn⟶₁ρθ'p  refl refl →

  CorrectBinding pin BV FV →
  p ≐ C ⟦ pin ⟧c →
  pin sn⟶₁ qin →

  ρ⟨ θ , A ⟩· C ⟦ qin ⟧c   sn⟶₁  ρ⟨ θ' , A ⟩· C ⟦ qin ⟧c

1-steplρ-pot-lemma {C} {θ} {_} {pin} {qin}
  {ρθpsn⟶₁ρθ'p = .(rabsence {S = S} S∈ θS≡unknown S∉can-p-θ)}
  (vabsence S S∈ θS≡unknown S∉can-p-θ)
  cb p≐C⟦pin⟧ pinsn⟶₁qin with sym (unplugc p≐C⟦pin⟧)
... | refl
  = rabsence {S = S} S∈ θS≡unknown
      (λ S∈can-q-θ →
        S∉can-p-θ
          (canθₛ-plug 0 (Env.sig θ) C pin qin
            (λ θ* → canₛ-monotonic θ* _ _ cb pinsn⟶₁qin ∘ _ₛ)
            (λ θ* → canₖ-monotonic θ* _ _ cb pinsn⟶₁qin)
            Env.[]env (Signal.unwrap S) S∈can-q-θ))

1-steplρ-pot-lemma {C} {θ} {_} {pin} {qin}
  {ρθpsn⟶₁ρθ'p = .(rreadyness {s = s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
  (vreadyness {θ = .θ} s s∈ θs≡old⊎θs≡new s∉can-p-θ)
  cb p≐C⟦pin⟧ pinsn⟶₁qin with sym (unplugc p≐C⟦pin⟧)
... | refl
  = rreadyness {s = s} s∈ θs≡old⊎θs≡new
      (λ s∈can-q-θ →
        s∉can-p-θ
          (canθₛₕ-plug 0 (Env.sig θ) C pin qin
            (λ θ* → canₛₕ-monotonic θ* _ _ cb pinsn⟶₁qin ∘ _ₛₕ)
            (λ θ* → canₖ-monotonic θ* _ _ cb pinsn⟶₁qin)
            (λ θ* → canₛ-monotonic θ* _ _ cb pinsn⟶₁qin ∘ _ₛ)
            Env.[]env (SharedVar.unwrap s)
            s∈can-q-θ))

-- Wrapper around 1-steplρ-pot-lemma.
1-steplρ-pot : ∀{p q θ θ' BV FV A} →
  {ρθpsn⟶₁ρθ'p  :  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ' , A ⟩· p} →
  CorrectBinding (ρ⟨ θ , A ⟩· p) BV FV →

  ->pot-view  ρθpsn⟶₁ρθ'p  refl refl →
  p sn⟶ q →

  (ρ⟨ θ' , A ⟩· p  sn⟶*  ρ⟨ θ' , A ⟩· q  ×
   ρ⟨ θ  , A ⟩· q  sn⟶*  ρ⟨ θ' , A ⟩· q)

1-steplρ-pot cb@(CBρ cb') pot psn⟶q@(rcontext _ p≐C⟦pin⟧ pinsn⟶₁qin) =
  sn⟶*-inclusion (rcontext _ (dcenv p≐C⟦pin⟧) pinsn⟶₁qin) ,′
  sn⟶*-inclusion
    (sn⟶-inclusion
      (1-steplρ-pot-lemma pot
        (proj₂ (binding-extractc' cb' p≐C⟦pin⟧))
        p≐C⟦pin⟧ pinsn⟶₁qin))


open import Data.String using (String)
open import Data.List using (List; []; _∷_)
open import Data.Nat using (ℕ)
open import Data.Product
open import Data.Bool
open import Data.Maybe
open import Data.Vec as V using (Vec; []; _∷_)
open import Data.Fin as F using (Fin; zero; suc)

open import Reflection using (TC)
open import Reflection.Name using (Names)
import Reflection.TypeChecking.Monad.Categorical as RCat

open import Category.Monad.State using (State; StateT; StateMonad; StateTMonad)
open import Category.Monad using (RawMonad)

--open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary
import      Relation.Unary as UR
open import Relation.Nullary.Negation using (contradiction)

open import Function

-- This is a `Maybe`-like data type except that nothing
-- is extended with a string argument, to carry around the error.
data Err {a} (A : Set a) : Set a where
  error : String → Err A
  ok : A → Err A

-- Our representation for programs: it is either a string containing
-- textual representation of the extracted program or an error that
-- happened during extraction.
Prog = Err String

-- Simply for convenience
Strings = List String

-- We define a custom RawMonoid to add `_++/_` (list join)
-- an its overloadings.
record RawMonoid {a}(A : Set a) : Set a where
  field
    _++_ : A → A → A
    ε : A
  _++/_ : (delim : A) → List A → A
  d ++/ [] = ε
  d ++/ (x ∷ []) = x
  d ++/ (x ∷ xs) = x ++ d ++ d ++/ xs

  infixr 5 _++_

open RawMonoid {{...}} public

instance
  monoidLst : ∀ {a}{A : Set a} → RawMonoid (List A)
  monoidLst {A = A} = record {
    _++_ = λ a b → (Data.List._++_ $! a) $! b ;
    ε = []
    }

  monoidStr : RawMonoid String
  monoidStr = record {
    _++_ = λ a b → (Data.String._++_ $! a) $! b;
    ε = ""
    }

  monoidErrStr : RawMonoid (Err String)
  monoidErrStr = record {
    _++_ =  λ where
      (error s) _ → error s
      _ (error s) → error s
      (ok s₁) (ok s₂) → ok (s₁ ++ s₂)
    ;
    ε = ok ""
    }

-- Simplify handling concatenation of `Prog`s and `String`s
data Err++Ty : Set → Set → Set where
  instance
    s-s : Err++Ty String String
    e-s : Err++Ty Prog String
    s-e : Err++Ty String Prog
    e-e : Err++Ty Prog Prog

infixr 5 _⊕_
_⊕_ : ∀ {A B}{{t : Err++Ty A B}} → A → B → Prog
_⊕_ {{t = s-s}} a         b = ok $! (a ++ b)
_⊕_ {{t = e-s}} (error x) b = error $! x
_⊕_ {{t = e-s}} (ok x)    b = ok $! (x ++ b)
_⊕_ {{t = s-e}} a (error x) = error $! x
_⊕_ {{t = s-e}} a    (ok x) = ok $! (a ++ x)
_⊕_ {{t = e-e}} a         b = id $! (a ++ b)

-- The state used at the top-most and term-level compilation.
record KS : Set where
  constructor ks
  field funs : Names   -- Functions to compile
        base : Names   -- Atomic functions that we do not traverse into.
        done : Names   -- Functions that we have processed.
        defs : Prog    -- Definitions such as lifted functions, function declarations, etc.
        cnt  : ℕ       -- Source of fresh variables

defaultKS = ks [] [] [] ε 1

SKS = State KS
TCS = StateT KS TC

instance
  monadTC = RCat.monad

  monadTCS : RawMonad TCS
  monadTCS = StateTMonad KS monadTC

  monadSKS : ∀ {S : Set} → RawMonad (State S)
  monadSKS {S} = StateMonad S

  monadErr : ∀ {f} → RawMonad {f} Err
  monadErr = record {
    return = ok ;
    _>>=_ = λ { (error s) f → error s ; (ok a) f → f a }
    }

lift-state : ∀ {f}{M}{RM : RawMonad {f} M}{A}{S} → M A → StateT S M A
lift-state {RM = RM} x = λ s → return (_, s) ⊛ x
          where open RawMonad RM

lift-mstate : ∀ {f}{M}{RM : RawMonad {f} M}{A}{S} → State S A → StateT S M A
lift-mstate {RM = RM}{S = S} sa = λ s → return (sa s)
                          where open RawMonad RM

-- Modify error message in Prog, in case Prog is error.
err-modify : Prog → (String → String) → Prog
err-modify (error s) f = error (f s)
err-modify p _ = p

-- Check if there exists an element in the list that satisfies the predicate P.
list-has-el : ∀ {a b}{A : Set a}{P : UR.Pred A b} → UR.Decidable P → List A → Bool
list-has-el P? [] = false
list-has-el P? (x ∷ xs) with P? x
... | yes _ = true
... | no  _ = list-has-el P? xs

-- Check if there exists an element in the list that satisfies the predicate P.
list-find-el : ∀ {a b}{A : Set a}{P : UR.Pred A b} → UR.Decidable P → List A → Maybe A
list-find-el P? [] = nothing
list-find-el P? (x ∷ xs) with P? x
... | yes _ = just x
... | no  _ = list-find-el P? xs

list-update-fst : ∀ {a b}{A : Set a}{P : UR.Pred A b} → UR.Decidable P → List A → (A → A) → List A
list-update-fst P? [] f = []
list-update-fst P? (x ∷ xs) f with P? x
... | yes _ = f x ∷ xs
... | no  _ = x ∷ list-update-fst P? xs f

list-filter : ∀ {a b}{A : Set a}{P : UR.Pred A b} → UR.Decidable P → List A → List A
list-filter P? [] = []
list-filter P? (x ∷ xs) with P? x
... | yes _ = x ∷ list-filter P? xs
... | no  _ = list-filter P? xs

dec-neg :  ∀ {a b}{A : Set a}{P : UR.Pred A b} → UR.Decidable P → UR.Decidable (UR._∉ P)
dec-neg P? x with P? x
... | yes p = no λ ¬p → contradiction p ¬p
... | no ¬p = yes ¬p

vec-find-el-idx : ∀ {a b}{A : Set a}{n}{P : UR.Pred A b} → UR.Decidable P → Vec A n → Maybe (Fin n × A)
vec-find-el-idx P? [] = nothing
vec-find-el-idx P? (x ∷ xs) with P? x
... | yes _ = just (zero , x)
... | no  _ with vec-find-el-idx P? xs
... | just (i , x′) = just (suc i , x′)
... | nothing = nothing


{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.DarkwingDuck.Primitive
module Spire.DarkwingDuck.Derived where

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

subst : (A : Set) (x : A) (y : A) (P : A → Set) → P x → x ≡ y → P y
subst A x y P p = elimEq A x (λ y _ → P y) p y

ISet : Set → Set
ISet I = I → Set

Scope  : Tel → Set
Scope = elimTel (λ _ → Set) ⊤ (λ A B ih → Σ A ih)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranchesM : Enum → Set
CurriedBranchesM E = (P : Tag E → Set) (X : Set) → Set

CurriedBranches : (E : Enum) → CurriedBranchesM E
CurriedBranches = elimEnum CurriedBranchesM
  (λ P X → X)
  (λ l E ih P X → P here → ih (λ t → P (there t)) X)

CurryBranches : Enum → Set
CurryBranches E = (P : Tag E → Set) (X : Set) → UncurriedBranches E P X → CurriedBranches E P X

curryBranches : (E : Enum) → CurryBranches E
curryBranches = elimEnum CurryBranches
  (λ P X f → f tt)
  (λ l E ih P X f c → ih (λ t → P (there t)) X (λ cs → f (c , cs)))

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

UncurriedScope : (T : Tel) (X : Scope T → Set) → Set
UncurriedScope T X = (xs : Scope T) → X xs

CurriedScope : (T : Tel) (X : Scope T → Set) → Set
CurriedScope = elimTel
  (λ T → (X : Scope T → Set) → Set)
  (λ X → X tt)
  (λ A B ih X → (a : A) → ih a (λ b → X (a , b)))

CurryScope : Tel → Set
CurryScope T = (X : Scope T → Set) → UncurriedScope T X → CurriedScope T X

curryScope : (T : Tel) → CurryScope T
curryScope = elimTel CurryScope
  (λ X f → f tt)
  (λ A B ih X f a → ih a (λ b → X (a , b)) (λ b → f (a , b)))

UncurryScope : Tel → Set
UncurryScope T = (X : Scope T → Set) → CurriedScope T X → UncurriedScope T X

uncurryScope : (T : Tel) → UncurryScope T
uncurryScope = elimTel UncurryScope
  (λ X x → elimUnit X x)
  (λ A B ih X f → elimPair A (λ a → Scope (B a)) X (λ a b → ih a (λ b → X (a , b)) (f a) b))

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

UncurriedFunc : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedFunc I D X = (i : I) → Func I D X i → X i

CurriedFuncM : (I : Set) → Desc I → Set
CurriedFuncM I _ = (X : ISet I) → Set

CurriedFunc : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedFunc I = elimDesc I (CurriedFuncM I)
  (λ i X → X i)
  (λ i D ih X → (x : X i) → ih X)
  (λ A B ih X → (a : A) → ih a X)

CurryFunc : (I : Set) → Desc I → Set
CurryFunc I D = (X : ISet I) → UncurriedFunc I D X → CurriedFunc I D X

curryFunc : (I : Set) (D : Desc I) → CurryFunc I D
curryFunc I = elimDesc I (CurryFunc I)
  (λ i X cn → cn i refl)
  (λ i D ih X cn x → ih X (λ j xs → cn j (x , xs)))
  (λ A B ih X cn a → ih a X (λ j xs → cn j (a , xs)))

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

UncurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedFunc I D X)
  → Set
UncurriedHyps I D X P cn =
  (i : I) (xs : Func I D X i) (ihs : Hyps I D X P i xs) → P i (cn i xs)

CurriedHypsM : (I : Set) (D : Desc I) → Set
CurriedHypsM I D = (X : ISet I) (P : (i : I) → X i → Set) (cn : UncurriedFunc I D X) → Set

CurriedHyps : (I : Set) (D : Desc I) → CurriedHypsM I D
CurriedHyps I = elimDesc I (CurriedHypsM I)
  (λ i X P cn → P i (cn i refl))
  (λ i D ih X P cn → (x : X i) → P i x → ih X P (λ j xs → cn j (x , xs)))
  (λ A B ih X P cn → (a : A) → ih a X P (λ j xs → cn j (a , xs)))

UncurryHyps : (I : Set) (D : Desc I) → Set
UncurryHyps I D = (X : ISet I) (P : (i : I) → X i → Set) (cn : UncurriedFunc I D X)
  → CurriedHyps I D X P cn → UncurriedHyps I D X P cn

uncurryHyps : (I : Set) (D : Desc I) → UncurryHyps I D
uncurryHyps I = elimDesc I (UncurryHyps I)
  (λ j X P cn pf i q u → elimEq I j
   (λ k r → P k (cn k r))
   pf i q
  )
  (λ j D ih X P cn pf i → elimPair (X j)
    (λ _ → Func I D X i)
    (λ xs → Hyps I (Rec j D) X P i xs → P i (cn i xs))
    (λ x xs → elimPair (P j x)
      (λ _ → Hyps I D X P i xs)
      (λ _ → P i (cn i (x , xs)))
      (λ p ps → ih X P (λ j ys → cn j (x , ys))
        (pf x p) i xs ps
      )
    )
  )
  (λ A B ih X P cn pf i → elimPair A
    (λ a → Func I (B a) X i)
    (λ xs → Hyps I (Arg A (λ a → B a)) X P i xs → P i (cn i xs))
    (λ a xs → ih a X P (λ j ys → cn j (a , ys))
      (pf a) i xs
    )
  )

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

BranchesD : Enum → Tel → Set
BranchesD E T = Branches E (λ _ → Desc (Scope T))

caseD : (E : Enum) (T : Tel) (cs : BranchesD E T) (t : Tag E) → Desc (Scope T)
caseD E T = case E (λ _ → Desc (Scope T))

sumD : (E : Enum) (T : Tel) (cs : BranchesD E T) → Desc (Scope T)
sumD E T cs = Arg (Tag E) (λ t → caseD E T cs t)

Indices : Tel → Set
Indices P = Scope P → Tel

indices : (P : Tel) → CurriedScope P (λ _ → Tel) → Indices P
indices P I = uncurryScope P (λ p → Tel) I

Constrs : (E : Enum) (P : Tel) (I : Indices P) → Set
Constrs E P I = (p : Scope P) → BranchesD E (I p)

constrs : (E : Enum) (P : Tel) (I : Indices P) → CurriedScope P (λ p → BranchesD E (I p)) → Constrs E P I
constrs E P I C = uncurryScope P (λ p → BranchesD E (I p)) C

Data : (X : (N : String) (E : Enum) (P : Tel) (I : Indices P) (C : Constrs E P I) → Set)
  → Set
Data X = (N : String) (E : Enum) (P : Tel) (I : Indices P) (C : Constrs E P I)
  → X N E P I C

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

FormUncurried : Data λ N E P I C
  → UncurriedScope P λ p
  → UncurriedScope (I p) λ i
  → Set
FormUncurried N E P I C p =
  μ N (Scope P) (Scope (I p)) (sumD E (I p) (C p)) p

Former : (P : Tel) → Indices P → Set
Former P I = CurriedScope P λ p → CurriedScope (I p) λ i → Set

Form : Data λ N E P I C → Former P I
Form N E P I C =
  curryScope P (λ p → CurriedScope (I p) λ i → Set) λ p →
  curryScope (I p) (λ i → Set) λ i →
  FormUncurried N E P I C p i

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

injUncurried : Data λ N E P I C
  → (t : Tag E)
  → UncurriedScope P λ p
  → CurriedFunc (Scope (I p)) (caseD E (I p) (C p) t) (FormUncurried N E P I C p)
injUncurried N E P I C t p = curryFunc (Scope (I p)) (caseD E (I p) (C p) t)
  (FormUncurried N E P I C p)
  (λ i xs → init (t , xs))

Inj : Data λ N E P I C → (t : Tag E) → Set
Inj N E P I C t = CurriedScope P λ p
  → CurriedFunc (Scope (I p)) (caseD E (I p) (C p) t) (FormUncurried N E P I C p)

inj : Data λ N E P I C → (t : Tag E) → Inj N E P I C t
inj N E P I C t = curryScope P
  (λ p → CurriedFunc (Scope (I p)) (caseD E (I p) (C p) t) (FormUncurried N E P I C p))
  (injUncurried N E P I C t)

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

indCurried : (ℓ : String) (P I : Set) (D : Desc I) (p : P)
  (M : (i : I) → μ ℓ P I D p i → Set)
  (f : CurriedHyps I D (μ ℓ P I D p) M (λ _ xs → init xs))
  (i : I) (x : μ ℓ P I D p i) → M i x
indCurried ℓ P I D p M f i x =
  ind ℓ P I D p M (uncurryHyps I D (μ ℓ P I D p) M (λ _ xs → init xs) f) i x

SumCurriedHyps : Data λ N E P I C
  → UncurriedScope P λ p
  → (M : CurriedScope (I p) (λ i → FormUncurried N E P I C p i → Set))
  → Tag E → Set
SumCurriedHyps N E P I C p M t =
  let unM = uncurryScope (I p) (λ i → FormUncurried N E P I C p i → Set) M in
  CurriedHyps (Scope (I p)) (caseD E (I p) (C p) t)
    (FormUncurried N E P I C p) unM (λ i xs → init (t , xs))

elimUncurried : Data λ N E P I C
  → UncurriedScope P λ p
  → (M : CurriedScope (I p) (λ i → FormUncurried N E P I C p i → Set))
  → let unM = uncurryScope (I p) (λ i → FormUncurried N E P I C p i → Set) M
  in UncurriedBranches E
     (SumCurriedHyps N E P I C p M)
     (CurriedScope (I p) (λ i → (x : FormUncurried N E P I C p i) → unM i x))
elimUncurried N E P I C p M cs = let
    unM = uncurryScope (I p) (λ i → FormUncurried N E P I C p i → Set) M
  in
  curryScope (I p) (λ i → (x : FormUncurried N E P I C p i) → unM i x)
  (indCurried N (Scope P) (Scope (I p)) (sumD E (I p) (C p)) p unM
    (case E (SumCurriedHyps N E P I C p M) cs))

Elim : Data λ N E P I C → Set
Elim N E P I C = CurriedScope P λ p
  → (M : CurriedScope (I p) (λ i → FormUncurried N E P I C p i → Set))
  → let unM = uncurryScope (I p) (λ i → FormUncurried N E P I C p i → Set) M
  in CurriedBranches E
     (SumCurriedHyps N E P I C p M)
     (CurriedScope (I p) (λ i → (x : FormUncurried N E P I C p i) → unM i x))

elim : Data λ N E P I C → Elim N E P I C
elim N E P I C = curryScope P
  (λ p → (M : CurriedScope (I p) (λ i → FormUncurried N E P I C p i → Set))
    → let unM = uncurryScope (I p) (λ i → FormUncurried N E P I C p i → Set) M
    in CurriedBranches E
       (SumCurriedHyps N E P I C p M)
       (CurriedScope (I p) (λ i → (x : FormUncurried N E P I C p i) → unM i x)))
  (λ p M → let unM = uncurryScope (I p) (λ i → FormUncurried N E P I C p i → Set) M
    in curryBranches E
    (SumCurriedHyps N E P I C p M)
    (CurriedScope (I p) (λ i → (x : FormUncurried N E P I C p i) → unM i x))
    (elimUncurried N E P I C p M))

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


{-# OPTIONS --rewriting #-}

module Properties.StrictMode where

import Agda.Builtin.Equality.Rewrite
open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.Either using (Either; Left; Right; mapL; mapR; mapLR; swapLR; cond)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import Luau.Heap using (Heap; Object; function_is_end; defn; alloc; ok; next; lookup-not-allocated) renaming (_≡_⊕_↦_ to _≡ᴴ_⊕_↦_; _[_] to _[_]ᴴ; ∅ to ∅ᴴ)
open import Luau.StrictMode using (Warningᴱ; Warningᴮ; Warningᴼ; Warningᴴ; UnallocatedAddress; UnboundVariable; FunctionCallMismatch; app₁; app₂; BinOpMismatch₁; BinOpMismatch₂; bin₁; bin₂; BlockMismatch; block₁; return; LocalVarMismatch; local₁; local₂; FunctionDefnMismatch; function₁; function₂; heap; expr; block; addr)
open import Luau.Substitution using (_[_/_]ᴮ; _[_/_]ᴱ; _[_/_]ᴮunless_; var_[_/_]ᴱwhenever_)
open import Luau.Subtyping using (_≮:_; witness; unknown; never; scalar; function; scalar-function; scalar-function-ok; scalar-function-err; scalar-scalar; function-scalar; function-ok; function-err; left; right; _,_; Tree; Language; ¬Language)
open import Luau.Syntax using (Expr; yes; var; val; var_∈_; _⟨_⟩∈_; _$_; addr; number; bool; string; binexp; nil; function_is_end; block_is_end; done; return; local_←_; _∙_; fun; arg; name; ==; ~=)
open import Luau.Type using (Type; nil; number; boolean; string; _⇒_; never; unknown; _∩_; _∪_; src; tgt; _≡ᵀ_; _≡ᴹᵀ_)
open import Luau.TypeCheck using (_⊢ᴮ_∈_; _⊢ᴱ_∈_; _⊢ᴴᴮ_▷_∈_; _⊢ᴴᴱ_▷_∈_; nil; var; addr; app; function; block; done; return; local; orUnknown; srcBinOp; tgtBinOp)
open import Luau.Var using (_≡ⱽ_)
open import Luau.Addr using (_≡ᴬ_)
open import Luau.VarCtxt using (VarCtxt; ∅; _⋒_; _↦_; _⊕_↦_; _⊝_; ⊕-lookup-miss; ⊕-swap; ⊕-over) renaming (_[_] to _[_]ⱽ)
open import Luau.VarCtxt using (VarCtxt; ∅)
open import Properties.Remember using (remember; _,_)
open import Properties.Equality using (_≢_; sym; cong; trans; subst₁)
open import Properties.Dec using (Dec; yes; no)
open import Properties.Contradiction using (CONTRADICTION; ¬)
open import Properties.Functions using (_∘_)
open import Properties.Subtyping using (unknown-≮:; ≡-trans-≮:; ≮:-trans-≡; never-tgt-≮:; tgt-never-≮:; src-unknown-≮:; unknown-src-≮:; ≮:-trans; ≮:-refl; scalar-≢-impl-≮:; function-≮:-scalar; scalar-≮:-function; function-≮:-never; unknown-≮:-scalar; scalar-≮:-never; unknown-≮:-never)
open import Properties.TypeCheck using (typeOfᴼ; typeOfᴹᴼ; typeOfⱽ; typeOfᴱ; typeOfᴮ; typeCheckᴱ; typeCheckᴮ; typeCheckᴼ; typeCheckᴴ)
open import Luau.OpSem using (_⟦_⟧_⟶_; _⊢_⟶*_⊣_; _⊢_⟶ᴮ_⊣_; _⊢_⟶ᴱ_⊣_; app₁; app₂; function; beta; return; block; done; local; subst; binOp₀; binOp₁; binOp₂; refl; step; +; -; *; /; <; >; ==; ~=; <=; >=; ··)
open import Luau.RuntimeError using (BinOpError; RuntimeErrorᴱ; RuntimeErrorᴮ; FunctionMismatch; BinOpMismatch₁; BinOpMismatch₂; UnboundVariable; SEGV; app₁; app₂; bin₁; bin₂; block; local; return; +; -; *; /; <; >; <=; >=; ··)
open import Luau.RuntimeType using (RuntimeType; valueType; number; string; boolean; nil; function)

data _⊑_ (H : Heap yes) : Heap yes → Set where
  refl : (H ⊑ H)
  snoc : ∀ {H′ a O} → (H′ ≡ᴴ H ⊕ a ↦ O) → (H ⊑ H′)

rednᴱ⊑ : ∀ {H H′ M M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → (H ⊑ H′)
rednᴮ⊑ : ∀ {H H′ B B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → (H ⊑ H′)

rednᴱ⊑ (function a p) = snoc p
rednᴱ⊑ (app₁ s) = rednᴱ⊑ s
rednᴱ⊑ (app₂ p s) = rednᴱ⊑ s
rednᴱ⊑ (beta O v p q) = refl
rednᴱ⊑ (block s) = rednᴮ⊑ s
rednᴱ⊑ (return v) = refl
rednᴱ⊑ done = refl
rednᴱ⊑ (binOp₀ p) = refl
rednᴱ⊑ (binOp₁ s) = rednᴱ⊑ s
rednᴱ⊑ (binOp₂ s) = rednᴱ⊑ s

rednᴮ⊑ (local s) = rednᴱ⊑ s
rednᴮ⊑ (subst v) = refl
rednᴮ⊑ (function a p) = snoc p
rednᴮ⊑ (return s) = rednᴱ⊑ s

data LookupResult (H : Heap yes) a V : Set where
  just : (H [ a ]ᴴ ≡ just V) → LookupResult H a V
  nothing : (H [ a ]ᴴ ≡ nothing) → LookupResult H a V

lookup-⊑-nothing : ∀ {H H′} a → (H ⊑ H′) → (H′ [ a ]ᴴ ≡ nothing) → (H [ a ]ᴴ ≡ nothing)
lookup-⊑-nothing {H} a refl p = p
lookup-⊑-nothing {H} a (snoc defn) p with a ≡ᴬ next H
lookup-⊑-nothing {H} a (snoc defn) p | yes refl = refl
lookup-⊑-nothing {H} a (snoc o) p | no q = trans (lookup-not-allocated o q) p

heap-weakeningᴱ : ∀ Γ H M {H′ U} → (H ⊑ H′) → (typeOfᴱ H′ Γ M ≮: U) → (typeOfᴱ H Γ M ≮: U)
heap-weakeningᴱ Γ H (var x) h p = p
heap-weakeningᴱ Γ H (val nil) h p = p
heap-weakeningᴱ Γ H (val (addr a)) refl p = p
heap-weakeningᴱ Γ H (val (addr a)) (snoc {a = b} q) p with a ≡ᴬ b
heap-weakeningᴱ Γ H (val (addr a)) (snoc {a = a} defn) p | yes refl = unknown-≮: p
heap-weakeningᴱ Γ H (val (addr a)) (snoc {a = b} q) p | no r = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ (lookup-not-allocated q r))) p
heap-weakeningᴱ Γ H (val (number x)) h p = p
heap-weakeningᴱ Γ H (val (bool x)) h p = p
heap-weakeningᴱ Γ H (val (string x)) h p = p
heap-weakeningᴱ Γ H (M $ N) h p = never-tgt-≮: (heap-weakeningᴱ Γ H M h (tgt-never-≮: p))
heap-weakeningᴱ Γ H (function f ⟨ var x ∈ T ⟩∈ U is B end) h p = p
heap-weakeningᴱ Γ H (block var b ∈ T is B end) h p = p
heap-weakeningᴱ Γ H (binexp M op N) h p = p

heap-weakeningᴮ : ∀ Γ H B {H′ U} → (H ⊑ H′) → (typeOfᴮ H′ Γ B ≮: U) → (typeOfᴮ H Γ B ≮: U)
heap-weakeningᴮ Γ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h p = heap-weakeningᴮ (Γ ⊕ f ↦ (T ⇒ U)) H B h p
heap-weakeningᴮ Γ H (local var x ∈ T ← M ∙ B) h p = heap-weakeningᴮ (Γ ⊕ x ↦ T) H B h p
heap-weakeningᴮ Γ H (return M ∙ B) h p = heap-weakeningᴱ Γ H M h p
heap-weakeningᴮ Γ H done h p = p

substitutivityᴱ : ∀ {Γ T U} H M v x → (typeOfᴱ H Γ (M [ v / x ]ᴱ) ≮: U) → Either (typeOfᴱ H (Γ ⊕ x ↦ T) M ≮: U) (typeOfᴱ H ∅ (val v) ≮: T)
substitutivityᴱ-whenever : ∀ {Γ T U} H v x y (r : Dec(x ≡ y)) → (typeOfᴱ H Γ (var y [ v / x ]ᴱwhenever r) ≮: U) → Either (typeOfᴱ H (Γ ⊕ x ↦ T) (var y) ≮: U) (typeOfᴱ H ∅ (val v) ≮: T)
substitutivityᴮ : ∀ {Γ T U} H B v x → (typeOfᴮ H Γ (B [ v / x ]ᴮ) ≮: U) → Either (typeOfᴮ H (Γ ⊕ x ↦ T) B ≮: U) (typeOfᴱ H ∅ (val v) ≮: T)
substitutivityᴮ-unless : ∀ {Γ T U V} H B v x y (r : Dec(x ≡ y)) → (typeOfᴮ H (Γ ⊕ y ↦ U) (B [ v / x ]ᴮunless r) ≮: V) → Either (typeOfᴮ H ((Γ ⊕ x ↦ T) ⊕ y ↦ U) B ≮: V) (typeOfᴱ H ∅ (val v) ≮: T)
substitutivityᴮ-unless-yes : ∀ {Γ Γ′ T V} H B v x y (r : x ≡ y) → (Γ′ ≡ Γ) → (typeOfᴮ H Γ (B [ v / x ]ᴮunless yes r) ≮: V) → Either (typeOfᴮ H Γ′ B ≮: V) (typeOfᴱ H ∅ (val v) ≮: T)
substitutivityᴮ-unless-no : ∀ {Γ Γ′ T V} H B v x y (r : x ≢ y) → (Γ′ ≡ Γ ⊕ x ↦ T) → (typeOfᴮ H Γ (B [ v / x ]ᴮunless no r) ≮: V) → Either (typeOfᴮ H Γ′ B ≮: V) (typeOfᴱ H ∅ (val v) ≮: T)

substitutivityᴱ H (var y) v x p = substitutivityᴱ-whenever H v x y (x ≡ⱽ y) p
substitutivityᴱ H (val w) v x p = Left p
substitutivityᴱ H (binexp M op N) v x p = Left p
substitutivityᴱ H (M $ N) v x p = mapL never-tgt-≮: (substitutivityᴱ H M v x (tgt-never-≮: p))
substitutivityᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p = Left p
substitutivityᴱ H (block var b ∈ T is B end) v x p = Left p
substitutivityᴱ-whenever H v x x (yes refl) q = swapLR (≮:-trans q)
substitutivityᴱ-whenever H v x y (no p) q = Left (≡-trans-≮: (cong orUnknown (sym (⊕-lookup-miss x y _ _ p))) q)

substitutivityᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p = substitutivityᴮ-unless H B v x f (x ≡ⱽ f) p
substitutivityᴮ H (local var y ∈ T ← M ∙ B) v x p = substitutivityᴮ-unless H B v x y (x ≡ⱽ y) p
substitutivityᴮ H (return M ∙ B) v x p = substitutivityᴱ H M v x p
substitutivityᴮ H done v x p = Left p
substitutivityᴮ-unless H B v x y (yes p) q = substitutivityᴮ-unless-yes H B v x y p (⊕-over p) q
substitutivityᴮ-unless H B v x y (no p) q = substitutivityᴮ-unless-no H B v x y p (⊕-swap p) q
substitutivityᴮ-unless-yes H B v x y refl refl p = Left p
substitutivityᴮ-unless-no H B v x y p refl q = substitutivityᴮ H B v x q

binOpPreservation : ∀ H {op v w x} → (v ⟦ op ⟧ w ⟶ x) → (tgtBinOp op ≡ typeOfᴱ H ∅ (val x))
binOpPreservation H (+ m n) = refl
binOpPreservation H (- m n) = refl
binOpPreservation H (/ m n) = refl
binOpPreservation H (* m n) = refl
binOpPreservation H (< m n) = refl
binOpPreservation H (> m n) = refl
binOpPreservation H (<= m n) = refl
binOpPreservation H (>= m n) = refl
binOpPreservation H (== v w) = refl
binOpPreservation H (~= v w) = refl
binOpPreservation H (·· v w) = refl

reflect-subtypingᴱ : ∀ H M {H′ M′ T} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → (typeOfᴱ H′ ∅ M′ ≮: T) → Either (typeOfᴱ H ∅ M ≮: T) (Warningᴱ H (typeCheckᴱ H ∅ M))
reflect-subtypingᴮ : ∀ H B {H′ B′ T} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → (typeOfᴮ H′ ∅ B′ ≮: T) → Either (typeOfᴮ H ∅ B ≮: T) (Warningᴮ H (typeCheckᴮ H ∅ B))

reflect-subtypingᴱ H (M $ N) (app₁ s) p = mapLR never-tgt-≮: app₁ (reflect-subtypingᴱ H M s (tgt-never-≮: p))
reflect-subtypingᴱ H (M $ N) (app₂ v s) p = Left (never-tgt-≮: (heap-weakeningᴱ ∅ H M (rednᴱ⊑ s) (tgt-never-≮: p)))
reflect-subtypingᴱ H (M $ N) (beta (function f ⟨ var y ∈ T ⟩∈ U is B end) v refl q) p = Left (≡-trans-≮: (cong tgt (cong orUnknown (cong typeOfᴹᴼ q))) p)
reflect-subtypingᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) p = Left p
reflect-subtypingᴱ H (block var b ∈ T is B end) (block s) p = Left p
reflect-subtypingᴱ H (block var b ∈ T is return (val v) ∙ B end) (return v) p = mapR BlockMismatch (swapLR (≮:-trans p))
reflect-subtypingᴱ H (block var b ∈ T is done end) done p = mapR BlockMismatch (swapLR (≮:-trans p))
reflect-subtypingᴱ H (binexp M op N) (binOp₀ s) p = Left (≡-trans-≮: (binOpPreservation H s) p)
reflect-subtypingᴱ H (binexp M op N) (binOp₁ s) p = Left p
reflect-subtypingᴱ H (binexp M op N) (binOp₂ s) p = Left p

reflect-subtypingᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a defn) p = mapLR (heap-weakeningᴮ _ _ B (snoc defn)) (CONTRADICTION ∘ ≮:-refl) (substitutivityᴮ _ B (addr a) f p)
reflect-subtypingᴮ H (local var x ∈ T ← M ∙ B) (local s) p = Left (heap-weakeningᴮ (x ↦ T) H B (rednᴱ⊑ s) p)
reflect-subtypingᴮ H (local var x ∈ T ← M ∙ B) (subst v) p = mapR LocalVarMismatch (substitutivityᴮ H B v x p)
reflect-subtypingᴮ H (return M ∙ B) (return s) p = mapR return (reflect-subtypingᴱ H M s p)

reflect-substitutionᴱ : ∀ {Γ T} H M v x → Warningᴱ H (typeCheckᴱ H Γ (M [ v / x ]ᴱ)) → Either (Warningᴱ H (typeCheckᴱ H (Γ ⊕ x ↦ T) M)) (Either (Warningᴱ H (typeCheckᴱ H ∅ (val v))) (typeOfᴱ H ∅ (val v) ≮: T))
reflect-substitutionᴱ-whenever : ∀ {Γ T} H v x y (p : Dec(x ≡ y)) → Warningᴱ H (typeCheckᴱ H Γ (var y [ v / x ]ᴱwhenever p)) → Either (Warningᴱ H (typeCheckᴱ H (Γ ⊕ x ↦ T) (var y))) (Either (Warningᴱ H (typeCheckᴱ H ∅ (val v))) (typeOfᴱ H ∅ (val v) ≮: T))
reflect-substitutionᴮ : ∀ {Γ T} H B v x → Warningᴮ H (typeCheckᴮ H Γ (B [ v / x ]ᴮ)) → Either (Warningᴮ H (typeCheckᴮ H (Γ ⊕ x ↦ T) B)) (Either (Warningᴱ H (typeCheckᴱ H ∅ (val v))) (typeOfᴱ H ∅ (val v) ≮: T))
reflect-substitutionᴮ-unless : ∀ {Γ T U} H B v x y (r : Dec(x ≡ y)) → Warningᴮ H (typeCheckᴮ H (Γ ⊕ y ↦ U) (B [ v / x ]ᴮunless r)) → Either (Warningᴮ H (typeCheckᴮ H ((Γ ⊕ x ↦ T) ⊕ y ↦ U) B)) (Either (Warningᴱ H (typeCheckᴱ H ∅ (val v))) (typeOfᴱ H ∅ (val v) ≮: T))
reflect-substitutionᴮ-unless-yes : ∀ {Γ Γ′ T} H B v x y (r : x ≡ y) → (Γ′ ≡ Γ) → Warningᴮ H (typeCheckᴮ H Γ (B [ v / x ]ᴮunless yes r)) → Either (Warningᴮ H (typeCheckᴮ H Γ′ B)) (Either (Warningᴱ H (typeCheckᴱ H ∅ (val v))) (typeOfᴱ H ∅ (val v) ≮: T))
reflect-substitutionᴮ-unless-no : ∀ {Γ Γ′ T} H B v x y (r : x ≢ y) → (Γ′ ≡ Γ ⊕ x ↦ T) → Warningᴮ H (typeCheckᴮ H Γ (B [ v / x ]ᴮunless no r)) → Either (Warningᴮ H (typeCheckᴮ H Γ′ B)) (Either (Warningᴱ H (typeCheckᴱ H ∅ (val v))) (typeOfᴱ H ∅ (val v) ≮: T))

reflect-substitutionᴱ H (var y) v x W = reflect-substitutionᴱ-whenever H v x y (x ≡ⱽ y) W
reflect-substitutionᴱ H (val (addr a)) v x (UnallocatedAddress r) = Left (UnallocatedAddress r)
reflect-substitutionᴱ H (M $ N) v x (FunctionCallMismatch p) with substitutivityᴱ H N v x p
reflect-substitutionᴱ H (M $ N) v x (FunctionCallMismatch p) | Right W = Right (Right W)
reflect-substitutionᴱ H (M $ N) v x (FunctionCallMismatch p) | Left q with substitutivityᴱ H M v x (src-unknown-≮: q)
reflect-substitutionᴱ H (M $ N) v x (FunctionCallMismatch p) | Left q | Left r = Left ((FunctionCallMismatch ∘ unknown-src-≮: q) r)
reflect-substitutionᴱ H (M $ N) v x (FunctionCallMismatch p) | Left q | Right W = Right (Right W)
reflect-substitutionᴱ H (M $ N) v x (app₁ W) = mapL app₁ (reflect-substitutionᴱ H M v x W)
reflect-substitutionᴱ H (M $ N) v x (app₂ W) = mapL app₂ (reflect-substitutionᴱ H N v x W)
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x (FunctionDefnMismatch q) = mapLR FunctionDefnMismatch Right (substitutivityᴮ-unless H B v x y (x ≡ⱽ y) q)
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x (function₁ W) = mapL function₁ (reflect-substitutionᴮ-unless H B v x y (x ≡ⱽ y) W)
reflect-substitutionᴱ H (block var b ∈ T is B end) v x (BlockMismatch q) =  mapLR BlockMismatch Right (substitutivityᴮ H B v x q)
reflect-substitutionᴱ H (block var b ∈ T is B end) v x (block₁ W′) = mapL block₁ (reflect-substitutionᴮ H B v x W′)
reflect-substitutionᴱ H (binexp M op N) v x (BinOpMismatch₁ q) = mapLR BinOpMismatch₁ Right (substitutivityᴱ H M v x q)
reflect-substitutionᴱ H (binexp M op N) v x (BinOpMismatch₂ q) = mapLR BinOpMismatch₂ Right (substitutivityᴱ H N v x q)
reflect-substitutionᴱ H (binexp M op N) v x (bin₁ W) = mapL bin₁ (reflect-substitutionᴱ H M v x W)
reflect-substitutionᴱ H (binexp M op N) v x (bin₂ W) = mapL bin₂ (reflect-substitutionᴱ H N v x W)

reflect-substitutionᴱ-whenever H a x x (yes refl) (UnallocatedAddress p) = Right (Left (UnallocatedAddress p))
reflect-substitutionᴱ-whenever H v x y (no p) (UnboundVariable q) = Left (UnboundVariable (trans (sym (⊕-lookup-miss x y _ _ p)) q))

reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x (FunctionDefnMismatch q) = mapLR FunctionDefnMismatch Right (substitutivityᴮ-unless H C v x y (x ≡ⱽ y) q)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x (function₁ W) =  mapL function₁ (reflect-substitutionᴮ-unless H C v x y (x ≡ⱽ y) W)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x (function₂ W) = mapL function₂ (reflect-substitutionᴮ-unless H B v x f (x ≡ⱽ f) W)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x (LocalVarMismatch q) = mapLR LocalVarMismatch Right (substitutivityᴱ H M v x q)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x (local₁ W) = mapL local₁ (reflect-substitutionᴱ H M v x W)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x (local₂ W) = mapL local₂ (reflect-substitutionᴮ-unless H B v x y (x ≡ⱽ y) W)
reflect-substitutionᴮ H (return M ∙ B) v x (return W) = mapL return (reflect-substitutionᴱ H M v x W)

reflect-substitutionᴮ-unless H B v x y (yes p) W = reflect-substitutionᴮ-unless-yes H B v x y p (⊕-over p) W
reflect-substitutionᴮ-unless H B v x y (no p) W = reflect-substitutionᴮ-unless-no H B v x y p (⊕-swap p) W
reflect-substitutionᴮ-unless-yes H B v x x refl refl W = Left W
reflect-substitutionᴮ-unless-no H B v x y p refl W = reflect-substitutionᴮ H B v x W

reflect-weakeningᴱ : ∀ Γ H M {H′} → (H ⊑ H′) → Warningᴱ H′ (typeCheckᴱ H′ Γ M) → Warningᴱ H (typeCheckᴱ H Γ M)
reflect-weakeningᴮ : ∀ Γ H B {H′} → (H ⊑ H′) → Warningᴮ H′ (typeCheckᴮ H′ Γ B) → Warningᴮ H (typeCheckᴮ H Γ B)

reflect-weakeningᴱ Γ H (var x) h (UnboundVariable p) = (UnboundVariable p)
reflect-weakeningᴱ Γ H (val (addr a)) h (UnallocatedAddress p) = UnallocatedAddress (lookup-⊑-nothing a h p)
reflect-weakeningᴱ Γ H (M $ N) h (FunctionCallMismatch p) = FunctionCallMismatch (heap-weakeningᴱ Γ H N h (unknown-src-≮: p (heap-weakeningᴱ Γ H M h (src-unknown-≮: p))))
reflect-weakeningᴱ Γ H (M $ N) h (app₁ W) = app₁ (reflect-weakeningᴱ Γ H M h W)
reflect-weakeningᴱ Γ H (M $ N) h (app₂ W) = app₂ (reflect-weakeningᴱ Γ H N h W)
reflect-weakeningᴱ Γ H (binexp M op N) h (BinOpMismatch₁ p) = BinOpMismatch₁ (heap-weakeningᴱ Γ H M h p)
reflect-weakeningᴱ Γ H (binexp M op N) h (BinOpMismatch₂ p) = BinOpMismatch₂ (heap-weakeningᴱ Γ H N h p)
reflect-weakeningᴱ Γ H (binexp M op N) h (bin₁ W′) = bin₁ (reflect-weakeningᴱ Γ H M h W′)
reflect-weakeningᴱ Γ H (binexp M op N) h (bin₂ W′) = bin₂ (reflect-weakeningᴱ Γ H N h W′)
reflect-weakeningᴱ Γ H (function f ⟨ var y ∈ T ⟩∈ U is B end) h (FunctionDefnMismatch p) = FunctionDefnMismatch (heap-weakeningᴮ (Γ ⊕ y ↦ T) H B h p)
reflect-weakeningᴱ Γ H (function f ⟨ var y ∈ T ⟩∈ U is B end) h (function₁ W) = function₁ (reflect-weakeningᴮ (Γ ⊕ y ↦ T) H B h W)
reflect-weakeningᴱ Γ H (block var b ∈ T is B end) h (BlockMismatch p) = BlockMismatch (heap-weakeningᴮ Γ H B h p)
reflect-weakeningᴱ Γ H (block var b ∈ T is B end) h (block₁ W) = block₁ (reflect-weakeningᴮ Γ H B h W)

reflect-weakeningᴮ Γ H (return M ∙ B) h (return W) = return (reflect-weakeningᴱ Γ H M h W)
reflect-weakeningᴮ Γ H (local var y ∈ T ← M ∙ B) h (LocalVarMismatch p) = LocalVarMismatch (heap-weakeningᴱ Γ H M h p)
reflect-weakeningᴮ Γ H (local var y ∈ T ← M ∙ B) h (local₁ W) = local₁ (reflect-weakeningᴱ Γ H M h W)
reflect-weakeningᴮ Γ H (local var y ∈ T ← M ∙ B) h (local₂ W) = local₂ (reflect-weakeningᴮ (Γ ⊕ y ↦ T) H B h W)
reflect-weakeningᴮ Γ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (FunctionDefnMismatch p) = FunctionDefnMismatch (heap-weakeningᴮ (Γ ⊕ x ↦ T) H C h p)
reflect-weakeningᴮ Γ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (function₁ W) = function₁ (reflect-weakeningᴮ (Γ ⊕ x ↦ T) H C h W)
reflect-weakeningᴮ Γ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (function₂ W) = function₂ (reflect-weakeningᴮ (Γ ⊕ f ↦ (T ⇒ U)) H B h W)

reflect-weakeningᴼ : ∀ H O {H′} → (H ⊑ H′) → Warningᴼ H′ (typeCheckᴼ H′ O) → Warningᴼ H (typeCheckᴼ H O)
reflect-weakeningᴼ H (just function f ⟨ var x ∈ T ⟩∈ U is B end) h (FunctionDefnMismatch p) = FunctionDefnMismatch (heap-weakeningᴮ (x ↦ T) H B h p)
reflect-weakeningᴼ H (just function f ⟨ var x ∈ T ⟩∈ U is B end) h (function₁ W) = function₁ (reflect-weakeningᴮ (x ↦ T) H B h W)

reflectᴱ : ∀ H M {H′ M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → Warningᴱ H′ (typeCheckᴱ H′ ∅ M′) → Either (Warningᴱ H (typeCheckᴱ H ∅ M)) (Warningᴴ H (typeCheckᴴ H))
reflectᴮ : ∀ H B {H′ B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → Warningᴮ H′ (typeCheckᴮ H′ ∅ B′) → Either (Warningᴮ H (typeCheckᴮ H ∅ B)) (Warningᴴ H (typeCheckᴴ H))

reflectᴱ H (M $ N) (app₁ s) (FunctionCallMismatch p) = cond (Left ∘ FunctionCallMismatch ∘ heap-weakeningᴱ ∅ H N (rednᴱ⊑ s) ∘ unknown-src-≮: p) (Left ∘ app₁) (reflect-subtypingᴱ H M s (src-unknown-≮: p))
reflectᴱ H (M $ N) (app₁ s) (app₁ W′) = mapL app₁ (reflectᴱ H M s W′)
reflectᴱ H (M $ N) (app₁ s) (app₂ W′) = Left (app₂ (reflect-weakeningᴱ ∅ H N (rednᴱ⊑ s) W′))
reflectᴱ H (M $ N) (app₂ p s) (FunctionCallMismatch q) = cond (λ r → Left (FunctionCallMismatch (unknown-src-≮: r (heap-weakeningᴱ ∅ H M (rednᴱ⊑ s) (src-unknown-≮: r))))) (Left ∘ app₂) (reflect-subtypingᴱ H N s q)
reflectᴱ H (M $ N) (app₂ p s) (app₁ W′) = Left (app₁ (reflect-weakeningᴱ ∅ H M (rednᴱ⊑ s) W′))
reflectᴱ H (M $ N) (app₂ p s) (app₂ W′) = mapL app₂ (reflectᴱ H N s W′)
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) with substitutivityᴮ H B v x q
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | Left r = Right (addr a p (FunctionDefnMismatch r))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | Right r = Left (FunctionCallMismatch (≮:-trans-≡ r ((cong src (cong orUnknown (cong typeOfᴹᴼ (sym p)))))))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) with reflect-substitutionᴮ _ B v x W′
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | Left W = Right (addr a p (function₁ W))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | Right (Left W) = Left (app₂ W)
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | Right (Right q) = Left (FunctionCallMismatch (≮:-trans-≡ q (cong src (cong orUnknown (cong typeOfᴹᴼ (sym p))))))
reflectᴱ H (block var b ∈ T is B end) (block s) (BlockMismatch p) = Left (cond BlockMismatch block₁ (reflect-subtypingᴮ H B s p))
reflectᴱ H (block var b ∈ T is B end) (block s) (block₁ W′) = mapL block₁ (reflectᴮ H B s W′)
reflectᴱ H (block var b ∈ T is B end) (return v) W′ = Left (block₁ (return W′))
reflectᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (UnallocatedAddress ())
reflectᴱ H (binexp M op N) (binOp₀ ()) (UnallocatedAddress p)
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₁ p) = Left (cond BinOpMismatch₁ bin₁ (reflect-subtypingᴱ H M s p))
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₂ p) = Left (BinOpMismatch₂ (heap-weakeningᴱ ∅ H N (rednᴱ⊑ s) p))
reflectᴱ H (binexp M op N) (binOp₁ s) (bin₁ W′) = mapL bin₁ (reflectᴱ H M s W′)
reflectᴱ H (binexp M op N) (binOp₁ s) (bin₂ W′) = Left (bin₂ (reflect-weakeningᴱ ∅ H N (rednᴱ⊑ s) W′))
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₁ p) = Left (BinOpMismatch₁ (heap-weakeningᴱ ∅ H M (rednᴱ⊑ s) p))
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₂ p) = Left (cond BinOpMismatch₂ bin₂ (reflect-subtypingᴱ H N s p))
reflectᴱ H (binexp M op N) (binOp₂ s) (bin₁ W′) = Left (bin₁ (reflect-weakeningᴱ ∅ H M (rednᴱ⊑ s) W′))
reflectᴱ H (binexp M op N) (binOp₂ s) (bin₂ W′) = mapL bin₂ (reflectᴱ H N s W′)

reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (LocalVarMismatch p) = Left (cond LocalVarMismatch local₁ (reflect-subtypingᴱ H M s p))
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (local₁ W′) = mapL local₁ (reflectᴱ H M s W′)
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (local₂ W′) = Left (local₂ (reflect-weakeningᴮ (x ↦ T) H B (rednᴱ⊑ s) W′))
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ = Left (cond local₂ (cond local₁ LocalVarMismatch) (reflect-substitutionᴮ H B v x W′))
reflectᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) W′ with reflect-substitutionᴮ _ B (addr a) f W′
reflectᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) W′ | Left W = Left (function₂ (reflect-weakeningᴮ (f ↦ (T ⇒ U)) H B (snoc defn) W))
reflectᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) W′ | Right (Left (UnallocatedAddress ()))
reflectᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) W′ | Right (Right p) = CONTRADICTION (≮:-refl p)
reflectᴮ H (return M ∙ B) (return s) (return W′) = mapL return (reflectᴱ H M s W′)

reflectᴴᴱ : ∀ H M {H′ M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → Warningᴴ H′ (typeCheckᴴ H′) → Either (Warningᴱ H (typeCheckᴱ H ∅ M)) (Warningᴴ H (typeCheckᴴ H))
reflectᴴᴮ : ∀ H B {H′ B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → Warningᴴ H′ (typeCheckᴴ H′) → Either (Warningᴮ H (typeCheckᴮ H ∅ B)) (Warningᴴ H (typeCheckᴴ H))

reflectᴴᴱ H (M $ N) (app₁ s) W = mapL app₁ (reflectᴴᴱ H M s W)
reflectᴴᴱ H (M $ N) (app₂ v s) W = mapL app₂ (reflectᴴᴱ H N s W)
reflectᴴᴱ H (M $ N) (beta O v refl p) W = Right W
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a p) (addr b refl W) with b ≡ᴬ a
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (addr b refl (FunctionDefnMismatch p)) | yes refl = Left (FunctionDefnMismatch (heap-weakeningᴮ (x ↦ T) H B (snoc defn) p))
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (addr b refl (function₁ W)) | yes refl = Left (function₁ (reflect-weakeningᴮ (x ↦ T) H B (snoc defn) W))
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a p) (addr b refl W) | no q = Right (addr b (lookup-not-allocated p q) (reflect-weakeningᴼ H _ (snoc p) W))
reflectᴴᴱ H (block var b ∈ T is B end) (block s) W = mapL block₁ (reflectᴴᴮ H B s W)
reflectᴴᴱ H (block var b ∈ T is return (val v) ∙ B end) (return v) W = Right W
reflectᴴᴱ H (block var b ∈ T is done end) done W = Right W
reflectᴴᴱ H (binexp M op N) (binOp₀ s) W = Right W
reflectᴴᴱ H (binexp M op N) (binOp₁ s) W = mapL bin₁ (reflectᴴᴱ H M s W)
reflectᴴᴱ H (binexp M op N) (binOp₂ s) W = mapL bin₂ (reflectᴴᴱ H N s W)

reflectᴴᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a p) (addr b refl W) with b ≡ᴬ a
reflectᴴᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a defn) (addr b refl (FunctionDefnMismatch p)) | yes refl = Left (FunctionDefnMismatch (heap-weakeningᴮ (x ↦ T) H C (snoc defn) p))
reflectᴴᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a defn) (addr b refl (function₁ W)) | yes refl = Left (function₁ (reflect-weakeningᴮ (x ↦ T) H C (snoc defn) W))
reflectᴴᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a p) (addr b refl W) | no q = Right (addr b (lookup-not-allocated p q) (reflect-weakeningᴼ H _ (snoc p) W))
reflectᴴᴮ H (local var x ∈ T ← M ∙ B) (local s) W = mapL local₁ (reflectᴴᴱ H M s W)
reflectᴴᴮ H (local var x ∈ T ← M ∙ B) (subst v) W = Right W
reflectᴴᴮ H (return M ∙ B) (return s) W = mapL return (reflectᴴᴱ H M s W)

reflect* : ∀ H B {H′ B′} → (H ⊢ B ⟶* B′ ⊣ H′) → Either (Warningᴮ H′ (typeCheckᴮ H′ ∅ B′)) (Warningᴴ H′ (typeCheckᴴ H′)) → Either (Warningᴮ H (typeCheckᴮ H ∅ B)) (Warningᴴ H (typeCheckᴴ H))
reflect* H B refl W = W
reflect* H B (step s t) W = cond (reflectᴮ H B s) (reflectᴴᴮ H B s) (reflect* _ _ t W)

isntNumber : ∀ H v → (valueType v ≢ number) → (typeOfᴱ H ∅ (val v) ≮: number)
isntNumber H nil p = scalar-≢-impl-≮: nil number (λ ())
isntNumber H (addr a) p with remember (H [ a ]ᴴ)
isntNumber H (addr a) p | (just (function f ⟨ var x ∈ T ⟩∈ U is B end) , q) = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ q)) (function-≮:-scalar number)
isntNumber H (addr a) p | (nothing , q) = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ q)) (unknown-≮:-scalar number)
isntNumber H (number x) p = CONTRADICTION (p refl)
isntNumber H (bool x) p = scalar-≢-impl-≮: boolean number (λ ())
isntNumber H (string x) p = scalar-≢-impl-≮: string number (λ ())

isntString : ∀ H v → (valueType v ≢ string) → (typeOfᴱ H ∅ (val v) ≮: string)
isntString H nil p = scalar-≢-impl-≮: nil string (λ ())
isntString H (addr a) p with remember (H [ a ]ᴴ)
isntString H (addr a) p | (just (function f ⟨ var x ∈ T ⟩∈ U is B end) , q) = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ q)) (function-≮:-scalar string)
isntString H (addr a) p | (nothing , q) = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ q)) (unknown-≮:-scalar string)
isntString H (number x) p = scalar-≢-impl-≮: number string (λ ())
isntString H (bool x) p = scalar-≢-impl-≮: boolean string (λ ())
isntString H (string x) p = CONTRADICTION (p refl)

isntFunction : ∀ H v {T U} → (valueType v ≢ function) → (typeOfᴱ H ∅ (val v) ≮: (T ⇒ U))
isntFunction H nil p = scalar-≮:-function nil
isntFunction H (addr a) p = CONTRADICTION (p refl)
isntFunction H (number x) p = scalar-≮:-function number
isntFunction H (bool x) p = scalar-≮:-function boolean
isntFunction H (string x) p = scalar-≮:-function string

isntEmpty : ∀ H v → (typeOfᴱ H ∅ (val v) ≮: never)
isntEmpty H nil = scalar-≮:-never nil
isntEmpty H (addr a) with remember (H [ a ]ᴴ)
isntEmpty H (addr a) | (just (function f ⟨ var x ∈ T ⟩∈ U is B end) , p) = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ p)) function-≮:-never
isntEmpty H (addr a) | (nothing , p) = ≡-trans-≮: (cong orUnknown (cong typeOfᴹᴼ p)) unknown-≮:-never
isntEmpty H (number x) = scalar-≮:-never number
isntEmpty H (bool x) = scalar-≮:-never boolean
isntEmpty H (string x) = scalar-≮:-never string

runtimeBinOpWarning : ∀ H {op} v → BinOpError op (valueType v) → (typeOfᴱ H ∅ (val v) ≮: srcBinOp op)
runtimeBinOpWarning H v (+ p) = isntNumber H v p
runtimeBinOpWarning H v (- p) = isntNumber H v p
runtimeBinOpWarning H v (* p) = isntNumber H v p
runtimeBinOpWarning H v (/ p) = isntNumber H v p
runtimeBinOpWarning H v (< p) = isntNumber H v p
runtimeBinOpWarning H v (> p) = isntNumber H v p
runtimeBinOpWarning H v (<= p) = isntNumber H v p
runtimeBinOpWarning H v (>= p) = isntNumber H v p
runtimeBinOpWarning H v (·· p) = isntString H v p

runtimeWarningᴱ : ∀ H M → RuntimeErrorᴱ H M → Warningᴱ H (typeCheckᴱ H ∅ M)
runtimeWarningᴮ : ∀ H B → RuntimeErrorᴮ H B → Warningᴮ H (typeCheckᴮ H ∅ B)

runtimeWarningᴱ H (var x) UnboundVariable = UnboundVariable refl
runtimeWarningᴱ H (val (addr a)) (SEGV p) = UnallocatedAddress p
runtimeWarningᴱ H (M $ N) (FunctionMismatch v w p) = FunctionCallMismatch (unknown-src-≮: (isntEmpty H w) (isntFunction H v p))
runtimeWarningᴱ H (M $ N) (app₁ err) = app₁ (runtimeWarningᴱ H M err)
runtimeWarningᴱ H (M $ N) (app₂ err) = app₂ (runtimeWarningᴱ H N err)
runtimeWarningᴱ H (block var b ∈ T is B end) (block err) = block₁ (runtimeWarningᴮ H B err)
runtimeWarningᴱ H (binexp M op N) (BinOpMismatch₁ v w p) = BinOpMismatch₁ (runtimeBinOpWarning H v p)
runtimeWarningᴱ H (binexp M op N) (BinOpMismatch₂ v w p) = BinOpMismatch₂ (runtimeBinOpWarning H w p)
runtimeWarningᴱ H (binexp M op N) (bin₁ err) = bin₁ (runtimeWarningᴱ H M err)
runtimeWarningᴱ H (binexp M op N) (bin₂ err) = bin₂ (runtimeWarningᴱ H N err)

runtimeWarningᴮ H (local var x ∈ T ← M ∙ B) (local err) = local₁ (runtimeWarningᴱ H M err)
runtimeWarningᴮ H (return M ∙ B) (return err) = return (runtimeWarningᴱ H M err)

wellTypedProgramsDontGoWrong : ∀ H′ B B′ → (∅ᴴ ⊢ B ⟶* B′ ⊣ H′) → (RuntimeErrorᴮ H′ B′) → Warningᴮ ∅ᴴ (typeCheckᴮ ∅ᴴ ∅ B)
wellTypedProgramsDontGoWrong H′ B B′ t err with reflect* ∅ᴴ B t (Left (runtimeWarningᴮ H′ B′ err))
wellTypedProgramsDontGoWrong H′ B B′ t err | Right (addr a refl ())
wellTypedProgramsDontGoWrong H′ B B′ t err | Left W = W


module STLC.Kovacs.PresheafRefinement where

open import STLC.Kovacs.Substitution public
open import STLC.Kovacs.Normalisation public
open import Category

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

-- (Tyᴺ-idₑ)
idacc : ∀ {A Γ} → (a : Γ ⊩ A)
                → acc idₑ a ≡ a
idacc {⎵}      M = idrenⁿᶠ M
idacc {A ⇒ B} f = fext¡ (fext! (λ η → f & lid○ η))

-- (Tyᴺ-∘ₑ)
acc○ : ∀ {A Γ Γ′ Γ″} → (η₁ : Γ″ ⊇ Γ′) (η₂ : Γ′ ⊇ Γ) (a : Γ ⊩ A)
                     → acc (η₂ ○ η₁) a ≡ (acc η₁ ∘ acc η₂) a
acc○ {⎵}      η₁ η₂ M = renⁿᶠ○ η₁ η₂ M
acc○ {A ⇒ B} η₁ η₂ f = fext¡ (fext! (λ η′ → f & assoc○ η′ η₁ η₂))

-- (Conᴺ-idₑ)
lid⬖ : ∀ {Γ Ξ} → (ρ : Γ ⊩⋆ Ξ)
               → ρ ⬖ idₑ ≡ ρ
lid⬖ ∅       = refl
lid⬖ (ρ , a) = _,_ & lid⬖ ρ
                   ⊗ idacc a

-- (Conᴺ-∘ₑ)
comp⬖○ : ∀ {Γ Γ′ Γ″ Ξ} → (η₁ : Γ″ ⊇ Γ′) (η₂ : Γ′ ⊇ Γ) (ρ : Γ ⊩⋆ Ξ)
                       → (ρ ⬖ η₂) ⬖ η₁ ≡ ρ ⬖ (η₂ ○ η₁)
comp⬖○ η₁ η₂ ∅       = refl
comp⬖○ η₁ η₂ (ρ , a) = _,_ & comp⬖○ η₁ η₂ ρ
                           ⊗ (acc○ η₁ η₂ a ⁻¹)

-- (∈ᴺ-nat)
get⬖ : ∀ {Γ Γ′ Ξ A} → (η : Γ′ ⊇ Γ) (ρ : Γ ⊩⋆ Ξ) (i : Ξ ∋ A)
                    → getᵥ (ρ ⬖ η) i ≡ (acc η ∘ getᵥ ρ) i
get⬖ η (ρ , a) zero    = refl
get⬖ η (ρ , a) (suc i) = get⬖ η ρ i

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

-- (Tyᴾ)
𝒰 : ∀ {A Γ} → Γ ⊩ A → Set

𝒰 {⎵}      {Γ} M = ⊤

𝒰 {A ⇒ B} {Γ} f = ∀ {Γ′} → (η : Γ′ ⊇ Γ) {a : Γ′ ⊩ A} (u : 𝒰 a)
                          → (∀ {Γ″} → (η′ : Γ″ ⊇ Γ′)
                                     → (f (η ○ η′) ∘ acc η′) a ≡
                                        (acc η′ ∘ f η) a)
                           × 𝒰 (f η a)

-- (Tyᴾₑ)
acc𝒰 : ∀ {A Γ Γ′} → {a : Γ ⊩ A}
                  → (η : Γ′ ⊇ Γ) → 𝒰 a
                  → 𝒰 (acc η a)
acc𝒰 {⎵}      {a = M} η tt = tt
acc𝒰 {A ⇒ B} {a = f} η u  = λ η′ {a} u′ →
                               let
                                 natf , u″ = u (η ○ η′) u′
                               in
                                 (λ η″ → (λ η‴ → (f η‴ ∘ acc η″) a)
                                          & (assoc○ η″ η′ η ⁻¹)
                                        ⦙ natf η″)
                               , u″

-- (Conᴾ ; ∙ ; _,_)
data 𝒰⋆ : ∀ {Γ Ξ} → Γ ⊩⋆ Ξ → Set where
  ∅   : ∀ {Γ} → 𝒰⋆ (∅ {Γ})

  _,_ : ∀ {Γ Ξ A} → {ρ : Γ ⊩⋆ Ξ} {a : Γ ⊩ A}
                  → (υ : 𝒰⋆ ρ) (u : 𝒰 a)
                  → 𝒰⋆ (ρ , a)

-- (Conᴾₑ)
-- NOTE _⬖𝒰_ = acc𝒰⋆
_⬖𝒰_ : ∀ {Γ Γ′ Ξ} → {ρ : Γ ⊩⋆ Ξ}
                  → 𝒰⋆ ρ → (η : Γ′ ⊇ Γ)
                  → 𝒰⋆ (ρ ⬖ η)
∅       ⬖𝒰 η = ∅
(υ , u) ⬖𝒰 η = υ ⬖𝒰 η , acc𝒰 η u

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

-- (∈ᴾ)
get𝒰 : ∀ {Γ Ξ A} → {ρ : Γ ⊩⋆ Ξ}
                 → 𝒰⋆ ρ → (i : Ξ ∋ A)
                 → 𝒰 (getᵥ ρ i)
get𝒰 (υ , u) zero    = u
get𝒰 (υ , u) (suc i) = get𝒰 υ i

mutual
  -- (Tmᴾ)
  eval𝒰 : ∀ {Γ Ξ A} → {ρ : Γ ⊩⋆ Ξ}
                    → 𝒰⋆ ρ → (M : Ξ ⊢ A)
                    → 𝒰 (eval ρ M)
  eval𝒰 {ρ = ρ} υ (𝓋 i)   = get𝒰 υ i
  eval𝒰 {ρ = ρ} υ (ƛ M)   = λ η {a} u →
                              (λ η′ → (λ ρ′ → eval (ρ′ , acc η′ a) M)
                                       & (comp⬖○ η′ η ρ ⁻¹)
                                     ⦙ eval⬖ η′ (υ ⬖𝒰 η , u) M)
                            , eval𝒰 (υ ⬖𝒰 η , u) M
  eval𝒰 {ρ = ρ} υ (M ∙ N) = proj₂ (eval𝒰 υ M idₑ (eval𝒰 υ N))

  -- (Tmᴺ-nat)
  eval⬖ : ∀ {Γ Γ′ Ξ A} → {ρ : Γ ⊩⋆ Ξ}
                       → (η : Γ′ ⊇ Γ) → 𝒰⋆ ρ → (M : Ξ ⊢ A)
                       → eval (ρ ⬖ η) M ≡ (acc η ∘ eval ρ) M
  eval⬖ {ρ = ρ} η υ (𝓋 i)   = get⬖ η ρ i
  eval⬖ {ρ = ρ} η υ (ƛ M)   = fext¡ (fext! (λ η′ → fext! (λ a →
                                (λ ρ′ → eval ρ′ M)
                                & ((_, a) & comp⬖○ η′ η ρ))))
  eval⬖ {ρ = ρ} η υ (M ∙ N) rewrite eval⬖ η υ M | eval⬖ η υ N
                            = (λ η′ → eval ρ M η′ (acc η (eval ρ N)))
                              & (rid○ η ⦙ lid○ η ⁻¹)
                            ⦙ proj₁ (eval𝒰 υ M idₑ (eval𝒰 υ N)) η

mutual
  -- (uᴾ)
  reflect𝒰 : ∀ {A Γ} → (M : Γ ⊢ⁿᵉ A)
                     → 𝒰 (reflect M)
  reflect𝒰 {⎵}      M = tt
  reflect𝒰 {A ⇒ B} M = λ η {a} u →
                          (λ η′ → (λ M′ N′ → reflect (M′ ∙ N′))
                                   & renⁿᵉ○ η′ η M
                                   ⊗ (natreify η′ a u)
                                 ⦙ natreflect η′ (renⁿᵉ η M ∙ reify a))
                        , reflect𝒰 (renⁿᵉ η M ∙ reify a)

  -- (qᴺ-nat)
  natreify : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ) (a : Γ ⊩ A) → 𝒰 a
                        → (reify ∘ acc η) a ≡ (renⁿᶠ η ∘ reify) a
  natreify {⎵}      η M u = refl
  natreify {A ⇒ B} η f u =
    let
      natf , u′ = u (wkₑ idₑ) (reflect𝒰 0)
    in
      ƛ & ( reify & ( f & (wkₑ & ( rid○ η
                                 ⦙ lid○ η ⁻¹
                                 ))
                        ⊗ natreflect (liftₑ η) 0
                    ⦙ natf (liftₑ η)
                    )
          ⦙ natreify (liftₑ η) (f (wkₑ idₑ) (reflect 0)) u′
          )

  -- (uᴺ-nat)
  natreflect : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ) (M : Γ ⊢ⁿᵉ A)
                          → (reflect ∘ renⁿᵉ η) M ≡ (acc η ∘ reflect) M
  natreflect {⎵}      η M = refl
  natreflect {A ⇒ B} η M = fext¡ (fext! (λ η′ → fext! (λ a →
                              (λ M′ → reflect (M′ ∙ reify a))
                              & (renⁿᵉ○ η′ η M ⁻¹))))

-- (uᶜᴾ)
id𝒰 : ∀ {Γ} → 𝒰⋆ (idᵥ {Γ})
id𝒰 {∅}     = ∅
id𝒰 {Γ , A} = id𝒰 ⬖𝒰 wkₑ idₑ , reflect𝒰 0

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

-- (OPEᴺ)
_⬗_ : ∀ {Γ Ξ Ξ′} → Ξ′ ⊇ Ξ → Γ ⊩⋆ Ξ′ → Γ ⊩⋆ Ξ
done    ⬗ ρ       = ρ
wkₑ η   ⬗ (ρ , a) = η ⬗ ρ
liftₑ η ⬗ (ρ , a) = η ⬗ ρ , a

-- (OPEᴺ-nat)
nat⬗ : ∀ {Γ Γ′ Ξ Ξ′} → (η₁ : Γ′ ⊇ Γ) (ρ : Γ ⊩⋆ Ξ′) (η₂ : Ξ′ ⊇ Ξ)
                     → η₂ ⬗ (ρ ⬖ η₁) ≡ (η₂ ⬗ ρ) ⬖ η₁
nat⬗ η₁ ρ       done       = refl
nat⬗ η₁ (ρ , a) (wkₑ η₂)   = nat⬗ η₁ ρ η₂
nat⬗ η₁ (ρ , a) (liftₑ η₂) = (_, acc η₁ a) & nat⬗ η₁ ρ η₂

-- (OPEᴺ-idₑ)
lid⬗ : ∀ {Γ Ξ} → (ρ : Γ ⊩⋆ Ξ)
               → idₑ ⬗ ρ ≡ ρ
lid⬗ ∅       = refl
lid⬗ (ρ , a) = (_, a) & lid⬗ ρ

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

-- (∈ₑᴺ)
get⬗ : ∀ {Γ Ξ Ξ′ A} → (ρ : Γ ⊩⋆ Ξ′) (η : Ξ′ ⊇ Ξ) (i : Ξ ∋ A)
                    → getᵥ (η ⬗ ρ) i ≡ (getᵥ ρ ∘ getₑ η) i
get⬗ ρ       done      i       = refl
get⬗ (ρ , a) (wkₑ η)   i       = get⬗ ρ η i
get⬗ (ρ , a) (liftₑ η) zero    = refl
get⬗ (ρ , a) (liftₑ η) (suc i) = get⬗ ρ η i

-- (Tmₑᴺ)
eval⬗ : ∀ {Γ Ξ Ξ′ A} → (ρ : Γ ⊩⋆ Ξ′) (η : Ξ′ ⊇ Ξ) (M : Ξ ⊢ A)
                     → eval (η ⬗ ρ) M ≡ (eval ρ ∘ ren η) M
eval⬗ ρ η (𝓋 i)   = get⬗ ρ η i
eval⬗ ρ η (ƛ M)   = fext¡ (fext! (λ η′ → fext! (λ a →
                      (λ ρ′ → eval (ρ′ , a) M) & nat⬗ η′ ρ η ⁻¹
                    ⦙ eval⬗ (ρ ⬖ η′ , a) (liftₑ η) M)))
eval⬗ ρ η (M ∙ N) rewrite eval⬗ ρ η M | eval⬗ ρ η N
                  = refl

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

-- (Subᴺ)
-- NOTE: _◆_ = eval⋆
_◆_ : ∀ {Γ Ξ Φ} → Ξ ⊢⋆ Φ → Γ ⊩⋆ Ξ → Γ ⊩⋆ Φ
∅       ◆ ρ = ∅
(σ , M) ◆ ρ = σ ◆ ρ , eval ρ M

-- (Subᴺ-nat)
comp◆⬖ : ∀ {Γ Γ′ Ξ Φ} → {ρ : Γ ⊩⋆ Ξ}
                      → (η : Γ′ ⊇ Γ) → 𝒰⋆ ρ → (σ : Ξ ⊢⋆ Φ)
                      → (σ ◆ ρ) ⬖ η ≡ σ ◆ (ρ ⬖ η)
comp◆⬖ η υ ∅       = refl
comp◆⬖ η υ (σ , M) = _,_ & comp◆⬖ η υ σ
                         ⊗ (eval⬖ η υ M ⁻¹)

-- (Subᴺ-ₛ∘ₑ)
comp◆⬗ : ∀ {Γ Ξ Ξ′ Φ} → (ρ : Γ ⊩⋆ Ξ′) (η : Ξ′ ⊇ Ξ) (σ : Ξ ⊢⋆ Φ)
                      → (σ ◐ η) ◆ ρ ≡ σ ◆ (η ⬗ ρ)
comp◆⬗ ρ η ∅       = refl
comp◆⬗ ρ η (σ , M) = _,_ & comp◆⬗ ρ η σ
                         ⊗ (eval⬗ ρ η M ⁻¹)

-- (∈ₛᴺ)
get◆ : ∀ {Γ Ξ Φ A} → (ρ : Γ ⊩⋆ Ξ) (σ : Ξ ⊢⋆ Φ) (i : Φ ∋ A)
                   → getᵥ (σ ◆ ρ) i ≡ (eval ρ ∘ getₛ σ) i
get◆ ρ (σ , M) zero    = refl
get◆ ρ (σ , M) (suc i) = get◆ ρ σ i

-- (Subᴺ-idₛ)
lid◆ : ∀ {Γ Ξ} → (ρ : Γ ⊩⋆ Ξ)
               → idₛ ◆ ρ ≡ ρ
lid◆ ∅       = refl
lid◆ (ρ , a) = (_, a) & ( comp◆⬗ (ρ , a) (wkₑ idₑ) idₛ
                        ⦙ lid◆ (idₑ ⬗ ρ)
                        ⦙ lid⬗ ρ
                        )

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

accPsh : 𝒯 → Presheaf₀ 𝗢𝗣𝗘
accPsh A =
  record
    { Fₓ  = _⊩ A
    ; F   = acc
    ; idF = fext! idacc
    ; F⋄  = λ η₁ η₂ → fext! (acc○ η₂ η₁)
    }

flip⬖Psh : 𝒞 → Presheaf₀ 𝗢𝗣𝗘
flip⬖Psh Ξ =
  record
    { Fₓ  = _⊩⋆ Ξ
    ; F   = flip _⬖_
    ; idF = fext! lid⬖
    ; F⋄  = λ η₁ η₂ → fext! (λ ρ → comp⬖○ η₂ η₁ ρ ⁻¹)
    }

getᵥNT : ∀ {Ξ A} → (i : Ξ ∋ A)
                 → NaturalTransformation (flip⬖Psh Ξ) (accPsh A)
getᵥNT i =
  record
    { N    = flip getᵥ i
    ; natN = λ η → fext! (λ ρ → get⬖ η ρ i)
    }

-- TODO
-- evalNT : ∀ {Ξ A} → (M : Ξ ⊢ A)
--                  → NaturalTransformation (flip⬖Psh Ξ) (accPsh A)
-- evalNT M =
--   record
--     { N    = flip eval M
--     ; natN = λ η → fext! (λ ρ → eval⬖ {ρ = ρ} η {!!} M)
--     }

-- TODO
-- reifyNT : ∀ {A} → NaturalTransformation (accPsh A) (renⁿᶠPsh A)
-- reifyNT =
--   record
--     { N    = reify
--     ; natN = λ η → fext! (λ a → natreify η a {!!})
--     }

reflectNT : ∀ {A} → NaturalTransformation (renⁿᵉPsh A) (accPsh A)
reflectNT =
  record
    { N    = reflect
    ; natN = λ η → fext! (λ M → natreflect η M)
    }

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