--------------------------------------------------------------------------------
-- This file provides the data structures and functions for the theory of
-- cedille core extended with the constructs for metaprogramming.
--------------------------------------------------------------------------------

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

module CoreTheory where

import Agda.Builtin.Nat using (_+_; _-_; _==_)

import Data.Product

open import Class.Map
open import Class.Monad.Except
open import Data.HSTrie
open import Data.Integer using (ℤ; +_; -[1+_])
open import Data.String using (toList; fromList)
open import Data.Word using (Word64; toℕ; fromℕ)
open import Data.Word64.Exts
open import Monads.Except

open import Prelude

open import Theory.PrimMeta public

private
  variable
    A B C : Set
    M : Set → Set

data Sort : Set where
  ⋆ : Sort
  □ : Sort

instance
  Sort-Show : Show Sort
  Sort-Show = record { show = helper }
    where
      helper : Sort → String
      helper ⋆ = "*"
      helper □ = "□"

  Sort-Eq : Eq Sort
  Sort-Eq = record { _≟_ = helper }
    where
      helper : (s s' : Sort) → Dec (s ≡ s')
      helper ⋆ ⋆ = yes refl
      helper ⋆ □ = no λ ()
      helper □ ⋆ = no λ ()
      helper □ □ = yes refl

  Sort-EqB = Eq→EqB {{Sort-Eq}}

GlobalName : Set
GlobalName = String

𝕀 : Set
𝕀 = Word64

instance
  𝕀-Eq : Eq 𝕀
  𝕀-Eq = record { _≟_ = Data.Word._≟_ }

  𝕀-EqB : EqB 𝕀
  𝕀-EqB = record { _≣_ = Agda.Builtin.Nat._==_ on toℕ }

  𝕀-Show : Show 𝕀
  𝕀-Show = record { show = show ∘ toℕ }

_<𝕀_ : 𝕀 → 𝕀 → Bool
x <𝕀 y = toℕ x <ᵇ toℕ y

_+𝕀_ : 𝕀 → 𝕀 → 𝕀
x +𝕀 y = fromℕ $ toℕ x + toℕ y

_-𝕀_ : 𝕀 → 𝕀 → 𝕀
_-𝕀_ = subWord

suc𝕀 : 𝕀 → 𝕀
suc𝕀 = _+𝕀 fromℕ 1

pred𝕀 : 𝕀 → 𝕀
pred𝕀 = _-𝕀 fromℕ 1

data Name : Set where
  Bound : 𝕀 → Name
  Free : GlobalName → Name

instance
  Name-Eq : Eq Name
  Name-Eq = record { _≟_ = helper }
    where
      helper : (n n' : Name) → Dec (n ≡ n')
      helper (Bound x) (Bound x₁) with x ≟ x₁
      ... | yes p rewrite p = yes refl
      ... | no ¬p = no λ { refl → ¬p refl }
      helper (Bound x) (Free x₁) = no λ ()
      helper (Free x) (Bound x₁) = no λ ()
      helper (Free x) (Free x₁) with x ≟ x₁
      ... | yes p rewrite p = yes refl
      ... | no ¬p = no λ { refl → ¬p refl }

  Name-EqB : EqB Name
  Name-EqB = Eq→EqB

  Name-Show : Show Name
  Name-Show = record { show = helper }
    where
      helper : Name → String
      helper (Bound x) = show x
      helper (Free x) = x

record TermLike (T : Set) : Set where
  infixl -1 _⟪$⟫_ -- same as $ but on the left
  field
    Var : Name → T
    _⟪$⟫_ : T → T → T

  BoundVar : 𝕀 → T
  BoundVar = Var ∘ Bound

  FreeVar : GlobalName → T
  FreeVar = Var ∘ Free

open TermLike {{...}} public

showVar : List String → Name → String
showVar l (Bound x) with lookupMaybe (toℕ x) l
... | nothing = show x
... | just x₁ = if x₁ ≣ "_" then show x else x₁
showVar l (Free x) = x

data Const : Set where
  CharT : Const

instance
  Const-Eq : Eq Const
  Const-Eq = record { _≟_ = helper }
    where
      helper : (c c' : Const) → Dec (c ≡ c')
      helper CharT CharT = yes refl

  Const-EqB : EqB Const
  Const-EqB = Eq→EqB

  Const-Show : Show Const
  Const-Show = record { show = helper }
    where
      helper : Const → String
      helper CharT = "CharT"

data PureTerm : Set where
  Var-P : Name → PureTerm
  Sort-P : Sort → PureTerm
  Const-P : Const → PureTerm
  App-P : PureTerm → PureTerm → PureTerm
  Lam-P : String → PureTerm → PureTerm
  Pi-P : String → PureTerm → PureTerm → PureTerm
  All-P : String → PureTerm → PureTerm → PureTerm
  Iota-P : String → PureTerm → PureTerm → PureTerm
  Eq-P : PureTerm → PureTerm → PureTerm
  M-P : PureTerm → PureTerm
  Mu-P : PureTerm → PureTerm → PureTerm
  Epsilon-P : PureTerm → PureTerm
  Gamma-P : PureTerm → PureTerm → PureTerm
  Ev-P : (m : PrimMeta) → primMetaArgs PureTerm m → PureTerm
  Char-P : Char → PureTerm
  CharEq-P : PureTerm → PureTerm → PureTerm

instance
  PureTerm-TermLike : TermLike PureTerm
  PureTerm-TermLike = record { Var = Var-P ; _⟪$⟫_ = App-P }

  {-# TERMINATING #-}
  PureTerm-Show : Show PureTerm
  PureTerm-Show = record { show = helper [] }
    where
      helper : List String → PureTerm → String
      helper l (Var-P x) = showVar l x
      helper l (Sort-P x) = show x
      helper l (Const-P x) = show x
      helper l (App-P t t₁) = "[" + helper l t <+> helper l t₁ + "]"
      helper l (Lam-P n t) = "λ" <+> n <+> helper (n ∷ l) t
      helper l (Pi-P n t t₁) = "Π" <+> n <+> helper (n ∷ l) t <+> helper l t₁
      helper l (All-P n t t₁) = "∀" <+> n <+> helper (n ∷ l) t <+> helper l t₁
      helper l (Iota-P n t t₁) = "ι" <+> n <+> helper (n ∷ l) t <+> helper l t₁
      helper l (Eq-P t t₁) = "=" <+> helper l t <+> helper l t₁
      helper l (M-P t) = "M" <+> helper l t
      helper l (Mu-P t t₁) = "μ" <+> helper l t <+> helper l t₁
      helper l (Epsilon-P t) = "ε" <+> helper l t
      helper l (Gamma-P t t₁) = "Γ" <+> helper l t <+> helper l t₁
      helper l (Ev-P m args) = "ζ" <+> show m <+> primMetaArgs-Show (helper l) args
      helper l (Char-P c) = "Char" <+> show c
      helper l (CharEq-P t t') = "CharEq" <+> show t <+> show t'

private
  beqMonadHelper : {{_ : EqB A}} {{_ : Show A}} {{_ : Monad M}} {{_ : MonadExcept M String}}
                → A → A → String → M ⊤
  beqMonadHelper a a' s =
    if a ≣ a'
      then return tt
      else throwError (s <+> show a <+> "isn't equal to name" <+> show a')

{-# TERMINATING #-}
pureTermBeq : {{_ : Monad M}} {{_ : MonadExcept M String}}
  → PureTerm → PureTerm → M ⊤
pureTermBeq (Var-P x) (Var-P x₁) = beqMonadHelper x x₁ "Name"
pureTermBeq (Sort-P x) (Sort-P x₁) = beqMonadHelper x x₁ "Sort"
pureTermBeq (Const-P x) (Const-P x₁) = beqMonadHelper x x₁ "Const"
pureTermBeq (App-P t t₁) (App-P x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (Lam-P _ t) (Lam-P _ t₁) = pureTermBeq t t₁
pureTermBeq (Pi-P _ t t₁) (Pi-P _ x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (All-P _ t t₁) (All-P _ x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (Iota-P _ t t₁) (Iota-P _ x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (Eq-P t t₁) (Eq-P x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (M-P t) (M-P x) = pureTermBeq x t
pureTermBeq (Mu-P t t₁) (Mu-P x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (Epsilon-P t) (Epsilon-P x) = pureTermBeq t x
pureTermBeq (Gamma-P t t₁) (Gamma-P x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
pureTermBeq (Ev-P m t) (Ev-P m' x) with m ≟ m'
... | yes refl = void $ primMetaArgsSequence $ primMetaArgsZipWith pureTermBeq t x
... | no  _    = throwError $ show m <+> "and" <+> show m' <+> "aren't equal!"
pureTermBeq (Char-P c) (Char-P c') = beqMonadHelper c c' "Char"
pureTermBeq (CharEq-P t t₁) (CharEq-P x x₁) = pureTermBeq t x >> pureTermBeq t₁ x₁
{-# CATCHALL #-}
pureTermBeq t t' =
  throwError $ "The terms" <+> show t <+> "and" <+> show t' <+> "aren't equal!"

data AnnTerm : Set where
  Var-A : Name → AnnTerm
  Sort-A : Sort → AnnTerm
  Const-A : Const → AnnTerm
  Pr1-A : AnnTerm → AnnTerm
  Pr2-A : AnnTerm → AnnTerm
  Beta-A : AnnTerm → AnnTerm → AnnTerm -- proves first arg eq, erase to second arg
  Delta-A : AnnTerm → AnnTerm → AnnTerm -- inhabits first arg if snd arg proves false
  Sigma-A : AnnTerm → AnnTerm
  App-A : AnnTerm → AnnTerm → AnnTerm
  AppE-A : AnnTerm → AnnTerm → AnnTerm
  Rho-A : AnnTerm → AnnTerm → AnnTerm → AnnTerm -- first arg is eq, rewrite the name in the third arg and inhabit with fourth arg
  All-A : String → AnnTerm → AnnTerm → AnnTerm
  Pi-A : String → AnnTerm → AnnTerm → AnnTerm
  Iota-A : String → AnnTerm → AnnTerm → AnnTerm
  Lam-A : String → AnnTerm → AnnTerm → AnnTerm
  LamE-A : String → AnnTerm → AnnTerm → AnnTerm
  Pair-A : AnnTerm → AnnTerm → AnnTerm → AnnTerm
  Phi-A : AnnTerm → AnnTerm → AnnTerm → AnnTerm
  -- there is a let binding here, which is probably unnecessary
  Eq-A : AnnTerm → AnnTerm → AnnTerm
  M-A : AnnTerm → AnnTerm
  Mu-A : AnnTerm → AnnTerm → AnnTerm
  Epsilon-A : AnnTerm → AnnTerm
  Gamma-A : AnnTerm → AnnTerm → AnnTerm
  Ev-A : (x : PrimMeta) → primMetaArgs AnnTerm x → AnnTerm
  Char-A : Char → AnnTerm
  CharEq-A : AnnTerm → AnnTerm → AnnTerm

instance
  AnnTerm-TermLike : TermLike AnnTerm
  AnnTerm-TermLike = record { Var = Var-A ; _⟪$⟫_ = App-A }

  {-# TERMINATING #-}
  AnnTerm-Show : Show AnnTerm
  AnnTerm-Show = record { show = helper [] }
    where
      helper : List String → AnnTerm → String
      helper l (Var-A x)        = showVar l x
      helper l (Sort-A x)       = show x
      helper l (Const-A x)      = show x
      helper l (Pr1-A t)        = "π1" <+> helper l t
      helper l (Pr2-A t)        = "π2" <+> helper l t
      helper l (Beta-A t t₁)    = "β" <+> helper l t <+> helper l t₁
      helper l (Delta-A t t₁)   = "Delta-A" + helper l t <+> helper l t₁
      helper l (Sigma-A t)      = "ς" + helper l t
      helper l (App-A t t₁)     = "[" + helper l t <+> helper l t₁ + "]"
      helper l (AppE-A t t₁)    = "<" + helper l t <+> helper l t₁ + ">"
      helper l (Rho-A t t₁ t₂)  = "ρ" <+> helper l t <+> ":" <+> helper l t₁ <+> helper l t₂
      helper l (All-A n t t₁)   = "∀" <+> n <+> ":" <+> helper l t + "." <+> helper (n ∷ l) t₁
      helper l (Pi-A n t t₁)    = "Π" <+> n <+> ":" <+> helper l t + "." <+> helper (n ∷ l) t₁
      helper l (Iota-A n t t₁)  = "ι" <+> n <+> ":" <+> helper l t + "." <+> helper (n ∷ l) t₁
      helper l (Lam-A n t t₁)   = "λ" <+> n <+> ":" <+> helper l t + "." <+> helper (n ∷ l) t₁
      helper l (LamE-A n t t₁)  = "Λ" <+> n <+> ":" <+> helper l t + "." <+> helper (n ∷ l) t₁
      helper l (Pair-A t t₁ t₂) = "{" + helper l t + "," + helper l t₁ <+> "." <+> helper l t₂ + "}"
      helper l (Phi-A t t₁ t₂)  = "φ" <+> helper l t <+> helper l t₁ <+> helper l t₂
      helper l (Eq-A t t₁)      = "(=" <+> helper l t <+> helper l t₁ + ")"
      helper l (M-A t)          = "M" <+> helper l t
      helper l (Mu-A t t₁)      = "μ" <+> helper l t <+> helper l t₁
      helper l (Epsilon-A t)    = "ε" <+> helper l t
      helper l (Gamma-A t t₁)   = "Γ" <+> helper l t <+> helper l t₁
      helper l (Ev-A m args)    = "Ev" <+> show m <+> primMetaArgs-Show (helper l) args
      helper l (Char-A c)       = "Char" <+> show c
      helper l (CharEq-A t t')  = "CharEq" <+> show t <+> show t'

primMetaS : (m : PrimMeta) → primMetaArgs AnnTerm m
primMetaS EvalStmt      = FreeVar "init$stmt"
primMetaS ShellCmd      = (FreeVar "init$string" , FreeVar "init$stringList")
primMetaS CheckTerm     = (Sort-A ⋆ , FreeVar "init$term")
primMetaS Parse         = (FreeVar "init$string" , Sort-A ⋆ , FreeVar "init$string")
primMetaS Normalize     = FreeVar "init$term"
primMetaS HeadNormalize = FreeVar "init$term"
primMetaS InferType     = FreeVar "init$term"

primMetaT : ∀ {T} {{_ : TermLike T}} (m : PrimMeta) → primMetaArgs T m → T
primMetaT EvalStmt _        = FreeVar "init$metaResult"
primMetaT ShellCmd _        = FreeVar "init$string"
primMetaT CheckTerm (t , _) = t
primMetaT Parse (_ , t , _) = FreeVar "init$product" ⟪$⟫ t ⟪$⟫ FreeVar "init$string"
primMetaT Normalize _       = FreeVar "init$term"
primMetaT HeadNormalize _   = FreeVar "init$term"
primMetaT InferType     _   = FreeVar "init$term"

data Def : Set where
  Let : AnnTerm → AnnTerm → Def
  Axiom : AnnTerm → Def

data EfficientDef : Set where
  EfficientLet : AnnTerm → PureTerm → AnnTerm → EfficientDef
  EfficientAxiom : AnnTerm → EfficientDef

toDef : EfficientDef → Def
toDef (EfficientLet x x₁ x₂)   = Let x x₂
toDef (EfficientAxiom x)       = Axiom x

getNorm : EfficientDef → Maybe PureTerm
getNorm (EfficientLet x x₁ x₂) = return x₁
getNorm (EfficientAxiom x)     = nothing

instance
  Def-Show : Show Def
  Def-Show = record { show = helper }
    where
      helper : Def → String
      helper (Let x x₁) = " :=" <+> show x <+> ":" <+> show x₁
      helper (Axiom x) = " :" <+> show x

typeOfDef : Def → AnnTerm
typeOfDef (Let _ x) = x
typeOfDef (Axiom x) = x

{-# TERMINATING #-}
modifyIndicesPure : 𝕀 → PureTerm → PureTerm
modifyIndicesPure = helper $ fromℕ 0
  where
    helper : 𝕀 → 𝕀 → PureTerm → PureTerm
    helper k n v@(Var-P (Bound x)) = if x <𝕀 k then v else BoundVar (pred𝕀 (x +𝕀 n))
    helper k n v@(Var-P (Free x))  = v
    helper k n v@(Sort-P x)        = v
    helper k n v@(Const-P x)       = v
    helper k n (App-P t t₁)        = App-P (helper k n t) (helper k n t₁)
    helper k n (Lam-P x t)         = Lam-P x (helper (suc𝕀 k) n t)
    helper k n (Pi-P x t t₁)       = Pi-P x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (All-P x t t₁)      = All-P x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (Iota-P x t t₁)     = Iota-P x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (Eq-P t t₁)         = Eq-P (helper k n t) (helper k n t₁)
    helper k n (M-P t)             = M-P (helper k n t)
    helper k n (Mu-P t t₁)         = Mu-P (helper k n t) (helper k n t₁)
    helper k n (Epsilon-P t)       = Epsilon-P (helper k n t)
    helper k n (Gamma-P t t₁)      = Gamma-P (helper k n t) (helper k n t₁)
    helper k n (Ev-P m args)       = Ev-P m (mapPrimMetaArgs (helper k n) args)
    helper k n (Char-P c)          = Char-P c
    helper k n (CharEq-P t t')     = CharEq-P (helper k n t) (helper k n t')

incrementIndicesPureBy : 𝕀 → PureTerm → PureTerm
incrementIndicesPureBy i = modifyIndicesPure (suc𝕀 i)

decrementIndicesPure : PureTerm → PureTerm
decrementIndicesPure = modifyIndicesPure (fromℕ 0)

{-# TERMINATING #-}
modifyIndices : 𝕀 → AnnTerm → AnnTerm
modifyIndices = helper (fromℕ 0)
  where
    helper : 𝕀 → 𝕀 → AnnTerm → AnnTerm
    helper k n v@(Var-A (Bound x)) = if x <𝕀 k then v else BoundVar (pred𝕀 (x +𝕀 n))
    helper k n v@(Var-A (Free x)) = v
    helper k n (Sort-A x) = Sort-A x
    helper k n (Const-A x) = Const-A x
    helper k n (Pr1-A t) = Pr1-A $ helper k n t
    helper k n (Pr2-A t) = Pr2-A $ helper k n t
    helper k n (Beta-A t t₁) = Beta-A (helper k n t) (helper k n t₁)
    helper k n (Delta-A t t₁) = Delta-A (helper k n t) (helper k n t₁)
    helper k n (Sigma-A t) = Sigma-A (helper k n t)
    helper k n (App-A t t₁) = App-A (helper k n t) (helper k n t₁)
    helper k n (AppE-A t t₁) = AppE-A (helper k n t) (helper k n t₁)
    helper k n (Rho-A t t₁ t₂) = Rho-A (helper k n t) (helper (suc𝕀 k) n t₁) (helper k n t₂)
    helper k n (All-A x t t₁) = All-A x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (Pi-A x t t₁) = Pi-A x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (Iota-A x t t₁) = Iota-A x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (Lam-A x t t₁) = Lam-A x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (LamE-A x t t₁) = LamE-A x (helper k n t) (helper (suc𝕀 k) n t₁)
    helper k n (Pair-A t t₁ t₂) = Pair-A (helper k n t) (helper k n t₁) (helper (suc𝕀 k) n t₂)
    helper k n (Phi-A t t₁ t₂) = Phi-A (helper k n t) (helper k n t₁) (helper k n t₂)
    helper k n (Eq-A t t₁) = Eq-A (helper k n t) (helper k n t₁)
    helper k n (M-A t) = M-A (helper k n t)
    helper k n (Mu-A t t₁) = Mu-A (helper k n t) (helper k n t₁)
    helper k n (Epsilon-A t) = Epsilon-A (helper k n t)
    helper k n (Gamma-A t t₁) = Gamma-A (helper k n t) (helper k n t₁)
    helper k n (Ev-A m args) = Ev-A m (mapPrimMetaArgs (helper k n) args)
    helper k n (Char-A c) = Char-A c
    helper k n (CharEq-A t t₁) = CharEq-A (helper k n t) (helper k n t₁)

incrementIndicesBy : 𝕀 → AnnTerm → AnnTerm
incrementIndicesBy i = modifyIndices (suc𝕀 i)

decrementIndices : AnnTerm → AnnTerm
decrementIndices = modifyIndices (fromℕ 0)

{-# TERMINATING #-}
checkFree : Name → PureTerm → Bool
checkFree = helper 0
  where
    helper : ℕ → Name → PureTerm → Bool
    helper k n (Var-P (Bound x)) = case n of λ where
      (Bound x₁) → x ≣ (fromℕ k +𝕀 x₁)
      (Free x₁) → false
    helper k n (Var-P (Free x)) = case n of λ where
      (Bound x₁) → false
      (Free x₁) → x ≣ x₁
    helper k n (Sort-P x) = false
    helper k n (Const-P x) = false
    helper k n (App-P t t₁) = helper k n t ∧ helper k n t₁
    helper k n (Lam-P _ t) = helper (suc k) n t
    helper k n (Pi-P _ t t₁) = helper k n t ∧ helper (suc k) n t₁
    helper k n (All-P _ t t₁) = helper k n t ∧ helper (suc k) n t₁
    helper k n (Iota-P _ t t₁) = helper k n t ∧ helper (suc k) n t₁
    helper k n (Eq-P t t₁) = helper k n t ∧ helper k n t₁
    helper k n (M-P t) = helper k n t
    helper k n (Mu-P t t₁) = helper k n t ∧ helper k n t₁
    helper k n (Epsilon-P t) = helper k n t
    helper k n (Gamma-P t t₁) = helper k n t ∧ helper k n t₁
    helper k n (Ev-P m t) = primMetaArgsAnd $ mapPrimMetaArgs (helper k n) t
    helper k n (Char-P c) = false
    helper k n (CharEq-P t t₁) = helper k n t ∧ helper k n t₁

GlobalContext : Set
GlobalContext = HSTrie EfficientDef

emptyGlobalContext : GlobalContext
emptyGlobalContext = emptyMap

Context : Set
Context = GlobalContext × List AnnTerm

instance
  Context-Show : Show Context
  Context-Show = record { show = helper }
    where
      helper : Context → String
      helper (fst , snd) =
        (show $ length snd) <+> "local variables:" + show snd

globalToContext : GlobalContext → Context
globalToContext Γ = Γ , []

contextToGlobal : Context → GlobalContext
contextToGlobal (fst , snd) = fst

-- add variable to context, so that index 0 points to that variable
pushVar : AnnTerm → Context → Context
pushVar v (fst , snd) = fst , v ∷ snd

localContextLength : Context → ℕ
localContextLength (fst , snd) = length snd

efficientLookupInContext : Name → Context → Maybe EfficientDef
efficientLookupInContext (Bound x) (fst , snd) =
  EfficientAxiom ∘ incrementIndicesBy (suc𝕀 x) <$> lookupMaybe (toℕ x) snd
efficientLookupInContext (Free x) (fst , snd) = lookup x fst

lookupInContext : Name → Context → Maybe Def
lookupInContext n Γ = toDef <$> efficientLookupInContext n Γ

{-# TERMINATING #-}
validInContext : PureTerm → Context → Bool
validInContext = helper 0
  where
    -- instead of modifying the context here, we just count how many variables we would have added if we did
    helper : ℕ → PureTerm → Context → Bool
    helper k (Var-P (Bound x)) Γ = x <𝕀 fromℕ (localContextLength Γ + k)
    helper k (Var-P n@(Free x)) Γ = maybe (λ _ → true) false $ lookupInContext n Γ
    helper k (Sort-P x) Γ = true
    helper k (Const-P x) Γ = true
    helper k (App-P t t₁) Γ = helper k t Γ ∧ helper k t₁ Γ
    helper k (Lam-P _ t) Γ = helper (suc k) t Γ
    helper k (Pi-P _ t t₁) Γ = helper k t Γ ∧ helper (suc k) t₁ Γ
    helper k (All-P _ t t₁) Γ = helper k t Γ ∧ helper (suc k) t₁ Γ
    helper k (Iota-P _ t t₁) Γ = helper k t Γ ∧ helper (suc k) t₁ Γ
    helper k (Eq-P t t₁) Γ = helper k t Γ ∧ helper k t₁ Γ
    helper k (M-P t) Γ = helper k t Γ
    helper k (Mu-P t t₁) Γ = helper k t Γ ∧ helper k t₁ Γ
    helper k (Epsilon-P t) Γ = helper k t Γ
    helper k (Gamma-P t t₁) Γ = helper k t Γ ∧ helper k t₁ Γ
    helper k (Ev-P m t) Γ = primMetaArgsAnd $ mapPrimMetaArgs (λ x → helper k x Γ) t
    helper k (Char-P c) Γ = true
    helper k (CharEq-P t t₁) Γ = helper k t Γ ∧ helper k t₁ Γ

{-# TERMINATING #-}
Erase : AnnTerm → PureTerm
Erase (Var-A x)        = Var-P x
Erase (Sort-A x)       = Sort-P x
Erase (Const-A x)      = Const-P x
Erase (Pr1-A t)        = Erase t
Erase (Pr2-A t)        = Erase t
Erase (Beta-A t t₁)    = Erase t₁
Erase (Delta-A t t₁)   = Erase t₁
Erase (Sigma-A t)      = Erase t
Erase (App-A t t₁)     = App-P (Erase t) (Erase t₁)
Erase (AppE-A t t₁)    = Erase t
Erase (Rho-A t t₁ t₂)  = Erase t₂
Erase (All-A n t t₁)   = All-P n (Erase t) (Erase t₁)
Erase (Pi-A n t t₁)    = Pi-P n (Erase t) (Erase t₁)
Erase (Iota-A n t t₁)  = Iota-P n (Erase t) (Erase t₁)
Erase (Lam-A n t t₁)   = Lam-P n (Erase t₁)
Erase (LamE-A _ t t₁)  = decrementIndicesPure (Erase t₁)
Erase (Pair-A t t₁ t₂) = Erase t
Erase (Phi-A t t₁ t₂)  = Erase t₂
Erase (Eq-A x x₁)      = Eq-P (Erase x) (Erase x₁)
Erase (M-A t)          = M-P (Erase t)
Erase (Mu-A t t₁)      = Mu-P (Erase t) (Erase t₁)
Erase (Epsilon-A t)    = Epsilon-P (Erase t)
Erase (Gamma-A t t₁)   = Gamma-P (Erase t) (Erase t₁)
Erase (Ev-A m args)    = Ev-P m (mapPrimMetaArgs Erase args)
Erase (Char-A c)       = Char-P c
Erase (CharEq-A x x₁)  = CharEq-P (Erase x) (Erase x₁)

-- substitute the first unbound variable in t with t'
{-# TERMINATING #-}
subst : AnnTerm → AnnTerm → AnnTerm
subst t t' = decrementIndices $ substIndex t (fromℕ 0) t'
  where
    -- substitute the k-th unbound variable in t with t'
    substIndex : AnnTerm → 𝕀 → AnnTerm → AnnTerm
    substIndex v@(Var-A (Bound x)) k t' = if k ≣ x then incrementIndicesBy (suc𝕀 k) t' else v
    substIndex v@(Var-A (Free x)) k t' = v
    substIndex v@(Sort-A x) k t' = v
    substIndex v@(Const-A x) k t' = v
    substIndex (Pr1-A t) k t' = Pr1-A (substIndex t k t')
    substIndex (Pr2-A t) k t' = Pr2-A (substIndex t k t')
    substIndex (Beta-A t t₁) k t' = Beta-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (Delta-A t t₁) k t' = Delta-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (Sigma-A t) k t' = Sigma-A (substIndex t k t')
    substIndex (App-A t t₁) k t' = App-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (AppE-A t t₁) k t' = AppE-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (Rho-A t t₁ t₂) k t' = Rho-A (substIndex t k t') (substIndex t₁ k t') (substIndex t₂ k t')
    substIndex (All-A n t t₁) k t' = All-A n (substIndex t k t') (substIndex t₁ (suc𝕀 k) t')
    substIndex (Pi-A n t t₁) k t' = Pi-A n (substIndex t k t') (substIndex t₁ (suc𝕀 k) t')
    substIndex (Iota-A n t t₁) k t' = Iota-A n (substIndex t k t') (substIndex t₁ (suc𝕀 k) t')
    substIndex (Lam-A n t t₁) k t' = Lam-A n (substIndex t k t') (substIndex t₁ (suc𝕀 k) t')
    substIndex (LamE-A n t t₁) k t' = LamE-A n (substIndex t k t') (substIndex t₁ (suc𝕀 k) t')
    substIndex (Pair-A t t₁ t₂) k t' = Pair-A (substIndex t k t') (substIndex t₁ k t') (substIndex t₂ (suc𝕀 k) t')
    substIndex (Phi-A t t₁ t₂) k t' = Phi-A (substIndex t k t') (substIndex t₁ k t') (substIndex t₂ k t')
    substIndex (Eq-A t t₁) k t' = Eq-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (M-A t) k t' = M-A (substIndex t k t')
    substIndex (Mu-A t t₁) k t' = Mu-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (Epsilon-A t) k t' = Epsilon-A (substIndex t k t')
    substIndex (Gamma-A t t₁) k t' = Gamma-A (substIndex t k t') (substIndex t₁ k t')
    substIndex (Ev-A m t) k t' = Ev-A m $ mapPrimMetaArgs (λ x → substIndex x k t') t
    substIndex (Char-A c) k t' = Char-A c
    substIndex (CharEq-A t t₁) k t' = CharEq-A (substIndex t k t') (substIndex t₁ k t')

-- substitute the first unbound variable in t with t'
{-# TERMINATING #-}
substPure : PureTerm → PureTerm → PureTerm
substPure t t' = decrementIndicesPure $ substIndexPure t (fromℕ 0) t'
  where
    -- substitute the k-th unbound variable in t with t'
    substIndexPure : PureTerm → 𝕀 → PureTerm → PureTerm
    substIndexPure v@(Var-P (Bound x)) k t' = if k ≣ x then incrementIndicesPureBy (suc𝕀 k) t' else v
    substIndexPure v@(Var-P (Free x)) k t' = v
    substIndexPure v@(Sort-P x) k t' = v
    substIndexPure v@(Const-P x) k t' = v
    substIndexPure (App-P t t₁) k t' = App-P (substIndexPure t k t') (substIndexPure t₁ k t')
    substIndexPure (Lam-P n t) k t' = Lam-P n (substIndexPure t (suc𝕀 k) t')
    substIndexPure (Pi-P n t t₁) k t' = Pi-P n (substIndexPure t k t') (substIndexPure t₁ (suc𝕀 k) t')
    substIndexPure (All-P n t t₁) k t' = All-P n (substIndexPure t k t') (substIndexPure t₁ (suc𝕀 k) t')
    substIndexPure (Iota-P n t t₁) k t' = Iota-P n (substIndexPure t k t') (substIndexPure t₁ (suc𝕀 k) t')
    substIndexPure (Eq-P t t₁) k t' = Eq-P (substIndexPure t k t') (substIndexPure t₁ k t')
    substIndexPure (M-P t) k t' = M-P (substIndexPure t k t')
    substIndexPure (Mu-P t t₁) k t' = Mu-P (substIndexPure t k t') (substIndexPure t₁ k t')
    substIndexPure (Epsilon-P t) k t' = Epsilon-P (substIndexPure t k t')
    substIndexPure (Gamma-P t t₁) k t' = Gamma-P (substIndexPure t k t') (substIndexPure t₁ k t')
    substIndexPure (Ev-P m t) k t' = Ev-P m $ mapPrimMetaArgs (λ x → substIndexPure x k t') t
    substIndexPure (Char-P c) k t' = Char-P c
    substIndexPure (CharEq-P t t₁) k t' = CharEq-P (substIndexPure t k t') (substIndexPure t₁ k t')

stripBinder : AnnTerm → Maybe AnnTerm
stripBinder (All-A  _ t' t'') = just t''
stripBinder (Pi-A   _ t' t'') = just t''
stripBinder (Iota-A _ t' t'') = just t''
stripBinder (Lam-A  _ t' t'') = just t''
stripBinder (LamE-A _ t' t'') = just t''
{-# CATCHALL #-}
stripBinder t                 = nothing

-- something in is head normal form, if its outermost constructor is not one of the following: Var-A (if the lookup fails), App-A, AppE-A
{-# TERMINATING #-}
hnfNorm : Context → AnnTerm → AnnTerm
hnfNorm Γ v@(Var-A x) with lookupInContext x Γ
... | just (Let x₁ x₂)  = hnfNorm Γ x₁
... | just (Axiom x₁)   = v -- we cannot reduce axioms
... | nothing           = v -- in case the lookup fails, we cannot reduce
hnfNorm Γ (App-A t t₁)  = maybe (λ t' → hnfNorm Γ $ subst t' t₁) (t ⟪$⟫ t₁) $ stripBinder (hnfNorm Γ t)
hnfNorm Γ (AppE-A t t₁) = maybe (λ t' → hnfNorm Γ $ subst t' t₁) (t ⟪$⟫ t₁) $ stripBinder (hnfNorm Γ t)
{-# CATCHALL #-}
hnfNorm Γ v             = v

stripBinderPure : PureTerm → Maybe PureTerm
stripBinderPure (Lam-P  _ t')     = just t'
stripBinderPure (Pi-P   _ t' t'') = just t''
stripBinderPure (All-P  _ t' t'') = just t''
stripBinderPure (Iota-P _ t' t'') = just t''
{-# CATCHALL #-}
stripBinderPure _                 = nothing

hnfNormPure normalizePure : Context → PureTerm → PureTerm

{-# NON_TERMINATING #-}
hnfNormPure Γ v@(Var-P x) with lookupInContext x Γ
... | just (Let x₁ x₂)         = hnfNormPure Γ $ Erase x₁
... | just (Axiom x₁)          = v -- we cannot reduce axioms
... | nothing                  = v -- in case the lookup fails, we cannot reduce
hnfNormPure Γ v@(App-P t t₁) with stripBinderPure (hnfNormPure Γ t)
... | (just t')                = hnfNormPure Γ $ substPure t' t₁
... | nothing                  = v
hnfNormPure Γ v@(CharEq-P _ _) = normalizePure Γ v -- reduce to a bool, if possible
{-# CATCHALL #-}
hnfNormPure Γ v                = v

{-# NON_TERMINATING #-}
normalizePure Γ v@(Var-P x) with efficientLookupInContext x Γ
... | just (EfficientLet x₁ x₂ x₃) = x₂
... | just (EfficientAxiom x₁)     = v -- we cannot reduce axioms
... | nothing                      = v -- in case the lookup fails, we cannot reduce
normalizePure Γ v@(Sort-P x)       = v
normalizePure Γ v@(Const-P x)      = v
normalizePure Γ (App-P t t₁) with hnfNormPure Γ t
...| t' = case stripBinderPure t' of λ where
    (just t'') → normalizePure Γ (substPure t'' t₁)
    nothing    → normalizePure Γ t' ⟪$⟫ normalizePure Γ t₁
normalizePure Γ (Lam-P n t) with normalizePure Γ t
... | t''@(App-P t' (Var-P (Bound i))) = if i ≣ (fromℕ 0) ∧ validInContext t' Γ
  then normalizePure Γ (decrementIndicesPure t') else Lam-P n t'' -- eta reduce here
... | t'' = Lam-P n t''
normalizePure Γ (Pi-P n t t₁)      = Pi-P n (normalizePure Γ t) (normalizePure Γ t₁)
normalizePure Γ (All-P n t t₁)     = All-P n (normalizePure Γ t) (normalizePure Γ t₁)
normalizePure Γ (Iota-P n t t₁)    = Iota-P n (normalizePure Γ t) (normalizePure Γ t₁)
normalizePure Γ (Eq-P t t₁)        = Eq-P (normalizePure Γ t) (normalizePure Γ t₁)
normalizePure Γ (M-P t)            = M-P (normalizePure Γ t)
normalizePure Γ (Mu-P t t₁)        = Mu-P (normalizePure Γ t) (normalizePure Γ t₁)
normalizePure Γ (Epsilon-P t)      = Epsilon-P (normalizePure Γ t)
normalizePure Γ (Gamma-P t t₁)     = Gamma-P (normalizePure Γ t) (normalizePure Γ t₁)
normalizePure Γ (Ev-P m args)      = Ev-P m (mapPrimMetaArgs (normalizePure Γ) args)
normalizePure Γ (Char-P c)         = (Char-P c)
normalizePure Γ (CharEq-P t t₁) with normalizePure Γ t | normalizePure Γ t₁
... | (Char-P c) | (Char-P c')     = normalizePure Γ $ FreeVar $ show (c ≣ c')
{-# CATCHALL #-}
... | x | x₁                       = CharEq-P x x₁

{-# TERMINATING #-}
findOutermostConstructor : PureTerm → PureTerm × List PureTerm
findOutermostConstructor t = outermostApp $ stripBinders t
  where
    stripBinders : PureTerm → PureTerm
    stripBinders t with stripBinderPure t
    stripBinders t | just x = stripBinders x
    stripBinders t | nothing = t

    outermostApp : PureTerm → PureTerm × List PureTerm
    outermostApp (App-P t t₁) = Data.Product.map id (t₁ ∷_) $ outermostApp t
    {-# CATCHALL #-}
    outermostApp t = t , []

insertInGlobalContext : GlobalName → Def → GlobalContext → String ⊎ GlobalContext
insertInGlobalContext n d Γ =
  if is-just $ lookup n Γ
    then inj₁ ("The name" <+> n <+> "is already defined!")
    else (inj₂ $ insert n (toEfficientDef d Γ) Γ)
  where
    toEfficientDef : Def → GlobalContext → EfficientDef
    toEfficientDef (Let x x₁) Γ = EfficientLet x (normalizePure (globalToContext Γ) $ Erase x) x₁
    toEfficientDef (Axiom x) Γ = EfficientAxiom x

module CheckEquality {{_ : Monad M}} {{_ : MonadExcept M String}} (Γ : Context) where

  compareNames : PureTerm → PureTerm → M ⊤
  compareNames (Var-P x) (Var-P x₁) =
    if x ≣ x₁
      then return tt
      else throwError "Names not equal! If you see this message, this is a bug!"
  {-# CATCHALL #-}
  compareNames _ _ = throwError "Terms are not names! If you see this message, this is a bug!"

  {-# NON_TERMINATING #-}
  checkβηPure : PureTerm → PureTerm → M ⊤
  checkβηPure t t' =
    tryElse (compareNames t t') $
    compareHnfs (hnfNormPure Γ t) (hnfNormPure Γ t')
    -- tryElse (compareHnfs (hnfNormPure Γ t) (hnfNormPure Γ t')) $
    -- pureTermBeq t t'
    where
      hnfError : PureTerm → PureTerm → M ⊤
      hnfError t t' =
        throwError $ "The terms" <+> show t <+> "and" <+> show t' <+> "aren't equal!"

      compareHnfs : PureTerm → PureTerm → M ⊤
      compareHnfs (Var-P x) (Var-P x₁) = beqMonadHelper x x₁ "Name"
      compareHnfs (Sort-P x) (Sort-P x₁) = beqMonadHelper x x₁ "Sort"
      compareHnfs (Const-P x) (Const-P x₁) = beqMonadHelper x x₁ "Const"
      compareHnfs (App-P t t₁) (App-P x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (Lam-P _ t) (Lam-P _ t₁) = checkβηPure t t₁
      compareHnfs (Pi-P _ t t₁) (Pi-P _ x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (All-P _ t t₁) (All-P _ x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (Iota-P _ t t₁) (Iota-P _ x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (Eq-P t t₁) (Eq-P x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (M-P t) (M-P x) = checkβηPure x t
      compareHnfs (Mu-P t t₁) (Mu-P x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (Epsilon-P t) (Epsilon-P x) = checkβηPure t x
      compareHnfs (Gamma-P t t₁) (Gamma-P x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs t@(Ev-P m x) t'@(Ev-P m' x') with m ≟ m'
      ... | yes refl = void $ primMetaArgsSequence $ primMetaArgsZipWith checkβηPure x x'
      ... | no  _    = hnfError t t'
      compareHnfs (Char-P c) (Char-P c') = beqMonadHelper c c' "Char"
      compareHnfs (CharEq-P t t₁) (CharEq-P x x₁) = checkβηPure t x >> checkβηPure t₁ x₁
      compareHnfs (Lam-P _ t) t₁ = case normalizePure Γ t of λ where
        t''@(App-P t' (Var-P (Bound i))) → if i ≣ (fromℕ 0) ∧ validInContext t' Γ
          then (compareHnfs (decrementIndicesPure t') t₁) else hnfError t'' t₁
        t'' → hnfError t'' t₁
      compareHnfs t (Lam-P _ t₁) = case normalizePure Γ t₁ of λ where
        t''@(App-P t' (Var-P (Bound i))) → if i ≣ (fromℕ 0) ∧ validInContext t' Γ
          then (compareHnfs t (decrementIndicesPure t')) else hnfError t t''
        t'' → hnfError t t''
      {-# CATCHALL #-}
      compareHnfs t t' = hnfError t t'

  checkβη : AnnTerm → AnnTerm → M ⊤
  checkβη t t' = checkβηPure (Erase t) (Erase t')

open CheckEquality public

{-# TERMINATING #-}
synthType synthType' :
  {{_ : Monad M}} {{_ : MonadExcept M String}} → Context → AnnTerm → M AnnTerm

synthType Γ t =
  appendIfError (synthType' Γ t) $
    "\n\nWhile synthesizing type for" <+> shortenString 1000 (show t) <+> "in context:\n" + show {{Context-Show}} Γ

synthType' Γ (Var-A x) =
  maybeToError
    (typeOfDef <$> lookupInContext x Γ)
    ("Lookup failed:" <+> show x <+> "in context" <+> show {{Context-Show}} Γ)
synthType' Γ (Sort-A ⋆) = return $ Sort-A □
synthType' Γ (Sort-A □) = throwError "Cannot synthesize type for the superkind"

synthType' Γ (Const-A CharT) = return $ Sort-A ⋆

synthType' Γ (Pr1-A t) = do
  T ← synthType Γ t
  case (hnfNorm Γ T) of λ
    { (Iota-A _ u u₁) → return u
    ; _ → throwError "Term does not normalize to an iota term" }

synthType' Γ (Pr2-A t) = do
  T ← synthType Γ t
  case (hnfNorm Γ T) of λ
    { (Iota-A _ u u₁) → return $ subst u₁ (Pr1-A t)
    ; _ → throwError "Term does not normalize to an iota term" }

synthType' Γ (Beta-A t t₁) = do
  T ← synthType Γ (Eq-A t t)
  case (hnfNorm Γ T) of λ
    { (Sort-A ⋆) → return $ Eq-A t t
    ; _ → throwError "Equality type does not have the right type. Is this a bug?" }

synthType' Γ (Delta-A t t₁) = do
  T ← synthType Γ t₁
  case (hnfNorm Γ T) of λ
    { (Eq-A u u₁) → do
      catchError
        (pureTermBeq (normalizePure Γ $ Erase u) (Lam-P "" $ Lam-P "" $ BoundVar $ fromℕ 1) >>
         pureTermBeq (normalizePure Γ $ Erase u₁) (Lam-P "" $ Lam-P "" $ BoundVar $ fromℕ 0))
        (λ e → throwError $
          "This equality cannot be used for the delta term:" <+> show u
          <+> "=" <+> show u₁ + "\nError:" <+> e)
      return t
    ; _ → throwError "The second argument of a delta needs to be of an eq type" }

synthType' Γ (Sigma-A t) = do
  T ← synthType Γ t
  case (hnfNorm Γ T) of λ
    { (Eq-A u u₁) → return $ Eq-A u₁ u
    ; _ → throwError "Sigma needs an inhabitant of an eq type as argument" }

synthType' Γ (App-A t t₁) = do
  T ← synthType Γ t
  T₁ ← synthType Γ t₁
  case (hnfNorm Γ T) of λ
    { (Pi-A _ u u₁) → do
      catchError
        (checkβη Γ T₁ u)
        (λ e → throwError ("Type mismatch in application, the type of" <+> show t₁
          <+> ":" <+> show T₁ +  " is not βη-equivalent to" <+> show u + "\nError:" <+> e))
      return $ subst u₁ t₁
    ; v → throwError $
      "The left term in an application needs to have a pi type, while it has type" <+> show v }

synthType' Γ (AppE-A t t₁) = do
  T ← synthType Γ t
  T₁ ← synthType Γ t₁
  case (hnfNorm Γ T) of λ
    { (All-A _ u u₁) → do
      catchError (checkβη Γ u T₁)
        (λ e → throwError
          ("Type mismatch in erased application, the following types are not βη-equivalent:\n"
            + show u + "\n" + show T₁ + "\nError:\n" + e))
      return $ subst u₁ t₁
    ; v → throwError $
      "The left term in an erased application needs to have a forall type, while it has type "
        + show v + "\nTest:" <+> show T }

synthType' Γ (Rho-A t t₁ t₂) = do
  T ← synthType Γ t
  T₁ ← synthType Γ t₂
  case (hnfNorm Γ T) of λ
    { (Eq-A u u₁) → do
      catchError (checkβη Γ (subst t₁ u₁) T₁)
        (λ e → throwError $ "Type mismatch in rho:" <+> show (subst t₁ u₁)
          <+> "should be βη-equivalent to the synthesized type of" <+> show t₂ <+> ": "
          + show T₁ + "\nError:\n" + e)
      return $ subst t₁ u
    ; _ → throwError "The type of the first argument of a rho needs to be an equality" }

synthType' Γ (All-A _ t t₁) = do
  u ← synthType Γ t
  case (hnfNorm Γ u) of λ
    { (Sort-A s) → do
      let Γ' = pushVar t Γ
      u₁ ← synthType Γ' t₁
      case (hnfNorm Γ' u₁) of λ
        { (Sort-A ⋆) → return $ Sort-A ⋆
        ; v → throwError $
          "The type family in forall should have type star, while it has type "
          + show v <+> "(" + show t₁ + ")\nContext:" <+> show {{Context-Show}} Γ' }
    ; _ → throwError "The type of the parameter type in forall should be star or square" }

synthType' Γ (Pi-A _ t t₁) = do
  u ← synthType Γ t
  case (hnfNorm Γ u) of λ
    { (Sort-A s) → do
      let Γ' = pushVar t Γ
      u₁ ← synthType Γ' t₁
      case (hnfNorm Γ u₁) of λ
        { (Sort-A s') → return $ Sort-A s'
        ; v → throwError $
          "The type family in pi should have type star or square, while it has type" <+> show v }
    ; _ → throwError "The type of the parameter type in pi should be star or square" }

synthType' Γ (Iota-A _ t t₁) = do
  u ← synthType Γ t
  case (hnfNorm Γ u) of λ
    { (Sort-A ⋆) → do
      let Γ' = pushVar t Γ
      u₁ ← synthType Γ' t₁
      case (hnfNorm Γ' u₁) of λ
        { (Sort-A ⋆) → return $ Sort-A ⋆
        ; _ → throwError "The type family in iota should have type star"}
    ; _ → throwError "The type of the parameter type in iota should be star" }

synthType' Γ (Lam-A n t t₁) = do
  synthType Γ t
  u ← synthType (pushVar t Γ) t₁
  return (Pi-A n t u)

synthType' Γ (LamE-A n t t₁) =
  if checkFree (Bound (fromℕ 0)) (Erase t₁)
    then throwError "Erased arguments cannot appear bound in a term"
    else do
      synthType Γ t
      u ← synthType (pushVar t Γ) t₁
      return $ All-A n t u

synthType' Γ (Pair-A t t₁ t₂) = do
  catchError (checkβη Γ t t₁)
    (λ e → throwError $
      "The terms in dependent intersection introduction have to be βη-equivalent. They normalize to:\n"
        + show (normalizePure Γ $ Erase t) + "\n"
        + show (normalizePure Γ $ Erase t₁) + "\nError:\n" + e)
  u ← synthType Γ t
  u₁ ← synthType Γ t₁
  catchError
    (checkβη Γ (subst t₂ t) u₁)
    (λ e → throwError
      ("Type mismatch in the second argument of the dependent intersection: "
        + show (subst t₂ t) <+> "should be βη-equivalent to the synthesized type "
        + show u₁ + "\n" + e))
  let res = Iota-A "" u t₂
  u₂ ← synthType Γ res
  case (hnfNorm Γ u₂) of λ
    { (Sort-A ⋆) → return res
    ; _ → throwError
      "The resulting iota type of the dependent intersection doesn't have type star. Is this a Bug?" }

synthType' Γ (Phi-A t t₁ t₂) = do
  T ← synthType Γ t
  case (hnfNorm Γ T) of λ
    { (Eq-A u u₁) → do
      catchError
        (checkβη Γ t₁ u >> checkβη Γ t₂ u₁)
        (λ e → throwError $
          "The arguments to phi are not equivalent to the sides of the equality. Error:\n" + e)
      synthType Γ t₁
    ; _ → throwError "The first argument to phi should be of an equality type" }

synthType' Γ (Eq-A x x₁) =
  if validInContext (Erase x) Γ
    then if validInContext (Erase x₁) Γ
      then return $ Sort-A ⋆
      else throwError
        ("The right term in the equality type needs to be valid in the context:" <+> show x₁)
    else throwError
      ("The left term in the equality type needs to be valid in the context:" <+> show x)

synthType' Γ (M-A t) = do
  T ← synthType Γ t
  case (hnfNorm Γ T) of λ
    { (Sort-A ∗) → return $ Sort-A ∗
    ; _ → throwError "The term M is applied to should have type ∗"}

synthType' Γ (Mu-A t t₁) = do
  T ← synthType Γ t
  T' ← synthType Γ t₁
  case (hnfNorm Γ T) of λ
    { (M-A u) →
      case (hnfNorm Γ T') of λ
        { (Pi-A _ v v₁) → do
          T'' ← if checkFree (Bound $ fromℕ 0) (Erase v₁)
            then throwError ("Index 0 is not allowed to appear in" <+> show v₁)
            else synthType (pushVar v Γ) v₁
          case (hnfNorm Γ T'') of λ
            { (Sort-A ∗) →
              case (hnfNorm Γ v₁) of λ
                { (M-A v₂) →
                  appendIfError
                    (checkβη Γ u v)
                    "The types in μ need to be compatible" >> return (M-A $ decrementIndices v₂)
                ; _ → throwError
                  "The second term in a μ needs to have a Pi type that maps to 'M t' for some 't'" }
            ; _ → throwError "The second term in a μ needs to have a non-dependent Pi type" }
        ; _ → throwError "The second term in a μ needs to have a Pi type" }
    ; _ → throwError "The first term in a μ needs to have type 'M t' for some 't'" }

synthType' Γ (Epsilon-A t) = M-A <$> synthType Γ t

synthType' Γ (Ev-A m t) = do
  T ← traversePrimMetaArgs (synthType Γ) t
  appendIfError
    (primMetaArgsSequence $ primMetaArgsZipWith (checkβη Γ) T $ primMetaS m)
    ("The arguments for primitive" <+> show m <+> "have incorrect types!")
  return $ M-A $ primMetaT m t

synthType' Γ (Gamma-A t t₁) = do
  T ← synthType Γ t
  T₁ ← synthType Γ t₁
  case (hnfNorm Γ T) of λ
    { (M-A u) → do
      appendIfError (checkβη Γ T₁ (Pi-A "" (FreeVar "init$err") (incrementIndicesBy (fromℕ 1) $ M-A u)))
        ("The second term supplied to CatchErr has type" <+> show T₁ +
         ", while it should have type 'init$err → M" <+> show u)
      return $ M-A u
    ; _ → throwError "The first term in CatchErr needs to have type 'M t' for some 't'" }

synthType' Γ (Char-A c) = return (Const-A CharT)
synthType' Γ (CharEq-A t t') = do
  T ← synthType Γ t
  T' ← synthType Γ t'
  case (hnfNorm Γ T) of λ
    { (Const-A CharT) → case (hnfNorm Γ T') of λ
      { (Const-A CharT) → return $ FreeVar "Bool"
      ; _ → throwError "The second term in CharEq needs to have type Char" }
    ; _ → throwError "The first term in CharEq needs to have type Char" }


open import Agda.Builtin.String
open import Agda.Builtin.Equality

test : String → String → String
test "x" b = "left"
test a "x" = "right"
test a b = "nowhere"

_ : test "a" "x" ≡ "right"
_ = refl


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

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

module Dijkstra.EitherD where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Haskell.Prelude

data EitherD (E : Set) : Set → Set₁ where
  -- Primitive combinators
  EitherD-return : ∀ {A} → A → EitherD E A
  EitherD-bind   : ∀ {A B} → EitherD E A → (A → EitherD E B) → EitherD E B
  EitherD-bail   : ∀ {A} → E → EitherD E A
  -- Branching conditionals (used for creating more convenient contracts)
  EitherD-if     : ∀ {A} → Guards (EitherD E A) → EitherD E A
  EitherD-either : ∀ {A B C}
                   → (B → EitherD E A) → (C → EitherD E A) → Either B C → EitherD E A
  EitherD-maybe  : ∀ {A B} → EitherD E B → (A → EitherD E B) → Maybe A → EitherD E B

pattern LeftD  x = EitherD-bail   x
pattern RightD x = EitherD-return x

private
  variable
    E : Set
    A B C : Set

EitherD-run : EitherD E A → Either E A
EitherD-run (EitherD-return x) = Right x
EitherD-run (EitherD-bind m f)
  with EitherD-run m
... | Left x = Left x
... | Right y = EitherD-run (f y)
EitherD-run (EitherD-bail x) = Left x
EitherD-run (EitherD-if (clause (b ≔ c) gs)) =
  if toBool b then EitherD-run c else EitherD-run (EitherD-if gs)
EitherD-run (EitherD-if (otherwise≔ c)) =
  EitherD-run c
EitherD-run (EitherD-either f₁ f₂ (Left x))  = EitherD-run (f₁ x)
EitherD-run (EitherD-either f₁ f₂ (Right y)) = EitherD-run (f₂ y)
EitherD-run (EitherD-maybe n s nothing ) = EitherD-run n
EitherD-run (EitherD-maybe n s (just x)) = EitherD-run (s x)

EitherD-Pre : (E A : Set) → Set₁
EitherD-Pre E A = Set

EitherD-Post : (E A : Set) → Set₁
EitherD-Post E A = Either E A → Set

EitherD-Post-⇒ : ∀ {E} {A} → (P Q : EitherD-Post E A) → Set
EitherD-Post-⇒ P Q = ∀ r → P r → Q r

EitherD-PredTrans : (E A : Set) → Set₁
EitherD-PredTrans E A = EitherD-Post E A → EitherD-Pre E A

EitherD-weakestPre-bindPost : (f : A → EitherD E B) → EitherD-Post E B → EitherD-Post E A

EitherD-weakestPre : (m : EitherD E A) → EitherD-PredTrans E A
EitherD-weakestPre (EitherD-return x) P = P (Right x)
EitherD-weakestPre (EitherD-bind m f) P =
  EitherD-weakestPre m (EitherD-weakestPre-bindPost f P)
EitherD-weakestPre (EitherD-bail x) P = P (Left x)
EitherD-weakestPre (EitherD-if (clause (b ≔ c) gs)) P =
  (toBool b ≡ true → EitherD-weakestPre c P)
  × (toBool b ≡ false → EitherD-weakestPre (EitherD-if gs) P)
EitherD-weakestPre (EitherD-if (otherwise≔ x)) P =
  EitherD-weakestPre x P
EitherD-weakestPre (EitherD-either f₁ f₂ e) P =
  (∀ x → e ≡ Left x → EitherD-weakestPre (f₁ x) P)
  × (∀ y → e ≡ Right y → EitherD-weakestPre (f₂ y) P)
EitherD-weakestPre (EitherD-maybe n s m) P =
  (m ≡ nothing → EitherD-weakestPre n P)
  × (∀ j → m ≡ just j → EitherD-weakestPre (s j) P)

EitherD-weakestPre-bindPost f P (Left x) =
  P (Left x)
EitherD-weakestPre-bindPost f P (Right y) =
  ∀ c → c ≡ y → EitherD-weakestPre (f c) P

EitherD-Contract : (m : EitherD E A) → Set₁
EitherD-Contract{E}{A} m =
  (P : EitherD-Post E A)
  → EitherD-weakestPre m P → P (EitherD-run m)

EitherD-contract : (m : EitherD E A) → EitherD-Contract m
EitherD-contract (EitherD-return x) P wp = wp
EitherD-contract (EitherD-bind m f) P wp
   with EitherD-contract m _ wp
...| wp'
   with EitherD-run m
... | Left x = wp'
... | Right y = EitherD-contract (f y) P (wp' y refl)
EitherD-contract (EitherD-bail x) P wp = wp
EitherD-contract{E}{A} (EitherD-if gs) P wp =
  EitherD-contract-if gs P wp
  where
  EitherD-contract-if : (gs : Guards (EitherD E A)) → EitherD-Contract (EitherD-if gs)
  EitherD-contract-if (clause (b ≔ c) gs) P wp
     with toBool b
  ... | false = EitherD-contract-if gs P (proj₂ wp refl)
  ... | true = EitherD-contract c P (proj₁ wp refl)
  EitherD-contract-if (otherwise≔ x) P wp = EitherD-contract x P wp
EitherD-contract (EitherD-either f₁ f₂ (Left x)) P wp =
  EitherD-contract (f₁ x) P (proj₁ wp x refl)
EitherD-contract (EitherD-either f₁ f₂ (Right y)) P wp =
  EitherD-contract (f₂ y) P (proj₂ wp y refl)
EitherD-contract (EitherD-maybe f₁ f₂ nothing) P wp =
  EitherD-contract f₁ P (proj₁ wp refl)
EitherD-contract (EitherD-maybe f₁ f₂ (just x)) P wp =
  EitherD-contract (f₂ x) P (proj₂ wp x refl)

EitherD-⇒
  : ∀ {E A} {P Q : EitherD-Post E A}
  → ∀ m → EitherD-weakestPre m P
  → (EitherD-Post-⇒ P Q)
  → EitherD-weakestPre m Q
EitherD-⇒ {P = Post₁} {Post₂} (LeftD x )         pre pf = pf (Left x ) pre
EitherD-⇒ {P = Post₁} {Post₂} (RightD x)         pre pf = pf (Right x) pre
EitherD-⇒ {P = Post₁} {Post₂} (EitherD-bind m x) pre pf =
  EitherD-⇒ m pre P⇒Q
  where
    P⇒Q : EitherD-Post-⇒ (EitherD-weakestPre-bindPost x Post₁)
                         (EitherD-weakestPre-bindPost x Post₂)
    P⇒Q (Left  rL) Pr = pf (Left rL) Pr
    P⇒Q (Right rR) Pr .rR refl = EitherD-⇒ (x rR) (Pr rR refl) pf
EitherD-⇒ {Post₁} {Post₂} (EitherD-if (otherwise≔ x)) pre pf = EitherD-⇒ x pre pf
EitherD-⇒ {Post₁} {Post₂} (EitherD-if (clause (x ≔ x₂) x₁)) (pre₁ , pre₂) pf =
    (λ x≡true  → EitherD-⇒ x₂ (pre₁ x≡true) pf)
  , (λ x≡false → EitherD-⇒ (EitherD-if x₁) (pre₂ x≡false) pf)
proj₁ (EitherD-⇒ {Post₁} {Post₂} (EitherD-either x₁ x₂ (Left  x)) (pre₁ , pre₂) pf) .x refl =
       EitherD-⇒ (x₁ x) (pre₁ x refl) pf
proj₂ (EitherD-⇒ {Post₁} {Post₂} (EitherD-either x₁ x₂ (Right x)) (pre₁ , pre₂) pf) .x refl =
       EitherD-⇒ (x₂ x) (pre₂ x refl) pf
proj₁ (EitherD-⇒ {Post₁} {Post₂} (EitherD-maybe m x₁ .nothing) (pre₁ , pre₂) pf) refl   =
       EitherD-⇒ m      (pre₁   refl) pf
proj₂ (EitherD-⇒ {Post₁} {Post₂} (EitherD-maybe m x₁ (just x)) (pre₁ , pre₂) pf) j refl =
       EitherD-⇒ (x₁ j) (pre₂ j refl) pf

EitherD-⇒-bind :
    ∀ {E} {A} {P : EitherD-Post E A}
    → {Q : EitherD-Post E B}
    → {f : A → EitherD E B}
    → ∀ m → EitherD-weakestPre m P
    → EitherD-Post-⇒ P (EitherD-weakestPre-bindPost f Q)
    → EitherD-weakestPre (EitherD-bind m f) Q
EitherD-⇒-bind = EitherD-⇒

EitherD-vacuous : ∀ (m : EitherD E A) → EitherD-weakestPre m (const Unit)
EitherD-vacuous (LeftD x)                        = unit
EitherD-vacuous (RightD x)                       = unit
EitherD-vacuous (EitherD-if (otherwise≔ x))      = EitherD-vacuous x
EitherD-vacuous (EitherD-if (clause (b ≔ x) x₁)) = (const (EitherD-vacuous x)) , (const (EitherD-vacuous (EitherD-if x₁)))
EitherD-vacuous (EitherD-either x₁ x₂ x)         = (λ x₃ _ → EitherD-vacuous (x₁ x₃)) , (λ y _ → EitherD-vacuous (x₂ y))
EitherD-vacuous (EitherD-maybe m x₁ x)           = (const (EitherD-vacuous m)) , λ j _ → EitherD-vacuous (x₁ j)
EitherD-vacuous (EitherD-bind m x)               = EitherD-⇒-bind m (EitherD-vacuous m) λ { (Left  _) _ → unit
                                                                                ; (Right _) _ → λ c _ → EitherD-vacuous (x c) }


-- P: (vcd) <E[send c v]> | <F[recv d]>  --> (vcd) <E[c]> | <F[(d,v)]>

-- P: (vcd) <E[close c]> | <F[wait d]>  --> (vcd) <E[()]> | <F[()]>
module Properties.StepCloseWait 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 Syntax
open import Global
open import Channel
open import Values
open import Session
open import Schedule

open import ProcessSyntax
open import ProcessRun

open import Properties.Base

mkclose : ∀ {Φ} → Expr (TUnit ∷ Φ) TUnit → Expr (TChan send! ∷ Φ) TUnit
mkclose = λ e → letbind (left (split-all-right _)) (close (here [])) e

mkwait : ∀ {Φ} → Expr (TUnit ∷ Φ) TUnit → Expr (TChan send? ∷ Φ) TUnit
mkwait = λ e → letbind (left (split-all-right _)) (wait (here [])) e

module General where

  mklhs : ∀ {Φ Φ₁ Φ₂}
    → Split Φ Φ₁ Φ₂
    → Expr (TUnit ∷ Φ₁) TUnit
    → Expr (TUnit ∷ Φ₂) TUnit
    → Proc Φ
  mklhs sp e f =
    res (delay send!)
        (par (left (rght sp))
             (exp (mkclose e)) (exp (mkwait f)))

  mkrhs : ∀ {Φ Φ₁ Φ₂}
    → Split Φ Φ₁ Φ₂
    → Expr (TUnit ∷ Φ₁) TUnit
    → Expr (TUnit ∷ Φ₂) TUnit
    → Proc Φ
  mkrhs sp e f =
    par sp (exp (letbind (split-all-right _) (unit []) e))
           (exp (letbind (split-all-right _) (unit []) f))

  -- obviously true, but requires a nasty inductive proof
  postulate
    weaken2-ident : ∀ {G Φ} (ϱ : VEnv G Φ) → weaken2-venv [] [] ϱ ≡ ϱ

  postulate
    weaken1-ident : ∀ {G Φ} (ϱ : VEnv G Φ) → weaken1-venv [] ϱ ≡ ϱ

  reductionT : Set
  reductionT =
    ∀ { Φ Φ₁ Φ₂ }
    (sp : Split Φ Φ₁ Φ₂)
    (ϱ : VEnv [] Φ)
    (p : ∃ λ ϱ₁ → ∃ λ ϱ₂ →
           split-env sp (lift-venv ϱ) ≡ (((nothing ∷ []) , (nothing ∷ [])) , (ss-both ss-[]) , ϱ₁ , ϱ₂))
    (e : Expr (TUnit ∷ Φ₁) TUnit)
    (f : Expr (TUnit ∷ Φ₂) TUnit) →
    let lhs = (runProc [] (mklhs sp e f) ϱ) in
    let rhs = (runProc [] (mkrhs sp e f) ϱ) in
    one-step lhs ≡
    (Closed , nothing ∷ proj₁ rhs , lift-threadpool (proj₂ rhs))

  reduction : reductionT
  reduction{Φ}{Φ₁}{Φ₂} sp ϱ p e f
    with ssplit-refl-left-inactive []
  ... | G' , ina-G' , ss-GG'
    with split-env-lemma-2 sp ϱ
  ... | ϱ₁ , ϱ₂ , spe== , sp==
    rewrite spe== | sp==
    with ssplit-compose{just (send! , POSNEG) ∷ []} (ss-posneg ss-[]) (ss-left ss-[])
  ... | ssc
    rewrite split-env-right-lemma ϱ₁
    with ssplit-compose{just (send! , POSNEG) ∷ []} (ss-left ss-[]) (ss-left ss-[])
  ... | ssc-ll
    rewrite split-env-right-lemma ϱ₂
    with ssplit-compose2 (ss-both ss-[]) (ss-both ss-[])
  ... | ssc2
    rewrite weaken2-ident (lift-venv ϱ₁)
          | split-rotate-lemma {Φ₁}
          | split-rotate-lemma {Φ₂}
          | split-env-right-lemma0 ϱ₁
          | split-env-right-lemma0 ϱ₂
          | weaken2-ident ϱ₁
          | weaken1-ident (lift-venv ϱ₂)
          | weaken1-ident ϱ₂
    = refl

module ClosedWithContext where
  mklhs : Expr (TUnit ∷ []) TUnit
    → Expr (TUnit ∷ []) TUnit
    → Proc []
  mklhs e f =
    res (delay send!)
        (par (left (rght []))
             (exp (mkclose e)) (exp (mkwait f)))

  mkrhs : Expr (TUnit ∷ []) TUnit
    → Expr (TUnit ∷ []) TUnit
    → Proc []
  mkrhs e f =
    par [] (exp (letbind [] (unit []) e))
           (exp (letbind [] (unit []) f))

  reduction :
    (e f : Expr (TUnit ∷ []) TUnit) →
    let lhs = (runProc [] (mklhs e f) (vnil []-inactive)) in
    let rhs = (runProc [] (mkrhs e f) (vnil []-inactive)) in
    one-step lhs ≡
    (Closed , nothing ∷ proj₁ rhs , lift-threadpool (proj₂ rhs))
  reduction e f
    with ssplit-refl-left-inactive []
  ... | G' , ina-G' , ss-GG'
    = refl


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.ShapeView {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Agda.Primitive

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Reflexivity

open import Tools.Embedding
open import Tools.Product
open import Tools.Empty using (⊥; ⊥-elim ; ⊥-elimω)
import Tools.PropositionalEquality as PE

-- Type for maybe embeddings of reducible types
data MaybeEmb (l : TypeLevel) (⊩⟨_⟩ : TypeLevel → Set) : Set where
  noemb : ⊩⟨ l ⟩ → MaybeEmb l ⊩⟨_⟩
  emb   : ∀ {l′} → l′ < l → MaybeEmb l′ ⊩⟨_⟩ → MaybeEmb l ⊩⟨_⟩

-- Specific reducible types with possible embedding

_⊩⟨_⟩U : (Γ : Con Term) (l : TypeLevel) → Set
Γ ⊩⟨ l ⟩U = MaybeEmb l (λ l′ → Γ ⊩′⟨ l′ ⟩U)

_⊩⟨_⟩ℕ_ : (Γ : Con Term) (l : TypeLevel) (A : Term) → Set
Γ ⊩⟨ l ⟩ℕ A = MaybeEmb l (λ l′ → Γ ⊩ℕ A)

_⊩⟨_⟩ne_ : (Γ : Con Term) (l : TypeLevel) (A : Term) → Set
Γ ⊩⟨ l ⟩ne A = MaybeEmb l (λ l′ → Γ ⊩ne A)

data _⊩⟨_⟩Π_ (Γ : Con Term) (l : TypeLevel) (A : Term) : Setω where
  noemb : Γ ⊩′⟨ l ⟩Π A → Γ ⊩⟨ l ⟩Π A
  emb : ∀ {l′} → l′ < l → Γ ⊩⟨ l′ ⟩Π A → Γ ⊩⟨ l ⟩Π A

-- -- Construct a general reducible type from a specific

U-intr : ∀ {Γ l} → Γ ⊩⟨ l ⟩U → Γ ⊩⟨ l ⟩ U
U-intr (noemb (Uᵣ l′ l< ⊢Γ)) = Uᵣ′ l′ l< ⊢Γ
U-intr (emb 0<1 x) = emb′ 0<1 (U-intr x)

ℕ-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩ℕ A → Γ ⊩⟨ l ⟩ A
ℕ-intr (noemb x) = ℕᵣ x
ℕ-intr (emb 0<1 x) = emb′ 0<1 (ℕ-intr x)

ne-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩ne A → Γ ⊩⟨ l ⟩ A
ne-intr (noemb x) = LRPack _ _ _ (LRne x)
ne-intr (emb 0<1 x) = emb′ 0<1 (ne-intr x)

Π-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩Π A → Γ ⊩⟨ l ⟩ A
Π-intr (noemb x) = LRPack _ _ _ (LRΠ x)
Π-intr (emb 0<1 x) = emb′ 0<1 (Π-intr x)

-- -- Construct a specific reducible type from a general with some criterion

U-elim : ∀ {Γ l} → Γ ⊩⟨ l ⟩ U → Γ ⊩⟨ l ⟩U
U-elim (Uᵣ′ l′ l< ⊢Γ) = noemb (Uᵣ l′ l< ⊢Γ)
U-elim (ℕᵣ D) = ⊥-elim (U≢ℕ (whnfRed* (red D) Uₙ))
U-elim (ne′ K D neK K≡K) = ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
U-elim (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = ⊥-elim (U≢Π (whnfRed* (red D) Uₙ))
U-elim (emb′ 0<1 x) with U-elim x
U-elim (emb′ 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
U-elim (emb′ 0<1 x) | emb () x₁

ℕ-elim′ : ∀ {A Γ l} → Γ ⊢ A ⇒* ℕ → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩ℕ A
ℕ-elim′ D (Uᵣ′ l′ l< ⊢Γ) = ⊥-elim (U≢ℕ (whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , ℕₙ)))
ℕ-elim′ D (ℕᵣ D′) = noemb D′
ℕ-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (ℕ≢ne neK (whrDet* (D , ℕₙ) (red D′ , ne neK)))
ℕ-elim′ D (Πᵣ′ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (ℕ≢Π (whrDet* (D , ℕₙ) (red D′ , Πₙ)))
ℕ-elim′ D (emb′ 0<1 x) with ℕ-elim′ D x
ℕ-elim′ D (emb′ 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
ℕ-elim′ D (emb′ 0<1 x) | emb () x₂

ℕ-elim : ∀ {Γ l} → Γ ⊩⟨ l ⟩ ℕ → Γ ⊩⟨ l ⟩ℕ ℕ
ℕ-elim [ℕ] = ℕ-elim′ (id (escape [ℕ])) [ℕ]

ne-elim′ : ∀ {A Γ l K} → Γ ⊢ A ⇒* K → Neutral K → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩ne A
ne-elim′ D neK (Uᵣ′ l′ l< ⊢Γ) =
  ⊥-elim (U≢ne neK (whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , ne neK)))
ne-elim′ D neK (ℕᵣ D′) = ⊥-elim (ℕ≢ne neK (whrDet* (red D′ , ℕₙ) (D , ne neK)))
ne-elim′ D neK (ne′ K D′ neK′ K≡K) = noemb (ne K D′ neK′ K≡K)
ne-elim′ D neK (Πᵣ′ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Π≢ne neK (whrDet* (red D′ , Πₙ) (D , ne neK)))
ne-elim′ D neK (emb′ 0<1 x) with ne-elim′ D neK x
ne-elim′ D neK (emb′ 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
ne-elim′ D neK (emb′ 0<1 x) | emb () x₂

ne-elim : ∀ {Γ l K} → Neutral K  → Γ ⊩⟨ l ⟩ K → Γ ⊩⟨ l ⟩ne K
ne-elim neK [K] = ne-elim′ (id (escape [K])) neK [K]

Π-elim′ : ∀ {A Γ F G l} → Γ ⊢ A ⇒* Π F ▹ G → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩Π A
Π-elim′ D (Uᵣ′ l′ l< ⊢Γ) = ⊥-elimω (U≢Π (whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , Πₙ)))
Π-elim′ D (ℕᵣ D′) = ⊥-elimω (ℕ≢Π (whrDet* (red D′ , ℕₙ) (D , Πₙ)))
Π-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elimω (Π≢ne neK (whrDet* (D , Πₙ) (red D′ , ne neK)))
Π-elim′ D (Πᵣ′ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  noemb (Πᵣ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
Π-elim′ D (emb′ 0<1 x) with Π-elim′ D x
Π-elim′ D (emb′ 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
Π-elim′ D (emb′ 0<1 x) | emb () x₂

Π-elim : ∀ {Γ F G l} → Γ ⊩⟨ l ⟩ Π F ▹ G → Γ ⊩⟨ l ⟩Π Π F ▹ G
Π-elim [Π] = Π-elim′ (id (escape [Π])) [Π]

-- Extract a type and a level from a maybe embedding
extractMaybeEmb : ∀ {l ⊩⟨_⟩} → MaybeEmb l ⊩⟨_⟩ → ∃ λ l′ → ⊩⟨ l′ ⟩
extractMaybeEmb (noemb x) = _ , x
extractMaybeEmb (emb 0<1 x) = extractMaybeEmb x

extractMaybeEmbΠl : ∀ {Γ A l} → Γ ⊩⟨ l ⟩Π A → TypeLevel
extractMaybeEmbΠl {l = l} (noemb x) = l
extractMaybeEmbΠl (emb 0<1 x) = ⁰

extractMaybeEmbΠ : ∀ {Γ A l} → ([A] : Γ ⊩⟨ l ⟩Π A) → Γ ⊩′⟨ extractMaybeEmbΠl [A] ⟩Π A
extractMaybeEmbΠ {l = l} (noemb x) = x
extractMaybeEmbΠ (emb 0<1 (noemb x)) = x

-- emb, but with a propositional equality for the target level
emb″ : ∀ {Γ A} (l : TypeLevel) → (l PE.≡ ¹) → (p : Γ ⊩⟨ ⁰ ⟩ A) → Γ ⊩⟨ l ⟩ A
emb″ .¹ PE.refl p = emb′ 0<1 p

-- A view for constructor equality of types where embeddings are ignored
data ShapeView Γ (l l′ : TypeLevel) : ∀ A B (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ B)
     → Set (lsuc (lsuc (toLevel l ⊔ toLevel l′))) where
  Uᵥ : ∀ l'A l<A ⊢ΓA l'B l<B ⊢ΓB
    → ShapeView Γ l l′ U U
      (LRPack _ _ _ (LRU ⊢ΓA l'A l<A))
      (LRPack _ _ _ (LRU ⊢ΓB l'B l<B))
  ℕᵥ : ∀ {A B} ℕA ℕB
    → ShapeView Γ l l′ A B
      (LRPack _ _ _ (LRℕ ℕA))
      (LRPack _ _ _ (LRℕ ℕB))
  ne  : ∀ {A B} neA neB
      → ShapeView Γ l l′ A B
        (LRPack _ _ _ (LRne neA))
        (LRPack _ _ _ (LRne neB))
  Πᵥ : ∀ {A B} ΠA ΠB
     → ShapeView Γ l l′ A B
       (LRPack _ _ _ (LRΠ ΠA))
       (LRPack _ _ _ (LRΠ ΠB))
  emb⁰¹ : ∀ {A B p q}
        → (l≡ : l PE.≡ ¹)
        → ShapeView Γ ⁰ l′ A B p q
        → ShapeView Γ l l′ A B (emb″ l l≡ p) q
  emb¹⁰ : ∀ {A B p q}
        → (l≡ : l′ PE.≡ ¹)
        → ShapeView Γ l ⁰ A B p q
        → ShapeView Γ l l′ A B p (emb″ l′ l≡ q)

-- Construct an shape view from an equality
goodCases : ∀ {l l′ Γ A B} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
          → Γ ⊩⟨ l ⟩ A ≡ B / [A] → ShapeView Γ l l′ A B [A] [B]
goodCases (Uᵣ′ lA l<A ⊢ΓA) (Uᵣ′ lB l<B ⊢ΓB) A≡B = Uᵥ lA l<A ⊢ΓA lB l<B ⊢ΓB
goodCases (Uᵣ′ _ _ ⊢Γ) (ℕᵣ D) (U₌ PE.refl) = ⊥-elim (U≢ℕ (whnfRed* (red D) Uₙ))
goodCases (Uᵣ′ _ _ ⊢Γ) (ne′ K D neK K≡K) (U₌ PE.refl) = ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
goodCases (Uᵣ′ _ _ ⊢Γ) (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (U₌ PE.refl) =
  ⊥-elim (U≢Π (whnfRed* (red D) Uₙ))
goodCases (ℕᵣ D) (Uᵣ′ _ _ ⊢Γ) (ιx (ℕ₌ A≡B)) = ⊥-elim (U≢ℕ (whnfRed* A≡B Uₙ))
goodCases (ℕᵣ ℕA) (ℕᵣ ℕB) A≡B = ℕᵥ ℕA ℕB
goodCases (ℕᵣ D) (ne′ K D₁ neK K≡K) (ιx (ℕ₌ A≡B)) =
  ⊥-elim (ℕ≢ne neK (whrDet* (A≡B , ℕₙ) (red D₁ , ne neK)))
goodCases (ℕᵣ D) (Πᵣ′ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) (ιx (ℕ₌ A≡B)) =
  ⊥-elim (ℕ≢Π (whrDet* (A≡B , ℕₙ) (red D₁ , Πₙ)))
goodCases (ne′ K D neK K≡K) (Uᵣ′ _ _ ⊢Γ) (ιx (ne₌ M D′ neM K≡M)) =
  ⊥-elim (U≢ne neM (whnfRed* (red D′) Uₙ))
goodCases (ne′ K D neK K≡K) (ℕᵣ D₁) (ιx (ne₌ M D′ neM K≡M)) =
  ⊥-elim (ℕ≢ne neM (whrDet* (red D₁ , ℕₙ) (red D′ , ne neM)))
goodCases (ne′ K D neK K≡K) (ne′ K′ D′ neK′ K≡K′) A≡B = ne (ne K D neK K≡K) (ne K′ D′ neK′ K≡K′)
goodCases (ne′ K D neK K≡K) (Πᵣ′ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) (ιx (ne₌ M D′ neM K≡M)) =
  ⊥-elim (Π≢ne neM (whrDet* (red D₁ , Πₙ) (red D′ , ne neM)))
goodCases (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Uᵣ′ _ _ ⊢Γ)
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (U≢Π (whnfRed* D′ Uₙ))
goodCases (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ℕᵣ D₁)
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (ℕ≢Π (whrDet* (red D₁ , ℕₙ) (D′ , Πₙ)))
goodCases (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ne′ K D₁ neK K≡K)
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (Π≢ne neK (whrDet* (D′ , Πₙ) (red D₁ , ne neK)))
goodCases (LRPack _ _ _ (LRΠ ΠA)) (LRPack _ _ _ (LRΠ ΠB)) A≡B = Πᵥ ΠA ΠB
goodCases {l} [A] (emb′ 0<1 x) A≡B =
  emb¹⁰ PE.refl (goodCases {l} {⁰} [A] x A≡B)
goodCases {l′ = l} (emb′ 0<1 x) [B] (ιx A≡B) =
  emb⁰¹ PE.refl (goodCases {⁰} {l} x [B] A≡B)

-- Construct an shape view between two derivations of the same type
goodCasesRefl : ∀ {l l′ Γ A} ([A] : Γ ⊩⟨ l ⟩ A) ([A′] : Γ ⊩⟨ l′ ⟩ A)
              → ShapeView Γ l l′ A A [A] [A′]
goodCasesRefl [A] [A′] = goodCases [A] [A′] (reflEq [A])

-- A view for constructor equality between three types
data ShapeView₃ Γ (l l′ l″ : TypeLevel) : ∀ A B C
                 (p : Γ ⊩⟨ l  ⟩ A)
                 (q : Γ ⊩⟨ l′ ⟩ B)
                 (r : Γ ⊩⟨ l″ ⟩ C)
                 → Set (lsuc (lsuc (toLevel l ⊔ toLevel l′ ⊔ toLevel l″))) where
  Uᵥ : ∀ lA l<A ⊢ΓA lB l<B ⊢ΓB lC l<C ⊢ΓC
    → ShapeView₃ Γ l l′ l″ U U U
      (LRPack _ _ _ (LRU ⊢ΓA lA l<A))
      (LRPack _ _ _ (LRU ⊢ΓB lB l<B))
      (LRPack _ _ _ (LRU ⊢ΓC lC l<C))
  ℕᵥ : ∀ {A B C} ℕA ℕB ℕC
    → ShapeView₃ Γ l l′ l″ A B C
      (LRPack _ _ _ (LRℕ ℕA))
      (LRPack _ _ _ (LRℕ ℕB))
      (LRPack _ _ _ (LRℕ ℕC))
  ne  : ∀ {A B C} neA neB neC
      → ShapeView₃ Γ l l′ l″ A B C
        (LRPack _ _ _ (LRne neA))
        (LRPack _ _ _ (LRne neB))
        (LRPack _ _ _ (LRne neC))
  Πᵥ : ∀ {A B C} ΠA ΠB ΠC
     → ShapeView₃ Γ l l′ l″ A B C
       (LRPack _ _ _ (LRΠ ΠA))
       (LRPack _ _ _ (LRΠ ΠB))
       (LRPack _ _ _ (LRΠ ΠC))
  emb⁰¹¹ : ∀ {A B C p q r}
        → (l≡ : l PE.≡ ¹)
        → ShapeView₃ Γ ⁰ l′ l″ A B C p q r
        → ShapeView₃ Γ l l′ l″ A B C (emb″ l l≡ p) q r
  emb¹⁰¹ : ∀ {A B C p q r}
        → (l≡ : l′ PE.≡ ¹)
        → ShapeView₃ Γ l ⁰ l″ A B C p q r
        → ShapeView₃ Γ l l′ l″ A B C p (emb″ l′ l≡ q) r
  emb¹¹⁰ : ∀ {A B C p q r}
        → (l≡ : l″ PE.≡ ¹)
        → ShapeView₃ Γ l l′ ⁰ A B C p q r
        → ShapeView₃ Γ l l′ l″ A B C p q (emb″ l″ l≡ r)

-- Combines two two-way views into a three-way view
combine : ∀ {Γ l l′ l″ l‴ A B C [A] [B] [B]′ [C]}
        → ShapeView Γ l l′ A B [A] [B]
        → ShapeView Γ l″ l‴ B C [B]′ [C]
        → ShapeView₃ Γ l l′ l‴ A B C [A] [B] [C]
combine (Uᵥ lA l<A ⊢ΓA lB l<B ⊢ΓB) (Uᵥ _ _ _ lC l<C ⊢ΓC) = Uᵥ lA l<A ⊢ΓA lB l<B ⊢ΓB lC l<C ⊢ΓC
combine (Uᵥ lA l<A ⊢ΓA lB l<B ⊢ΓB) (ℕᵥ ℕA ℕB) = ⊥-elim (U≢ℕ (whnfRed* (red ℕA) Uₙ))
combine (Uᵥ lA l<A ⊢ΓA lB l<B ⊢ΓB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
combine (Uᵥ lA l<A ⊢ΓA lB l<B ⊢ΓB) (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
  ⊥-elim (U≢Π (whnfRed* (red D) Uₙ))
combine (ℕᵥ ℕA ℕB) (Uᵥ lB l<B ⊢ΓB lC l<C ⊢ΓC) = ⊥-elim (U≢ℕ (whnfRed* (red ℕB) Uₙ))
combine (ℕᵥ ℕA₁ ℕB₁) (ℕᵥ ℕA ℕB) = ℕᵥ ℕA₁ ℕB₁ ℕB
combine (ℕᵥ ℕA ℕB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (ℕ≢ne neK (whrDet* (red ℕB , ℕₙ) (red D , ne neK)))
combine (ℕᵥ ℕA ℕB) (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
  ⊥-elim (ℕ≢Π (whrDet* (red ℕB , ℕₙ) (red D , Πₙ)))
combine (ne neA (ne K D neK K≡K)) (Uᵥ lB l<B ⊢ΓB lC l<C ⊢ΓC) =
  ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
combine (ne neA (ne K D neK K≡K)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢ne neK (whrDet* (red ℕA , ℕₙ) (red D , ne neK)))
combine (ne neA₁ neB₁) (ne neA neB) = ne neA₁ neB₁ neB
combine (ne neA (ne K D₁ neK K≡K)) (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
  ⊥-elim (Π≢ne neK (whrDet* (red D , Πₙ) (red D₁ , ne neK)))
combine (Πᵥ ΠA (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Uᵥ lB l<B ⊢ΓB lC l<C ⊢ΓC) =
  ⊥-elim (U≢Π (whnfRed* (red D) Uₙ))
combine (Πᵥ ΠA (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢Π (whrDet* (red ℕA , ℕₙ) (red D , Πₙ)))
combine (Πᵥ ΠA (Πᵣ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext)) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (Π≢ne neK (whrDet* (red D₁ , Πₙ) (red D , ne neK)))
combine (Πᵥ ΠA₁ ΠB₁) (Πᵥ ΠA ΠB) = Πᵥ ΠA₁ ΠB₁ ΠB
combine (emb⁰¹ l≡ [AB]) [BC] = emb⁰¹¹ l≡ (combine [AB] [BC])
combine (emb¹⁰ l≡ [AB]) [BC] = emb¹⁰¹ l≡ (combine [AB] [BC])
combine [AB] (emb⁰¹ l≡ [BC]) = combine [AB] [BC]
combine [AB] (emb¹⁰ l≡ [BC]) = emb¹¹⁰ l≡ (combine [AB] [BC])


module Luau.RuntimeType.ToString where

open import FFI.Data.String using (String)
open import Luau.RuntimeType using (RuntimeType; function; number; nil)

runtimeTypeToString : RuntimeType → String
runtimeTypeToString function = "function"
runtimeTypeToString number = "number"
runtimeTypeToString nil = "nil"


-- Andreas, 2015-07-07 continuation of issue 665

-- Jesper, 2015-12-18 some of these don't work anymore with the new unifier,
-- but a few others that weren't accepted are now.

{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.with.strip:10 #-}
-- {-# OPTIONS -v tc.with.strip:60 -v tc.lhs:20 -v tc.lhs.unify:20 #-}

postulate
  C : Set
  anything : C

record I : Set where
  constructor c
  field
    {f} : C

data Wrap : (i : I) → Set where
  wrap : ∀ {i} → Wrap i

-- Test 0: first argument not given

test0 : ∀ {j} → Wrap j → C
test0 wrap with anything
test0 wrap | z = z

test0a : ∀ {j} → Wrap j → C
test0a (wrap {c {x}}) with anything
test0a  wrap | z = z

test0b : ∀ {j} → Wrap j → C
test0b (wrap {c {_}}) with anything
test0b wrap | z = z

test0c : ∀ {j} → Wrap j → C
test0c (wrap {c}) with anything
test0c wrap | z = z

test0d : ∀ {j} → Wrap j → C
test0d (wrap {c {._}}) with anything
test0d  wrap | z = z

test0e : ∀ {j} → Wrap j → C
test0e (wrap .{c}) with anything
test0e  wrap | z = z

test0f : ∀ {j} → Wrap j → C
test0f (wrap .{c {_}}) with anything
test0f  wrap | z = z

--test00 : ∀ {j} → Wrap j → C
--test00 wrap with anything
--test00 {.c} wrap | z = z

test00a : ∀ {j} → Wrap j → C
test00a (wrap {c {x}}) with anything
test00a {.c} wrap | z = z

--test00b : ∀ {j} → Wrap j → C
--test00b (wrap {c {_}}) with anything
--test00b {.c} wrap | z = z

--test00c : ∀ {j} → Wrap j → C
--test00c (wrap {c}) with anything
--test00c {.c} wrap | z = z

--test00d : ∀ {j} → Wrap j → C
--test00d (wrap {c {._}}) with anything
--test00d {.c} wrap | z = z

--test00e : ∀ {j} → Wrap j → C
--test00e (wrap .{c}) with anything
--test00e {.c} wrap | z = z

--test00f : ∀ {j} → Wrap j → C
--test00f (wrap .{c {_}}) with anything
--test00f {.c} wrap | z = z

--test000 : ∀ {j} → Wrap j → C
--test000 wrap with anything
--test000 .{c {_}} wrap | z = z

test000a : ∀ {j} → Wrap j → C
test000a (wrap {c {x}}) with anything
test000a .{c {_}} wrap | z = z

--test000b : ∀ {j} → Wrap j → C
--test000b (wrap {c {_}}) with anything
--test000b .{c {_}} wrap | z = z

--test000c : ∀ {j} → Wrap j → C
--test000c (wrap {c}) with anything
--test000c .{c {_}} wrap | z = z

--test000d : ∀ {j} → Wrap j → C
--test000d (wrap {c {._}}) with anything
--test000d .{c {_}} wrap | z = z

--test000e : ∀ {j} → Wrap j → C
--test000e (wrap .{c}) with anything
--test000e .{c {_}} wrap | z = z

--test000f : ∀ {j} → Wrap j → C
--test000f (wrap .{c {_}}) with anything
--test000f .{c {_}} wrap | z = z

-- Test 1: first argument is dot pattern

test1a : ∀ {j} → Wrap j → C
test1a .{c} (wrap {c {x}}) with anything
test1a .{c} wrap | z = z

test1b : ∀ {j} → Wrap j → C
test1b .{c} (wrap {c {_}}) with anything
test1b .{c} wrap | z = z

test1c : ∀ {j} → Wrap j → C
test1c .{c} (wrap {c}) with anything
test1c .{c} wrap | z = z

test11a : ∀ {j} → Wrap j → C
test11a .{c} (wrap {c {x}}) with anything
test11a wrap | z = z

test11b : ∀ {j} → Wrap j → C
test11b .{c} (wrap {c {_}}) with anything
test11b wrap | z = z

test11c : ∀ {j} → Wrap j → C
test11c .{c} (wrap {c}) with anything
test11c wrap | z = z

test111a : ∀ {j} → Wrap j → C
test111a (wrap {c {x}}) with anything
test111a .{c} wrap | z = z

--test111b : ∀ {j} → Wrap j → C
--test111b (wrap {c {_}}) with anything
--test111b .{c} wrap | z = z

--test111c : ∀ {j} → Wrap j → C
--test111c (wrap {c}) with anything
--test111c .{c} wrap | z = z

-- Test 2: First argument is record pattern

test2a : ∀ {j} → Wrap j → C
test2a {c} wrap with anything
test2a {c} wrap | z = z

test2b : ∀ {j} → Wrap j → C
test2b {c} wrap with anything
test2b wrap | z = z

test2c : ∀ {j} → Wrap j → C
test2c {c} (wrap {c}) with anything
test2c {c} wrap | z = z

test2d : ∀ {j} → Wrap j → C
test2d {c} (wrap {c}) with anything
test2d wrap | z = z

test2e : ∀ {j} → Wrap j → C
test2e {c} (wrap {c {._}}) with anything
test2e {c} wrap | z = z

test2f : ∀ {j} → Wrap j → C
test2f {c} (wrap {c {._}}) with anything
test2f wrap | z = z

test2g : ∀ {j} → Wrap j → C
test2g {c} (wrap {c {x}}) with anything
test2g {c} wrap | z = z

test2h : ∀ {j} → Wrap j → C
test2h {c} (wrap {c {x}}) with anything
test2h wrap | z = z

test2i : ∀ {j} → Wrap j → C
test2i {c} (wrap {c {_}}) with anything
test2i {c} wrap | z = z

test2j : ∀ {j} → Wrap j → C
test2j {c} (wrap {c {_}}) with anything
test2j wrap | z = z

-- Test 3: First argument is record of dot pattern, second is record pattern
-- The commented-out ones fail due to issue 1608

-- test3a : ∀ {j} → Wrap j → C
-- test3a {c {._}} wrap with anything
-- test3a {c {._}} wrap | z = z

test3b : ∀ {j} → Wrap j → C
test3b {c {._}} wrap with anything
test3b wrap | z = z

-- test3c : ∀ {j} → Wrap j → C
-- test3c {c {._}} (wrap {c}) with anything
-- test3c {c {._}} wrap | z = z

test3d : ∀ {j} → Wrap j → C
test3d {c {._}} (wrap {c}) with anything
test3d wrap | z = z

-- test3e : ∀ {j} → Wrap j → C
-- test3e {c {._}} (wrap {c {._}}) with anything
-- test3e {c {._}} wrap | z = z

-- test3f : ∀ {j} → Wrap j → C
-- test3f {c {._}} (wrap {c {._}}) with anything
-- test3f wrap | z = z

test3g : ∀ {j} → Wrap j → C
test3g {c {._}} (wrap {c {x}}) with anything
test3g {c {._}} wrap | z = z

test3h : ∀ {j} → Wrap j → C
test3h {c {._}} (wrap {c {x}}) with anything
test3h wrap | z = z

-- test3i : ∀ {j} → Wrap j → C
-- test3i {c {._}} (wrap {c {_}}) with anything
-- test3i {c {._}} wrap | z = z

test3j : ∀ {j} → Wrap j → C
test3j {c {._}} (wrap {c {_}}) with anything
test3j wrap | z = z


{-
The equivalent "goodness" of can-θ w.r.t. the rmerge reduction.
The main properties of the Can function proved in this file are:

  canθₛ-mergeˡ : ∀ {E θ' r p BV FV} sigs θ →
    CorrectBinding p BV FV →
    p ≐ E ⟦ ρ θ' · r ⟧e →
    ∀ S' →
      Signal.unwrap S' ∉ SigMap.keys (Env.sig θ') →
      Signal.unwrap S' ∈ Canθₛ (SigMap.union sigs (Env.sig θ')) 0 (E ⟦ r ⟧e) θ →
      Signal.unwrap S' ∈ Canθₛ sigs 0 p θ

  canθₛ-mergeʳ : ∀ sigs θ' r θ →
    distinct' (proj₁ (Dom θ)) (SigMap.keys sigs) →
    ∀ S' →
      Signal.unwrap S' ∈ Canθₛ (SigMap.union sigs (Env.sig θ')) 0 r θ →
      Signal.unwrap S' ∈ Canθₛ (Env.sig θ') 0 r θ

and their corresponding counterparts for the shared variables.

-}
module Esterel.Lang.CanFunction.MergePotentialRuleTheta where

open import utility
  renaming (_U̬_ to _∪_ ; _|̌_ to _-_)

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.CanFunction
open import Esterel.Lang.CanFunction.Base
open import Esterel.Lang.CanFunction.CanThetaContinuation
open import Esterel.Lang.CanFunction.MergePotentialRuleLeftInductive
open import Esterel.Lang.CanFunction.NonMergePotentialRules
open import Esterel.Context
  using (EvaluationContext1 ; EvaluationContext ; _⟦_⟧e ; _≐_⟦_⟧e)
open import Esterel.Context.Properties
  using (plug ; unplug)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
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 EvaluationContext1
open _≐_⟦_⟧e

open import Data.Bool
  using (Bool ; not ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; [] ; _∷_ ; _++_ ; map ; concatMap ; foldr)
open import Data.List.Properties
  using (map-id)
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 ; maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _≟_ ; _+_)
open import Data.Nat.Properties.Simple
  using (+-comm)
open import Data.Product
  using (Σ ; proj₁ ; proj₂ ; ∃ ; _,_ ; _,′_ ; _×_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function
  using (_∘_ ; id ; _∋_)
open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; _≢_ ; refl ; trans ; sym ; cong ; subst ; module ≡-Reasoning)

open ListSet Data.Nat._≟_
  using (set-subtract ; set-subtract-[] ; set-subtract-split ; set-subtract-merge
       ; set-subtract-notin
       ; set-remove ; set-remove-mono-∈ ; set-remove-removed ; set-remove-not-removed
       ; set-subtract-[a]≡set-remove)

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 ≡-Reasoning

canθₖ-mergeˡ : ∀ {E θ' r p BV FV A} sigs θ →
  CorrectBinding p BV FV →
  p ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e →
  ∀ k →
    k ∈ Canθₖ (SigMap.union sigs (Env.sig θ')) 0 (E ⟦ r ⟧e) θ →
    k ∈ Canθₖ sigs 0 p θ
canθₖ-mergeˡ {E} {θ'} {r} {A = A} sigs θ cb p≐E⟦ρθ'r⟧ k k∈canθ-sigs←θ'-E⟦r⟧-θ
  rewrite sym (unplug p≐E⟦ρθ'r⟧)
  with binding-extract cb (((E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ∋ plug refl)
... | (BVp , FVp) , (BVp⊆BV , FVp⊆FV) , cbρθ'r@(CBρ cbp)
  with binding-subst cb (((E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ∋ plug refl) cbρθ'r
                     ((λ _ ()) ,′ (λ _ ()) ,′ (λ _ ()))
                     ((λ _ ()) ,′ (λ _ ()) ,′ (λ _ ()))
                     CBnothing
... | (BV' , FV') , (BVnothin⊆BV , FVnothin⊆FV) , cbnothin
  rewrite canθ'-←-distribute sigs (Env.sig θ') 0 (E ⟦ r ⟧e) θ =
  canθₖ-mergeˡ-sigs-induction sigs 0 (Env.sig θ') (Env.shr θ') (Env.var θ') r θ
    ((E ⟦ nothin ⟧e ≐ E ⟦ nothin ⟧e) ∋ plug refl) cbnothin
    (distinct'-sym
      (dist'++ˡ
        (distinct'-sym
          (proj₁
            (distinct-term-context-help (ρ⟨ θ' , A ⟩· r) E cb cbρθ'r BVp⊆BV cbnothin)))))
    k k∈canθ-sigs←θ'-E⟦r⟧-θ

canθₛ-mergeˡ : ∀ {E θ' r p BV FV A} sigs θ →
  CorrectBinding p BV FV →
  p ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e →
  ∀ S' →
    Signal.unwrap S' ∉ SigMap.keys (Env.sig θ') →
    Signal.unwrap S' ∈ Canθₛ (SigMap.union sigs (Env.sig θ')) 0 (E ⟦ r ⟧e) θ →
    Signal.unwrap S' ∈ Canθₛ sigs 0 p θ
canθₛ-mergeˡ {E} {θ'} {r} {A = A} sigs θ cb p≐E⟦ρθ'r⟧ S' S'∉Domθ' S'∈canθ-sigs←θ'-E⟦r⟧-θ
  rewrite sym (unplug p≐E⟦ρθ'r⟧)
  with binding-extract cb (((E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ∋ plug refl)
... | (BVp , FVp) , (BVp⊆BV , FVp⊆FV) , cbρθ'r@(CBρ cbp)
  with binding-subst cb (((E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ∋ plug refl) cbρθ'r
                     ((λ _ ()) ,′ (λ _ ()) ,′ (λ _ ()))
                     ((λ _ ()) ,′ (λ _ ()) ,′ (λ _ ()))
                     CBnothing
... | (BV' , FV') , (BVnothin⊆BV , FVnothin⊆FV) , cbnothin
  rewrite canθ'-←-distribute sigs (Env.sig θ') 0 (E ⟦ r ⟧e) θ =
  canθₛ-mergeˡ-sigs-induction sigs 0 (Env.sig θ') (Env.shr θ') (Env.var θ') r θ
    ((E ⟦ nothin ⟧e ≐ E ⟦ nothin ⟧e) ∋ plug refl) cbnothin
    (distinct'-sym
      (dist'++ˡ
        (distinct'-sym
          (proj₁
            (distinct-term-context-help (ρ⟨ θ' , A ⟩· r) E cb cbρθ'r BVp⊆BV cbnothin)))))
    (Signal.unwrap S')
    S'∉Domθ' S'∈canθ-sigs←θ'-E⟦r⟧-θ

canθₛₕ-mergeˡ : ∀ {E θ' r p BV FV A} sigs θ →
  CorrectBinding p BV FV →
  p ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e →
  ∀ s' →
    SharedVar.unwrap s' ∉ ShrMap.keys (Env.shr θ') →
    SharedVar.unwrap s' ∈ Canθₛₕ (SigMap.union sigs (Env.sig θ')) 0 (E ⟦ r ⟧e) θ →
    SharedVar.unwrap s' ∈ Canθₛₕ sigs 0 p θ
canθₛₕ-mergeˡ {E} {θ'} {r} {A = A} sigs θ cb p≐E⟦ρθ'r⟧ s' s'∉Domθ' s'∈canθ-sigs←θ'-E⟦r⟧-θ
  rewrite sym (unplug p≐E⟦ρθ'r⟧)
  with binding-extract cb (((E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ∋ plug refl)
... | (BVp , FVp) , (BVp⊆BV , FVp⊆FV) , cbρθ'r@(CBρ cbp)
  with binding-subst cb (((E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ≐ E ⟦ ρ⟨ θ' , A ⟩· r ⟧e) ∋ plug refl) cbρθ'r
                     ((λ _ ()) ,′ (λ _ ()) ,′ (λ _ ()))
                     ((λ _ ()) ,′ (λ _ ()) ,′ (λ _ ()))
                     CBnothing
... | (BV' , FV') , (BVnothin⊆BV , FVnothin⊆FV) , cbnothin
  rewrite canθ'-←-distribute sigs (Env.sig θ') 0 (E ⟦ r ⟧e) θ =
  canθₛₕ-mergeˡ-sigs-induction sigs 0 (Env.sig θ') (Env.shr θ') (Env.var θ') r θ
    ((E ⟦ nothin ⟧e ≐ E ⟦ nothin ⟧e) ∋ plug refl) cbnothin
    (distinct'-sym
      (dist'++ˡ
        (distinct'-sym
          (proj₁
            (distinct-term-context-help (ρ⟨ θ' , A ⟩· r) E cb cbρθ'r BVp⊆BV cbnothin)))))
    (SharedVar.unwrap s')
    s'∉Domθ' s'∈canθ-sigs←θ'-E⟦r⟧-θ

canθₛ-mergeʳ-add-sig-notin : ∀ sigs' r θ S status →
  S ∉ proj₁ (Dom θ) →
  S ∉ SigMap.keys sigs' →
  ∀ S'' →
    S'' ∈ Canθₛ sigs' 0 r (θ ← [ (S ₛ) ↦ status ]) →
    S'' ∈ Canθₛ sigs' 0 r θ
canθₛ-mergeʳ-add-sig-notin sigs' r θ S status S∉Domθ S∉sigs'
  S'' S''∈canθ-sigs'-r-θ←[S]
  rewrite canθ-is-unknown-lemma sigs' 0 r θ (S ₛ) S∉Domθ
            (subst (S ∉_)
               (sym (map-id (SigMap.keys sigs')))
               S∉sigs')
  = canθₛ-add-sig-monotonic sigs' 0 r θ (S ₛ) status
      S'' S''∈canθ-sigs'-r-θ←[S]

canθₛ-mergeʳ-sigs-induction : ∀ sigs S sigs' r θ →
  distinct' (proj₁ (Dom θ)) (map (_+_ S) (SigMap.keys sigs)) →
  ∀ S'' →
    S'' ∈ proj₁ (Canθ' sigs S (Canθ sigs' 0 r) θ) →
    S'' ∈ proj₁               (Canθ sigs' 0 r θ)
canθₛ-mergeʳ-sigs-induction [] S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  = S''∈canθ'-sigs-canθ-sigs'-r-θ
canθₛ-mergeʳ-sigs-induction (nothing ∷ sigs) S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  = canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ θ≠sigs
      S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
canθₛ-mergeʳ-sigs-induction (just Signal.present ∷ sigs) S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.present θ S∈sigs'
  = canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛ-mergeʳ-add-sig-notin sigs' r θ S Signal.present
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' S''
      (canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env-present (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.present S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env-present (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        S'' S''∈canθ'-sigs-canθ-sigs'-r-θ)
canθₛ-mergeʳ-sigs-induction (just Signal.absent ∷ sigs) S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.absent θ S∈sigs'
  = canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛ-mergeʳ-add-sig-notin sigs' r θ S Signal.absent
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' S''
      (canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env-absent (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.absent S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env-absent (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        S'' S''∈canθ'-sigs-canθ-sigs'-r-θ)
canθₛ-mergeʳ-sigs-induction (just Signal.unknown ∷ sigs) S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  with any (_≟_ S) (proj₁ (Canθ' sigs (suc S) (Canθ sigs' 0 r) (θ ← [S]-env (S ₛ))))
canθₛ-mergeʳ-sigs-induction (just Signal.unknown ∷ sigs) S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  | yes S∈canθ'-sigs-canθ-sigs'-r-θ←[S]
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.unknown θ S∈sigs'
  = canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛ-mergeʳ-add-sig-notin sigs' r θ S Signal.unknown
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' S''
      (canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.unknown S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        S'' S''∈canθ'-sigs-canθ-sigs'-r-θ)
canθₛ-mergeʳ-sigs-induction (just Signal.unknown ∷ sigs) S sigs' r θ θ≠sigs
  S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
  | no  S∉canθ'-sigs-canθ-sigs'-r-θ←[S]
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.absent θ S∈sigs'
  = canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) S'' S''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛ-mergeʳ-add-sig-notin sigs' r θ S Signal.absent
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' S''
      (canθₛ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env-absent (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.absent S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env-absent (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        S'' S''∈canθ'-sigs-canθ-sigs'-r-θ)

canθₛ-mergeʳ : ∀ sigs θ' r θ →
  distinct' (proj₁ (Dom θ)) (SigMap.keys sigs) →
  ∀ S' →
    Signal.unwrap S' ∈ Canθₛ (SigMap.union sigs (Env.sig θ')) 0 r θ →
    Signal.unwrap S' ∈ Canθₛ (Env.sig θ') 0 r θ
canθₛ-mergeʳ sigs θ' r θ θ≠sigs S' S'∈canθ-sigs←θ'-r-θ
  rewrite canθ'-←-distribute sigs (Env.sig θ') 0 r θ
  = canθₛ-mergeʳ-sigs-induction sigs 0 (Env.sig θ') r θ
      (subst (distinct' _) (sym (map-id (SigMap.keys sigs))) θ≠sigs)
      (Signal.unwrap S') S'∈canθ-sigs←θ'-r-θ

canθₛₕ-mergeʳ-add-sig-notin : ∀ sigs' r θ S status →
  S ∉ proj₁ (Dom θ) →
  S ∉ SigMap.keys sigs' →
  ∀ s'' →
    s'' ∈ Canθₛₕ sigs' 0 r (θ ← [ (S ₛ) ↦ status ]) →
    s'' ∈ Canθₛₕ sigs' 0 r θ
canθₛₕ-mergeʳ-add-sig-notin sigs' r θ S status S∉Domθ S∉sigs'
  s'' s''∈canθ-sigs'-r-θ←[S]
  rewrite canθ-is-unknown-lemma sigs' 0 r θ (S ₛ) S∉Domθ
            (subst (S ∉_)
               (sym (map-id (SigMap.keys sigs')))
               S∉sigs')
  = canθₛₕ-add-sig-monotonic sigs' 0 r θ (S ₛ) status
      s'' s''∈canθ-sigs'-r-θ←[S]

canθₛₕ-mergeʳ-sigs-induction : ∀ sigs S sigs' r θ →
  distinct' (proj₁ (Dom θ)) (map (_+_ S) (SigMap.keys sigs)) →
  ∀ s'' →
    s'' ∈ proj₂ (proj₂ (Canθ' sigs S (Canθ sigs' 0 r) θ)) →
    s'' ∈ proj₂ (proj₂               (Canθ sigs' 0 r θ))
canθₛₕ-mergeʳ-sigs-induction [] S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  = s''∈canθ'-sigs-canθ-sigs'-r-θ
canθₛₕ-mergeʳ-sigs-induction (nothing ∷ sigs) S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  = canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ θ≠sigs
      s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
canθₛₕ-mergeʳ-sigs-induction (just Signal.present ∷ sigs) S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.present θ S∈sigs'
  = canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛₕ-mergeʳ-add-sig-notin sigs' r θ S Signal.present
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' s''
      (canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env-present (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.present S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env-present (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        s'' s''∈canθ'-sigs-canθ-sigs'-r-θ)
canθₛₕ-mergeʳ-sigs-induction (just Signal.absent ∷ sigs) S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.absent θ S∈sigs'
  = canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛₕ-mergeʳ-add-sig-notin sigs' r θ S Signal.absent
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' s''
      (canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env-absent (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.absent S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env-absent (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        s'' s''∈canθ'-sigs-canθ-sigs'-r-θ)
canθₛₕ-mergeʳ-sigs-induction (just Signal.unknown ∷ sigs) S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  with any (_≟_ S) (proj₁ (Canθ' sigs (suc S) (Canθ sigs' 0 r) (θ ← [S]-env (S ₛ))))
canθₛₕ-mergeʳ-sigs-induction (just Signal.unknown ∷ sigs) S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  | yes S∈canθ'-sigs-canθ-sigs'-r-θ←[S]
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.unknown θ S∈sigs'
  = canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛₕ-mergeʳ-add-sig-notin sigs' r θ S Signal.unknown
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' s''
      (canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.unknown S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        s'' s''∈canθ'-sigs-canθ-sigs'-r-θ)
canθₛₕ-mergeʳ-sigs-induction (just Signal.unknown ∷ sigs) S sigs' r θ θ≠sigs
  s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
  | no  S∉canθ'-sigs-canθ-sigs'-r-θ←[S]
  rewrite map-+-compose-suc S (SigMap.keys sigs)
  with any (_≟_ S) (SigMap.keys sigs')
... | yes S∈sigs'
  rewrite  canθ'-inner-shadowing-irr sigs (suc S) sigs' r S Signal.absent θ S∈sigs'
  = canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r θ
      (dist'++ʳ {V2 = S + 0 ∷ []} θ≠sigs) s'' s''∈canθ'-sigs-canθ-sigs'-r-θ
... | no  S∉sigs'
  rewrite +-comm S 0
  = canθₛₕ-mergeʳ-add-sig-notin sigs' r θ S Signal.absent
      (λ S∈Domθ → θ≠sigs S S∈Domθ (here refl)) S∉sigs' s''
      (canθₛₕ-mergeʳ-sigs-induction sigs (suc S) sigs' r (θ ← [S]-env-absent (S ₛ))
        (λ S'' S''∈Domθ←[S] S''∈map-+-suc-S-sigs → -- TODO: should make this a function
          Data.Sum.[ (λ S''∈Domθ → θ≠sigs S'' S''∈Domθ (there S''∈map-+-suc-S-sigs)) ,
                     (λ S''∈[S] →
                       subst (_∉ _)
                         (sym (Env.sig-single-∈-eq (S'' ₛ) (S ₛ) Signal.absent S''∈[S]))
                         (n∉map-suc-n-+ S (SigMap.keys sigs))
                       S''∈map-+-suc-S-sigs) ]
            (Env.sig-←⁻ {θ} {[S]-env-absent (S ₛ)} (S'' ₛ) S''∈Domθ←[S]))
        s'' s''∈canθ'-sigs-canθ-sigs'-r-θ)

canθₛₕ-mergeʳ : ∀ sigs θ' r θ →
  distinct' (proj₁ (Dom θ)) (SigMap.keys sigs) →
  ∀ s' →
    SharedVar.unwrap s' ∈ Canθₛₕ (SigMap.union sigs (Env.sig θ')) 0 r θ →
    SharedVar.unwrap s' ∈ Canθₛₕ (Env.sig θ') 0 r θ
canθₛₕ-mergeʳ sigs θ' r θ θ≠sigs s' s'∈canθ-sigs←θ'-r-θ
  rewrite canθ'-←-distribute sigs (Env.sig θ') 0 r θ
  = canθₛₕ-mergeʳ-sigs-induction sigs 0 (Env.sig θ') r θ
      (subst (distinct' _) (sym (map-id (SigMap.keys sigs))) θ≠sigs)
      (SharedVar.unwrap s') s'∈canθ-sigs←θ'-r-θ


-- Andreas, 2015-07-07 continuation of issue 665

-- Jesper, 2015-12-18 some of these don't work anymore with the new unifier,
-- but a few others that weren't accepted are now.

{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.with.strip:10 #-}
-- {-# OPTIONS -v tc.with.strip:60 -v tc.lhs:20 -v tc.lhs.unify:20 #-}

postulate
  C : Set
  anything : C

record I : Set where
  constructor c
  field
    {f} : C

data Wrap : (i : I) → Set where
  wrap : ∀ {i} → Wrap i

-- Test 0: first argument not given

test0 : ∀ {j} → Wrap j → C
test0 wrap with anything
test0 wrap | z = z

test0a : ∀ {j} → Wrap j → C
test0a (wrap {c {x}}) with anything
test0a  wrap | z = z

test0b : ∀ {j} → Wrap j → C
test0b (wrap {c {_}}) with anything
test0b wrap | z = z

test0c : ∀ {j} → Wrap j → C
test0c (wrap {c}) with anything
test0c wrap | z = z

test0d : ∀ {j} → Wrap j → C
test0d (wrap {c {._}}) with anything
test0d  wrap | z = z

test0e : ∀ {j} → Wrap j → C
test0e (wrap .{c}) with anything
test0e  wrap | z = z

test0f : ∀ {j} → Wrap j → C
test0f (wrap .{c {_}}) with anything
test0f  wrap | z = z

test00 : ∀ {j} → Wrap j → C
test00 wrap with anything
test00 {.c} wrap | z = z

test00a : ∀ {j} → Wrap j → C
test00a (wrap {c {x}}) with anything
test00a {.c} wrap | z = z

test00b : ∀ {j} → Wrap j → C
test00b (wrap {c {_}}) with anything
test00b {.c} wrap | z = z

test00c : ∀ {j} → Wrap j → C
test00c (wrap {c}) with anything
test00c {.c} wrap | z = z

test00d : ∀ {j} → Wrap j → C
test00d (wrap {c {._}}) with anything
test00d {.c} wrap | z = z

test00e : ∀ {j} → Wrap j → C
test00e (wrap .{c}) with anything
test00e {.c} wrap | z = z

test00f : ∀ {j} → Wrap j → C
test00f (wrap .{c {_}}) with anything
test00f {.c} wrap | z = z

test000 : ∀ {j} → Wrap j → C
test000 wrap with anything
test000 .{c {_}} wrap | z = z

test000a : ∀ {j} → Wrap j → C
test000a (wrap {c {x}}) with anything
test000a .{c {_}} wrap | z = z

test000b : ∀ {j} → Wrap j → C
test000b (wrap {c {_}}) with anything
test000b .{c {_}} wrap | z = z

test000c : ∀ {j} → Wrap j → C
test000c (wrap {c}) with anything
test000c .{c {_}} wrap | z = z

test000d : ∀ {j} → Wrap j → C
test000d (wrap {c {._}}) with anything
test000d .{c {_}} wrap | z = z

test000e : ∀ {j} → Wrap j → C
test000e (wrap .{c}) with anything
test000e .{c {_}} wrap | z = z

test000f : ∀ {j} → Wrap j → C
test000f (wrap .{c {_}}) with anything
test000f .{c {_}} wrap | z = z

-- Test 1: first argument is dot pattern

test1a : ∀ {j} → Wrap j → C
test1a .{c} (wrap {c {x}}) with anything
test1a .{c} wrap | z = z

test1b : ∀ {j} → Wrap j → C
test1b .{c} (wrap {c {_}}) with anything
test1b .{c} wrap | z = z

test1c : ∀ {j} → Wrap j → C
test1c .{c} (wrap {c}) with anything
test1c .{c} wrap | z = z

test11a : ∀ {j} → Wrap j → C
test11a .{c} (wrap {c {x}}) with anything
test11a wrap | z = z

test11b : ∀ {j} → Wrap j → C
test11b .{c} (wrap {c {_}}) with anything
test11b wrap | z = z

test11c : ∀ {j} → Wrap j → C
test11c .{c} (wrap {c}) with anything
test11c wrap | z = z

test111a : ∀ {j} → Wrap j → C
test111a (wrap {c {x}}) with anything
test111a .{c} wrap | z = z

test111b : ∀ {j} → Wrap j → C
test111b (wrap {c {_}}) with anything
test111b .{c} wrap | z = z

test111c : ∀ {j} → Wrap j → C
test111c (wrap {c}) with anything
test111c .{c} wrap | z = z

-- Test 2: First argument is record pattern

test2a : ∀ {j} → Wrap j → C
test2a {c} wrap with anything
test2a {c} wrap | z = z

test2b : ∀ {j} → Wrap j → C
test2b {c} wrap with anything
test2b wrap | z = z

test2c : ∀ {j} → Wrap j → C
test2c {c} (wrap {c}) with anything
test2c {c} wrap | z = z

test2d : ∀ {j} → Wrap j → C
test2d {c} (wrap {c}) with anything
test2d wrap | z = z

test2e : ∀ {j} → Wrap j → C
test2e {c} (wrap {c {._}}) with anything
test2e {c} wrap | z = z

test2f : ∀ {j} → Wrap j → C
test2f {c} (wrap {c {._}}) with anything
test2f wrap | z = z

test2g : ∀ {j} → Wrap j → C
test2g {c} (wrap {c {x}}) with anything
test2g {c} wrap | z = z

test2h : ∀ {j} → Wrap j → C
test2h {c} (wrap {c {x}}) with anything
test2h wrap | z = z

test2i : ∀ {j} → Wrap j → C
test2i {c} (wrap {c {_}}) with anything
test2i {c} wrap | z = z

test2j : ∀ {j} → Wrap j → C
test2j {c} (wrap {c {_}}) with anything
test2j wrap | z = z

-- Test 3: First argument is record of dot pattern, second is record pattern

test3a : ∀ {j} → Wrap j → C
test3a {c {._}} wrap with anything
test3a {c {._}} wrap | z = z

test3b : ∀ {j} → Wrap j → C
test3b {c {._}} wrap with anything
test3b wrap | z = z

test3c : ∀ {j} → Wrap j → C
test3c {c {._}} (wrap {c}) with anything
test3c {c {._}} wrap | z = z

test3d : ∀ {j} → Wrap j → C
test3d {c {._}} (wrap {c}) with anything
test3d wrap | z = z

test3e : ∀ {j} → Wrap j → C
test3e {c {._}} (wrap {c {._}}) with anything
test3e {c {._}} wrap | z = z

test3f : ∀ {j} → Wrap j → C
test3f {c {._}} (wrap {c {._}}) with anything
test3f wrap | z = z

test3g : ∀ {j} → Wrap j → C
test3g {c {_}} (wrap {c {x}}) with anything
test3g {c {_}} wrap | z = z

test3h : ∀ {j} → Wrap j → C
test3h {c {_}} (wrap {c {x}}) with anything
test3h wrap | z = z

test3i : ∀ {j} → Wrap j → C
test3i {c {_}} (wrap {c {_}}) with anything
test3i {c {_}} wrap | z = z

test3j : ∀ {j} → Wrap j → C
test3j {c {_}} (wrap {c {_}}) with anything
test3j wrap | z = z


-- Andreas, 2015-11-10, issue reported by Wolfram Kahl
-- {-# OPTIONS -v scope.mod.inst:30 #-}
-- {-# OPTIONS -v tc.mod.check:10 -v tc.mod.apply:80 -v impossible:10 #-}

postulate
  A : Set
  a : A

module Id (A : Set) (a : A) where
  x = a

module ModParamsToLoose (A : Set) where
  private module M (a : A) where module I = Id A a
  open M public

open ModParamsToLoose A
open I a

y : A
y = x