------------------------------------------------------------------------
-- A total parser combinator library
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

module TotalParserCombinators where

-- Check out TotalRecognisers for an introduction to the ideas used
-- below in the simplified setting of recognisers (as opposed to
-- parsers).

import TotalRecognisers

-- The parser type, and its semantics.

import TotalParserCombinators.Parser
import TotalParserCombinators.Semantics

-- Forcing of parsers (can be used for inspection/debugging purposes).

import TotalParserCombinators.Force

-- Some lemmas about initial bags.

import TotalParserCombinators.InitialBag

-- A small library of derived parser combinators.

import TotalParserCombinators.Lib

-- A Brzozowski derivative operator for parsers.

import TotalParserCombinators.Derivative

-- A breadth-first backend, based on the derivative operator.

import TotalParserCombinators.BreadthFirst

-- An alternative, coinductive definition of equality (and related
-- orderings) between parsers.

import TotalParserCombinators.CoinductiveEquality

-- Language equivalence and parser equivalence are both congruences.
-- The various orderings are compatible preorders.

import TotalParserCombinators.Congruence
import TotalParserCombinators.Congruence.Sound

-- However, it is possible to construct combinators which do not
-- preserve equality.

import TotalParserCombinators.NotACongruence

-- Proofs of various laws, for instance the monad laws.

import TotalParserCombinators.Laws

-- A proof showing that all functions of type List Bool → List R can
-- be realised using parser combinators (for any R, assuming that bag
-- equality is used for the lists of results).

import TotalParserCombinators.ExpressiveStrength

-- Definitions of asymmetric choice, and and not. Note that no
-- extension of the library is required to define these combinators,
-- which make use of a general operator which lifts initial bag
-- operations to parsers. This operator is defined using the
-- breadth-first backend's derivative operator.

import TotalParserCombinators.Pointwise
import TotalParserCombinators.AsymmetricChoice
import TotalParserCombinators.And
import TotalParserCombinators.Not

-- A lookahead operator cannot be defined.

import TotalParserCombinators.NoLookahead

-- An alternative semantics.

import TotalParserCombinators.Semantics.Continuation

-- Simplification of parsers.

import TotalParserCombinators.Simplification

-- Definition of unambiguity.

import TotalParserCombinators.Unambiguity

-- An example: a left recursive expression grammar.

import TotalParserCombinators.Examples.Expression

-- Recognisers defined on top of the parsers, and a variant of the
-- left recursive expression grammar mentioned above.

import TotalParserCombinators.Recogniser
import TotalParserCombinators.Recogniser.Expression

-- Another example: parsing PBM image files.

import TotalParserCombinators.Examples.PBM

-- An extended example: mixfix operator parsing.

import Mixfix

-- For code related to the paper "Structurally Recursive Descent
-- Parsing", developed together with Ulf Norell, see the following
-- module:

import StructurallyRecursiveDescentParsing


open import Agda.Builtin.Nat
open import Agda.Builtin.Unit
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)
open import Agda.Builtin.List
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality
open import Agda.Primitive

record X {a} (A : Set a) : Set a where
  field fld : A

d : X Nat
d = record { fld = 5 }

-- Here we test that suppressing reduction of lzero has no effect on the reconstruction
-- of parameters.  Essentially, we ignore ReduceDefs annotations when reconstructing
-- hidden parameters.
macro
  x : Term → TC ⊤
  x hole = do
      (function (clause tel ps t ∷ [])) ← withReconstructed (getDefinition (quote d))
        where _ → quoteTC "ERROR" >>= unify hole
      a ← withReconstructed (dontReduceDefs (quote lzero ∷ []) (normalise t))
      quoteTC a >>= unify hole

-- If we were to consider suppressed reduction of lzero, we end up with
-- Set ≠ Set lzero.
test₁ : Term
test₁ = x

map : ∀ {a b}{A : Set a}{B : Set b} → (A → B) → List A → List B
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs

reverse : ∀ {a}{A : Set a} → List A → List A
reverse {A = A} xs = reverseAcc xs []
  where
    reverseAcc : List A → List A → List A
    reverseAcc [] a = a
    reverseAcc (x ∷ xs) a = reverseAcc xs (x ∷ a)

foo : Nat → Nat
foo x = 1 + x

bar : Nat → Nat
bar x = foo (foo (x))

-- Here we test that normalisation respects ReduceDefs
-- when parameter reconstruction is on.
macro
  y : Term → TC ⊤
  y hole = do
      (function (clause tel ps t ∷ [])) ← withReconstructed (dontReduceDefs (quote foo ∷ []) (getDefinition (quote bar)))
        where _ → quoteTC "ERROR" >>= unify hole
      t ← inContext (reverse tel)
          (withReconstructed (dontReduceDefs (quote foo ∷ []) (normalise t)))
      quoteTC t >>= unify hole

test₂ : y ≡ def (quote foo) (arg _ (def (quote foo) _) ∷ [])
test₂ = refl


{-# OPTIONS --guardedness #-}
module hello-world-prog where

open import IO

main : Main
main = run (putStrLn "Hello, World!")


-- Currently this test case is broken. Once Issue 3451 has been fixed
-- it should be moved to test/Fail (and this comment should be
-- removed).

-- The option --guardedness turns off sized types.

{-# OPTIONS --guardedness #-}

open import Agda.Builtin.Size

record Stream (A : Set) (i : Size) : Set where
  coinductive
  field
    head : A
    tail : {j : Size< i} → Stream A j

open Stream

postulate
  destroy-guardedness : {A : Set} → A → A

repeat : ∀ {A i} → A → Stream A i
repeat x .head = x
repeat x .tail = destroy-guardedness (repeat x)


open import FRP.JS.Behaviour using ( Beh ; [_] )
open import FRP.JS.DOM using ( DOM ; element ; attr ; text ; _++_ )
open import FRP.JS.RSet using ( ⟦_⟧ )

module FRP.JS.Demo.HRef where

main : ∀ {w} → ⟦ Beh (DOM w) ⟧
main = element ("a")
  ( attr "href" ["http://bell-labs.com/"] ++
    text ["A hyperlink."] )


module README where

------------------------------------------------------------------------
-- The Agda "standard" library, version 0.2
--
-- Author: Nils Anders Danielsson, with contributions from
-- Jean-Philippe Bernardy, Samuel Bronson, Liang-Ting Chen, Dan Doel,
-- Patrik Jansson, Shin-Cheng Mu, and Ulf Norell
------------------------------------------------------------------------

-- This version of the library has been tested using Agda 2.2.4.

-- Note that no guarantees are currently made about forwards or
-- backwards compatibility, the library is still at an experimental
-- stage.

-- To make use of the library, add the path to the library’s root
-- directory (src) to the Agda search path, either using the
-- --include-path flag or by customising the Emacs mode variable
-- agda2-include-dirs (M-x customize-group RET agda2 RET).

-- To compile programs using some of the IO functions you need to
-- install the Haskell package utf8-string (available from Hackage).

-- Contributions to this library are welcome. Please send
-- contributions in the form of darcs patches (run
-- darcs send --output <patch file> and attach the patch file to an
-- email), and include a statement saying that you agree to release
-- your library patches under the library's licence.

------------------------------------------------------------------------
-- Module hierarchy
------------------------------------------------------------------------

-- The top-level module names of the library are currently allocated
-- as follows:
--
-- • Algebra
--     Abstract algebra (monoids, groups, rings etc.), along with
--     properties needed to specify these structures (associativity,
--     commutativity, etc.), and operations on and proofs about the
--     structures.
-- • Category
--     Category theory-inspired idioms used to structure functional
--     programs (functors and monads, for instance).
-- • Coinduction
--     Support for coinduction.
-- • Data
--     Data types and properties about data types. (Also some
--     combinators working solely on and with functions; see
--     Data.Function.)
-- • Foreign
--     Related to the foreign function interface.
-- • Induction
--     A general framework for induction (includes lexicographic and
--     well-founded induction).
-- • IO
--     Input/output-related functions.
-- • Relation
--     Properties of and proofs about relations (mostly homogeneous
--     binary relations).
-- • Size
--     Sizes used by the sized types mechanism.

------------------------------------------------------------------------
-- A selection of useful library modules
------------------------------------------------------------------------

-- Note that module names in source code are often hyperlinked to the
-- corresponding module. In the Emacs mode you can follow these
-- hyperlinks by typing M-. or clicking with the middle mouse button.

-- • Some data types

import Data.Bool     -- Booleans.
import Data.Char     -- Characters.
import Data.Empty    -- The empty type.
import Data.Fin      -- Finite sets.
import Data.List     -- Lists.
import Data.Maybe    -- The maybe type.
import Data.Nat      -- Natural numbers.
import Data.Product  -- Products.
import Data.Stream   -- Streams.
import Data.String   -- Strings.
import Data.Sum      -- Disjoint sums.
import Data.Unit     -- The unit type.
import Data.Vec      -- Fixed-length vectors.

-- • Some types used to structure computations

import Category.Functor      -- Functors.
import Category.Applicative  -- Applicative functors.
import Category.Monad        -- Monads.

-- • Equality

-- Propositional equality:
import Relation.Binary.PropositionalEquality

-- Convenient syntax for "equational reasoning" using a preorder:
import Relation.Binary.PreorderReasoning

-- Solver for commutative ring or semiring equalities:
import Algebra.RingSolver

-- • Properties of functions, sets and relations

-- Monoids, rings and similar algebraic structures:
import Algebra

-- Negation, decidability, and similar operations on sets:
import Relation.Nullary

-- Properties of homogeneous binary relations:
import Relation.Binary

-- • Induction

-- An abstraction of various forms of recursion/induction:
import Induction

-- Well-founded induction:
import Induction.WellFounded

-- Various forms of induction for natural numbers:
import Induction.Nat

-- • Support for coinduction

import Coinduction

-- • IO

import IO

------------------------------------------------------------------------
-- Record hierarchies
------------------------------------------------------------------------

-- When an abstract hierarchy of some sort (for instance semigroup →
-- monoid → group) is included in the library the basic approach is to
-- specify the properties of every concept in terms of a record
-- containing just properties, parameterised on the underlying
-- operations, sets etc.:
--
--   record IsSemigroup {A} (≈ : Rel A) (∙ : Op₂ A) : Set where
--     open FunctionProperties ≈
--     field
--       isEquivalence : IsEquivalence ≈
--       assoc         : Associative ∙
--       ∙-pres-≈      : ∙ Preserves₂ ≈ ⟶ ≈ ⟶ ≈
--
-- More specific concepts are then specified in terms of the simpler
-- ones:
--
--     record IsMonoid {A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) : Set where
--       open FunctionProperties ≈
--       field
--         isSemigroup : IsSemigroup ≈ ∙
--         identity    : Identity ε ∙
--
--     open IsSemigroup isSemigroup public
--
-- Note here that open IsSemigroup isSemigroup public ensures that the
-- fields of the isSemigroup record can be accessed directly; this
-- technique enables the user of an IsMonoid record to use underlying
-- records without having to manually open an entire record hierarchy.
-- This is not always possible, though. Consider the following definition
-- of preorders:
--
--   record IsPreorder {A : Set}
--                     (_≈_ : Rel A) -- The underlying equality.
--                     (_∼_ : Rel A) -- The relation.
--                     : Set where
--     field
--       isEquivalence : IsEquivalence _≈_
--       -- Reflexivity is expressed in terms of an underlying equality:
--       reflexive     : _≈_ ⇒ _∼_
--       trans         : Transitive _∼_
--       ∼-resp-≈      : _∼_ Respects₂ _≈_
--
--     module Eq = IsEquivalence isEquivalence
--
--     refl : Reflexive _∼_
--     refl = reflexive Eq.refl
--
-- The Eq module in IsPreorder is not opened publicly, because it
-- contains some fields which clash with fields or other definitions
-- in IsPreorder.

-- Records packing up properties with the corresponding operations,
-- sets, etc. are sometimes also defined:
--
--   record Semigroup : Set₁ where
--     infixl 7 _∙_
--     infix  4 _≈_
--     field
--       carrier     : Set
--       _≈_         : Rel carrier
--       _∙_         : Op₂ carrier
--       isSemigroup : IsSemigroup _≈_ _∙_
--
--     open IsSemigroup isSemigroup public
--
--     setoid : Setoid
--     setoid = record { isEquivalence = isEquivalence }
--
--   record Monoid : Set₁ where
--     infixl 7 _∙_
--     infix  4 _≈_
--     field
--       carrier  : Set
--       _≈_      : Rel carrier
--       _∙_      : Op₂ carrier
--       ε        : carrier
--       isMonoid : IsMonoid _≈_ _∙_ ε
--
--     open IsMonoid isMonoid public
--
--     semigroup : Semigroup
--     semigroup = record { isSemigroup = isSemigroup }
--
--     open Semigroup semigroup public using (setoid)
--
-- Note that the Monoid record does not include a Semigroup field.
-- Instead the Monoid /module/ includes a "repackaging function"
-- semigroup which converts a Monoid to a Semigroup.

-- The above setup may seem a bit complicated, but we think it makes the
-- library quite easy to work with, while also providing enough
-- flexibility.

------------------------------------------------------------------------
-- More documentation
------------------------------------------------------------------------

-- Some examples showing where the natural numbers and some related
-- operations and properties are defined, and how they can be used:

import README.Nat

------------------------------------------------------------------------
-- Core modules
------------------------------------------------------------------------

-- Some modules have names ending in ".Core". These modules are
-- internal, and have (mostly) been created to avoid mutual recursion
-- between modules. They should not be imported directly; their
-- contents are reexported by other modules.

------------------------------------------------------------------------
-- All library modules
------------------------------------------------------------------------

-- For short descriptions of every library module, see Everything:

import Everything


module Syntax.Substitution where

open import Syntax.Substitution.Kits public
open import Syntax.Substitution.Instances public
open import Syntax.Substitution.Lemmas public


module _ where

data Flat (A : Set) : Set where
  flat : @♭ A → Flat A

-- the lambda cohesion annotation must match the domain.
into : {A : Set} → A → Flat A
into = λ (@♭ a) → flat a


------------------------------------------------------------------------
-- Pointers to results from the paper
------------------------------------------------------------------------

module README.Pointers-to-results-from-the-paper where

open import Prelude using (Type)
open import Prelude.Size using (∞)

import Colist
import Conat
import Omniscience

import Delay-monad
import Delay-monad.Bisimilarity
import Delay-monad.Monad
import Delay-monad.Quantitative-weak-bisimilarity

import Only-allocation
import Unbounded-space
import Upper-bounds

import Lambda.Compiler
import Lambda.Compiler-correctness
import Lambda.Compiler-correctness.Sizes-match
import Lambda.Compiler-correctness.Steps-match
import Lambda.Delay-crash
import Lambda.Delay-crash-trace
import Lambda.Interpreter
import Lambda.Interpreter.Stack-sizes
import Lambda.Interpreter.Stack-sizes.Counterexample
import Lambda.Interpreter.Stack-sizes.Example
import Lambda.Interpreter.Steps
import Lambda.Interpreter.Steps.Counterexample
import Lambda.Virtual-machine
import Lambda.Virtual-machine.Instructions
import Lambda.Syntax

------------------------------------------------------------------------
-- Section 2

-- Conatural numbers.

Conat  = Conat.Conat
Conat′ = Conat.Conat′

-- Infinity.

infinity = Conat.infinity

-- Ordering.

[_]_≤_  = Conat.[_]_≤_
[_]_≤′_ = Conat.[_]_≤′_

-- Bisimilarity.

[_]_∼N_ = Conat.[_]_∼_

------------------------------------------------------------------------
-- Section 3

-- Programs.

Stmt    = Only-allocation.Stmt
Program = Only-allocation.Program

-- Colists.

Colist = Colist.Colist

-- The interpreter.

modify = Unbounded-space.modify
⟦_⟧₁   = Unbounded-space.⟦_⟧
⟦_⟧′   = Unbounded-space.⟦_⟧′

-- Upper bounds.

[_]_⊑_  = Upper-bounds.[_]_⊑_
[_]_⊑′_ = Upper-bounds.[_]_⊑′_

-- The □ predicate.

□ = Colist.□

-- Least upper bounds.

LUB = Upper-bounds.LUB

-- Least upper bounds are unique up to bisimilarity.

lub-unique = Upper-bounds.lub-unique

-- Antisymmetry for conatural numbers.

antisymmetric = Conat.antisymmetric-≤

-- WLPO.

WLPO = Omniscience.WLPO

-- WLPO is classically valid: it follows from excluded middle and
-- extensionality for functions.

LEM→WLPO = Omniscience.LEM→WLPO

-- WLPO is logically equivalent to one formulation of "least upper
-- bounds exist for every colist".

wlpo⇔lub = Unbounded-space.wlpo⇔lub

-- Maximum heap usage.

Heap-usage = Unbounded-space.Heap-usage

-- This was not mentioned in the paper, but WLPO is also logically
-- equivalent to one formulation of "maximum heap usages exist for
-- every program".

wlpo⇔max = Unbounded-space.wlpo⇔max

-- The maximum heap usage is unique up to bisimilarity.

max-unique = Unbounded-space.max-unique

-- Some examples.

bounded   = Only-allocation.bounded
bounded₂  = Only-allocation.bounded₂
unbounded = Only-allocation.unbounded
_∷′_      = Colist._∷′_

-- The example programs have infinitely long traces.

bounded-loops   = Unbounded-space.bounded-loops
bounded₂-loops  = Unbounded-space.bounded₂-loops
unbounded-loops = Unbounded-space.unbounded-loops

-- Properties showing that the example programs have certain maximum
-- heap usages.

max-bounded-1   = Unbounded-space.max-bounded-1
max-bounded₂-2  = Unbounded-space.max-bounded₂-2
max-unbounded-∞ = Unbounded-space.max-unbounded-∞

-- If no natural number is an upper bound of the heap usage of p, then
-- the maximum heap usage of p is infinity.

no-finite-max→infinite-max = Unbounded-space.no-finite-max→infinite-max

-- If no natural number is an upper bound of ms, but the conatural
-- number m is, then m is bisimilar to infinity.

no-finite→infinite = Upper-bounds.no-finite→infinite

------------------------------------------------------------------------
-- Section 4

-- The optimiser.

opt = Unbounded-space.opt

-- The optimiser improves the space complexity of at least one
-- program.

opt-improves = Unbounded-space.opt-improves

-- The semantics of optimise bounded-space₂ matches that of
-- bounded-space.

opt-bounded₂∼bounded = Unbounded-space.opt-bounded₂∼bounded

-- Bisimilarity of colists.

[_]_∼L_ = Colist.[_]_∼_

-- The maximum heap usage of an optimised program is at most as high
-- as that of the original program (assuming that these maximums
-- exist).

opt-correct = Unbounded-space.opt-correct

-- The [_]_≲_ relation.

[_]_≲_  = Upper-bounds.[_]_≲_
[_]_≲′_ = Upper-bounds.[_]_≲′_

-- If ms has the least upper bound m, and ns has the least upper bound
-- n, then ms is bounded by ns if and only if m is bounded by n.

≲⇔least-upper-bounds-≤ = Upper-bounds.≲⇔least-upper-bounds-≤

-- Four combinators that can be used to prove that one colist is
-- bounded by another.

[]≲     = Upper-bounds.[]≲
consʳ-≲ = Upper-bounds.consʳ-≲
consˡ-≲ = Upper-bounds.consˡ-≲
cons′-≲ = Upper-bounds.cons′-≲
Bounded = Upper-bounds.Bounded

-- If consʳ-≲ had taken the primed variant of the relation as an
-- argument instead, then one could have proved that any colist was
-- bounded by any infinite colist, and this leads to a contradiction.

consʳ-≲′→≲-infinite = Upper-bounds.consʳ-≲′→≲-infinite
¬-consʳ-≲′          = Upper-bounds.¬-consʳ-≲′

-- The [_]_≲_ relation is a preorder. (The transitivity result has a
-- type signature that differs slightly from that given in the paper.)

reflexive-≲  = Upper-bounds._□≲
transitive-≲ = Upper-bounds.step-≲

-- Transitivity cannot be made size-preserving in the second argument.

¬-transitivity-size-preservingʳ =
  Upper-bounds.¬-transitivity-size-preservingʳ

-- A size-preserving variant of transitivity. (This result has a
-- type signature that differs slightly from that given in the paper.)

transitive-∼≲ = Upper-bounds.step-∼≲

-- The main lemma used to prove that the maximum heap usage of an
-- optimised program is at most as high as that of the original
-- program (assuming that these maximums exist).

opt-correct-≲ = Unbounded-space.opt-correct-≲

------------------------------------------------------------------------
-- Section 5

-- The delay monad.

Delay = Delay-monad.Delay

-- The non-terminating computation never.

never = Delay-monad.never

-- Monad instance.

monad-instance₁ = Delay-monad.Monad.delay-raw-monad

-- Strong bisimilarity.

[_]_∼D_ = Delay-monad.Bisimilarity.[_]_∼_

-- Monad laws.

left-identity₁  = Delay-monad.Monad.left-identity′
right-identity₁ = Delay-monad.Monad.right-identity′
associativity₁  = Delay-monad.Monad.associativity′

-- Weak bisimilarity. (This relation is not defined in exactly the
-- same way as in the paper.)

[_]_≈D_ = Delay-monad.Bisimilarity.[_]_≈_

------------------------------------------------------------------------
-- Section 6

-- Terms.

Tm = Lambda.Syntax.Tm

-- Environments and values. (The code uses a definition which is
-- parametrised by the type of terms. The same definition is used also
-- for virtual machine environments and values.)

Env   = Lambda.Syntax.Closure.Env
Value = Lambda.Syntax.Closure.Value

-- DelayC (called Delay-crash in the code) and crash.

DelayC = Lambda.Delay-crash.Delay-crash

crash : {A : Type} → DelayC A ∞
crash = Lambda.Delay-crash.crash

-- The computation crash (in fact, any computation of the form now x)
-- is not weakly bisimilar to never.

now≉never = Delay-monad.Bisimilarity.now≉never

-- The interpreter.

_∙_  = Lambda.Interpreter._∙_
⟦_⟧₂ = Lambda.Interpreter.⟦_⟧
⟦if⟧ = Lambda.Interpreter.⟦if⟧

------------------------------------------------------------------------
-- Section 7

-- DelayCT (called Delay-crash-trace in the code).

DelayCT = Lambda.Delay-crash-trace.Delay-crash-trace
trace   = Lambda.Delay-crash-trace.trace
delayC  = Lambda.Delay-crash-trace.delay-crash

-- Monad instance.

monad-instance₂ = Lambda.Delay-crash-trace.raw-monad

-- Strong bisimilarity.

[_]_∼DCT_ = Lambda.Delay-crash-trace.[_]_∼_

-- Monad laws.

left-identity₂  = Lambda.Delay-crash-trace.left-identity
right-identity₂ = Lambda.Delay-crash-trace.right-identity
associativity₂  = Lambda.Delay-crash-trace.associativity

-- Instructions and code.

Instr = Lambda.Virtual-machine.Instructions.Instr
Code  = Lambda.Virtual-machine.Instructions.Code

-- Environments and values. (The code uses a definition which is
-- parametrised by the type of terms. The same definition is used also
-- for the interpreter's environments and values.)

VM-Env   = Lambda.Syntax.Closure.Env
VM-Value = Lambda.Syntax.Closure.Value

-- Stack elements and stacks.

Stack-element = Lambda.Virtual-machine.Instructions.Stack-element
Stack         = Lambda.Virtual-machine.Instructions.Stack

-- States.

State = Lambda.Virtual-machine.Instructions.State

-- The virtual machine.

Result      = Lambda.Virtual-machine.Instructions.Result
step        = Lambda.Virtual-machine.step
exec⁺       = Lambda.Virtual-machine.exec⁺
exec⁺′      = Lambda.Virtual-machine.exec⁺′
exec        = Lambda.Virtual-machine.exec
stack-sizes = Lambda.Virtual-machine.stack-sizes

------------------------------------------------------------------------
-- Section 8

-- Tail context information.

In-tail-context = Lambda.Compiler.In-tail-context

-- The compilation functions.

comp      = Lambda.Compiler.comp
comp-body = Lambda.Compiler.comp-body
comp-name = Lambda.Compiler.comp-name
comp-env  = Lambda.Compiler.comp-env
comp-val  = Lambda.Compiler.comp-val
comp₀     = Lambda.Compiler.comp₀

-- Compiler correctness.

compiler-correct = Lambda.Compiler-correctness.correct

-- The key lemma used to prove compiler correctness.

key-lemma₁ = Lambda.Compiler-correctness.⟦⟧-correct
Cont-OK    = Lambda.Compiler-correctness.Cont-OK
Stack-OK   = Lambda.Compiler-correctness.Stack-OK

------------------------------------------------------------------------
-- Section 9

-- The instrumented interpreter.

[_,_]_∙S_    = Lambda.Interpreter.Stack-sizes.[_,_]_∙_
⟦_⟧S         = Lambda.Interpreter.Stack-sizes.⟦_⟧
δ            = Lambda.Interpreter.Stack-sizes.δ
⟦if⟧S        = Lambda.Interpreter.Stack-sizes.⟦if⟧
scanl        = Colist.scanl
numbers      = Lambda.Interpreter.Stack-sizes.numbers
stack-sizesS = Lambda.Interpreter.Stack-sizes.stack-sizes

-- The instrumented semantics produces computations that are strongly
-- bisimilar to those produced by the other semantics.

⟦⟧∼⟦⟧ = Lambda.Interpreter.Stack-sizes.⟦⟧∼⟦⟧

-- If the trace of stack sizes produced by the instrumented semantics
-- has the least upper bound i, and the corresponding trace produced
-- by the virtual machine has the least upper bound v, then i and v
-- are bisimilar.

maximum-stack-sizes-match =
  Lambda.Compiler-correctness.Sizes-match.maximum-stack-sizes-match

-- The trace of stack sizes produced by the virtual machine is not
-- necessarily bisimilar to that produced by the instrumented
-- interpreter.

stack-sizes-not-bisimilar =
  Lambda.Interpreter.Stack-sizes.Counterexample.stack-sizes-not-bisimilar

-- The trace of stack sizes produced by the virtual machine and that
-- produced by the instrumented interpreter are upper bounds of each
-- other.

stack-sizes-related =
  Lambda.Compiler-correctness.Sizes-match.stack-sizes-related

-- The [_]_≂_ relation.

[_]_≂_  = Upper-bounds.[_]_≂_
[_]_≂′_ = Upper-bounds.[_]_≂′_

-- Colists that are related by this relation have the same least upper
-- bounds (if any).

LUB-cong = Upper-bounds.LUB-cong

-- Some combinators that can be used to prove that two colists are
-- bounded by each other.

consʳ-≂ = Upper-bounds.consʳ-≂
consˡ-≂ = Upper-bounds.consˡ-≂
cons-≂  = Upper-bounds.cons-≂
cons′-≂ = Upper-bounds.cons′-≂

-- The [_]_≂_ relation is an equivalence relation. (The
-- transitivity-like results have type signatures that differ slightly
-- from those given in the paper.)

reflexive-≂   = Upper-bounds._□≂
symmetric-≂   = Upper-bounds.symmetric-≂
transitive-≂  = Upper-bounds.step-≂
transitive-∼≂ = Upper-bounds.step-∼≂
transitive-≂∼ = Upper-bounds.step-≂∼

-- The [_]_≂″_ relation.

[_]_≂″_ = Upper-bounds.[_]_≂″_

-- [_]_≂′_ and [_]_≂″_ are pointwise logically equivalent.

≂′⇔≂″ = Upper-bounds.≂′⇔≂″

-- This was not mentioned in the paper, but a corresponding relation
-- can also be defined for [_]_≲′_.

[_]_≲″_ = Upper-bounds.[_]_≲″_
≲′⇔≲″   = Upper-bounds.≲′⇔≲″

-- The key lemma used to prove correctness.

key-lemma₂ = Lambda.Compiler-correctness.Sizes-match.⟦⟧-correct

-- A non-terminating program that requires unbounded stack space.

Ω                          = Lambda.Syntax.Ω
Ω-loops                    = Lambda.Interpreter.Ω-loops′
Ω-requires-unbounded-space =
  Lambda.Interpreter.Stack-sizes.Ω-requires-unbounded-space

-- A non-terminating program that runs in bounded stack space.

go               = Lambda.Interpreter.Stack-sizes.Example.go
go-loops         = Lambda.Interpreter.Stack-sizes.Example.go-loops
go-bounded-stack =
  Lambda.Interpreter.Stack-sizes.Example.go-bounded-stack

------------------------------------------------------------------------
-- Section 10

-- The uninstrumented interpreter does not provide a suitable cost
-- measure, in the sense that there is a family of programs for which
-- the running "time" (number of steps) of the corresponding compiled
-- programs on the virtual machine is not linear in the running time
-- on the interpreter.

not-suitable-cost-measure =
  Lambda.Interpreter.Steps.Counterexample.not-suitable-cost-measure

-- The instrumented interpreter.

✓_    = Lambda.Interpreter.Steps.✓_
_∙T_  = Lambda.Interpreter.Steps._∙_
⟦_⟧T  = Lambda.Interpreter.Steps.⟦_⟧
⟦if⟧T = Lambda.Interpreter.Steps.⟦if⟧

-- The cost measure provided by the instrumented interpreter is
-- "suitable", in the sense that the cost of running a compiled
-- program on the virtual machine is linear in the cost of running the
-- corresponding source program on the interpreter, and vice versa.

the-cost-measure-is-suitable =
  Lambda.Compiler-correctness.Steps-match.steps-match

-- Quantitative weak bisimilarity.

[_∣_∣_∣_∣_]_≈D_ =
  Delay-monad.Quantitative-weak-bisimilarity.[_∣_∣_∣_∣_]_≈_

-- A characterisation of quantitative weak bisimilarity.

≈⇔≈×steps≤steps² =
  Delay-monad.Quantitative-weak-bisimilarity.≈⇔≈×steps≤steps²

-- The left-to-right direction of the characterisation can be made
-- size-preserving.

≈→≈×steps≤steps² =
  Delay-monad.Quantitative-weak-bisimilarity.≈→≈×steps≤steps²

-- The right-to-left direction of the characterisation can be made
-- size-preserving if and only if the carrier type is uninhabited
-- (assuming that Agda is not buggy).

≈×steps≤steps²→≈⇔uninhabited =
  Delay-monad.Quantitative-weak-bisimilarity.≈×steps≤steps²→≈⇔uninhabited

-- Weakening.

weaken = Delay-monad.Quantitative-weak-bisimilarity.weaken

-- Two transitivity-like results.

transitive-≳∼ = Delay-monad.Quantitative-weak-bisimilarity.transitive-≳∼
transitive-≈∼ = Delay-monad.Quantitative-weak-bisimilarity.transitive-≈∼
transitive-∼≈ = Delay-monad.Quantitative-weak-bisimilarity.transitive-∼≈

-- The key lemma used to prove that the cost measure is "suitable".

key-lemma₃ = Lambda.Compiler-correctness.Steps-match.⟦⟧-correct


{-# OPTIONS --safe #-}

module Cubical.HITs.FreeComMonoids where

open import Cubical.HITs.FreeComMonoids.Base public
open import Cubical.HITs.FreeComMonoids.Properties public


------------------------------------------------------------------------
-- Some simple substitution combinators
------------------------------------------------------------------------

-- Given a term type which supports weakening and transformation of
-- variables to terms various substitutions are defined and various
-- lemmas proved.

open import Data.Universe.Indexed

module deBruijn.Substitution.Function.Simple
  {i u e} {Uni : IndexedUniverse i u e} where

import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Function.Basics
open import deBruijn.Substitution.Function.Map
open import Function as F using (_$_)
open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open P.≡-Reasoning

-- Simple substitutions.

record Simple {t} (T : Term-like t) : Set (i ⊔ u ⊔ e ⊔ t) where

  open Term-like T

  field

    -- Weakens terms.
    weaken : ∀ {Γ} {σ : Type Γ} → [ T ⟶ T ] ŵk[ σ ]

  -- A synonym.

  weaken[_] : ∀ {Γ} (σ : Type Γ) → [ T ⟶ T ] ŵk[ σ ]
  weaken[_] _ = weaken

  field

    -- Takes variables to terms.
    var : [ Var ⟶⁼ T ]

    -- A property relating weaken and var.
    weaken-var : ∀ {Γ σ τ} (x : Γ ∋ τ) →
                 weaken[ σ ] · (var · x) ≅-⊢ var · suc[ σ ] x

  -- Weakens substitutions.

  wk-subst : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → Sub T (ρ̂ ∘̂ ŵk[ σ ])
  wk-subst ρ = map weaken ρ

  wk-subst[_] : ∀ {Γ Δ} σ {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → Sub T (ρ̂ ∘̂ ŵk[ σ ])
  wk-subst[ _ ] = wk-subst

  -- N-ary weakening of substitutions.

  wk-subst⁺ : ∀ {Γ Δ} Δ⁺ {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → Sub T (ρ̂ ∘̂ ŵk⁺ Δ⁺)
  wk-subst⁺ ε        ρ = ρ
  wk-subst⁺ (Δ⁺ ▻ σ) ρ = wk-subst (wk-subst⁺ Δ⁺ ρ)

  wk-subst₊ : ∀ {Γ Δ} Δ₊ {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → Sub T (ρ̂ ∘̂ ŵk₊ Δ₊)
  wk-subst₊ ε        ρ = ρ
  wk-subst₊ (σ ◅ Δ₊) ρ = wk-subst₊ Δ₊ (wk-subst ρ)

  -- Lifting.

  infixl 10 _↑_
  infix  10 _↑

  _↑_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → ∀ σ → Sub T (ρ̂ ↑̂ σ)
  ρ ↑ _ =
    P.subst (Sub T)
            (≅-⇨̂-⇒-≡ $ ▻̂-cong P.refl P.refl
                         (P.sym $ corresponds var zero))
            (wk-subst ρ ▻⇨ var · zero)

  _↑ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → Sub T (ρ̂ ↑̂ σ)
  ρ ↑ = ρ ↑ _

  -- N-ary lifting.

  infixl 10 _↑⁺_ _↑₊_

  _↑⁺_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → ∀ Γ⁺ → Sub T (ρ̂ ↑̂⁺ Γ⁺)
  ρ ↑⁺ ε        = ρ
  ρ ↑⁺ (Γ⁺ ▻ σ) = (ρ ↑⁺ Γ⁺) ↑

  _↑₊_ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → ∀ Γ₊ → Sub T (ρ̂ ↑̂₊ Γ₊)
  ρ ↑₊ ε        = ρ
  ρ ↑₊ (σ ◅ Γ₊) = ρ ↑ ↑₊ Γ₊

  -- The identity substitution.

  id[_] : ∀ Γ → Sub T îd[ Γ ]
  id[ ε     ] = ε⇨
  id[ Γ ▻ σ ] = id[ Γ ] ↑

  id : ∀ {Γ} → Sub T îd[ Γ ]
  id = id[ _ ]

  -- N-ary weakening.

  wk⁺ : ∀ {Γ} (Γ⁺ : Ctxt⁺ Γ) → Sub T (ŵk⁺ Γ⁺)
  wk⁺ ε        = id
  wk⁺ (Γ⁺ ▻ σ) = wk-subst (wk⁺ Γ⁺)

  wk₊ : ∀ {Γ} (Γ₊ : Ctxt₊ Γ) → Sub T (ŵk₊ Γ₊)
  wk₊ Γ₊ = wk-subst₊ Γ₊ id

  -- Weakening.

  wk[_] : ∀ {Γ} (σ : Type Γ) → Sub T ŵk[ σ ]
  wk[ σ ] = wk⁺ (ε ▻ σ)

  wk : ∀ {Γ} {σ : Type Γ} → Sub T ŵk[ σ ]
  wk = wk[ _ ]

  private

    -- Three possible definitions of wk coincide definitionally.

    coincide₁ : ∀ {Γ} {σ : Type Γ} → wk⁺ (ε ▻ σ) ≡ wk₊ (σ ◅ ε)
    coincide₁ = P.refl

    coincide₂ : ∀ {Γ} {σ : Type Γ} → wk⁺ (ε ▻ σ) ≡ wk-subst id
    coincide₂ = P.refl

  -- A substitution which only replaces the first variable.

  sub : ∀ {Γ σ} (t : Γ ⊢ σ) → Sub T (ŝub ⟦ t ⟧)
  sub t = id ▻⇨ t

  abstract

    -- Unfolding lemma for _↑.

    unfold-↑ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) →
               ρ ↑ σ ≅-⇨ wk-subst[ σ / ρ ] ρ ▻⇨[ σ ] var · zero
    unfold-↑ _ =
      drop-subst-Sub F.id
        (≅-⇨̂-⇒-≡ $ ▻̂-cong P.refl P.refl (P.sym $ corresponds var zero))

  -- Some congruence lemmas.

  weaken-cong : ∀ {Γ₁ σ₁ τ₁} {t₁ : Γ₁ ⊢ τ₁}
                  {Γ₂ σ₂ τ₂} {t₂ : Γ₂ ⊢ τ₂} →
                σ₁ ≅-Type σ₂ → t₁ ≅-⊢ t₂ →
                weaken[ σ₁ ] · t₁ ≅-⊢ weaken[ σ₂ ] · t₂
  weaken-cong P.refl P.refl = P.refl

  var-cong : ∀ {Γ₁ σ₁} {x₁ : Γ₁ ∋ σ₁}
               {Γ₂ σ₂} {x₂ : Γ₂ ∋ σ₂} →
               x₁ ≅-∋ x₂ → var · x₁ ≅-⊢ var · x₂
  var-cong P.refl = P.refl

  wk-subst-cong : ∀ {Γ₁ Δ₁ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
                    {Γ₂ Δ₂ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
                  σ₁ ≅-Type σ₂ → ρ₁ ≅-⇨ ρ₂ →
                  wk-subst[ σ₁ ] ρ₁ ≅-⇨ wk-subst[ σ₂ ] ρ₂
  wk-subst-cong {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] =
    [ P.refl ]

  abstract

    wk-subst⁺-cong : ∀ {Γ₁ Δ₁ Γ⁺₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
                       {Γ₂ Δ₂ Γ⁺₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
                     Γ⁺₁ ≅-Ctxt⁺ Γ⁺₂ → ρ₁ ≅-⇨ ρ₂ →
                     wk-subst⁺ Γ⁺₁ ρ₁ ≅-⇨ wk-subst⁺ Γ⁺₂ ρ₂
    wk-subst⁺-cong {Γ⁺₁ = ε} {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] =
      [ P.refl ]
    wk-subst⁺-cong {Γ⁺₁ = Γ⁺₁ ▻ σ} P.refl ρ₁≅ρ₂ =
      wk-subst-cong (P.refl {x = [ σ ]})
                    (wk-subst⁺-cong (P.refl {x = [ Γ⁺₁ ]}) ρ₁≅ρ₂)

    wk-subst₊-cong : ∀ {Γ₁ Δ₁ Γ₊₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
                       {Γ₂ Δ₂ Γ₊₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
                     Γ₊₁ ≅-Ctxt₊ Γ₊₂ → ρ₁ ≅-⇨ ρ₂ →
                     wk-subst₊ Γ₊₁ ρ₁ ≅-⇨ wk-subst₊ Γ₊₂ ρ₂
    wk-subst₊-cong {Γ₊₁ = ε} {ρ₁ = _ , _} {ρ₂ = ._ , _} P.refl [ P.refl ] =
      [ P.refl ]
    wk-subst₊-cong {Γ₊₁ = σ ◅ Γ₊₁} P.refl ρ₁≅ρ₂ =
      wk-subst₊-cong (P.refl {x = [ Γ₊₁ ]}) (wk-subst-cong P.refl ρ₁≅ρ₂)

    ↑-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁} {σ₁}
               {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} {σ₂} →
             ρ₁ ≅-⇨ ρ₂ → σ₁ ≅-Type σ₂ → ρ₁ ↑ σ₁ ≅-⇨ ρ₂ ↑ σ₂
    ↑-cong {ρ₁ = ρ₁} {σ₁} {ρ₂ = ρ₂} {σ₂} ρ₁≅ρ₂ σ₁≅σ₂ =
      let lemma = /-cong σ₁≅σ₂ ρ₁≅ρ₂ in
      ρ₁ ↑ σ₁                               ≅-⟶⟨ unfold-↑ ρ₁ ⟩
      wk-subst ρ₁ ▻⇨ var · zero[ σ₁ / ρ₁ ]  ≅-⟶⟨ ▻⇨-cong σ₁≅σ₂ (wk-subst-cong lemma ρ₁≅ρ₂) (var-cong (zero-cong lemma)) ⟩
      wk-subst ρ₂ ▻⇨ var · zero[ σ₂ / ρ₂ ]  ≅-⟶⟨ sym-⟶ $ unfold-↑ ρ₂ ⟩
      ρ₂ ↑ σ₂                               ∎-⟶

    ↑⁺-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁} {Γ⁺₁}
                {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} {Γ⁺₂} →
              ρ₁ ≅-⇨ ρ₂ → Γ⁺₁ ≅-Ctxt⁺ Γ⁺₂ → ρ₁ ↑⁺ Γ⁺₁ ≅-⇨ ρ₂ ↑⁺ Γ⁺₂
    ↑⁺-cong {ρ₁ = _ , _} {Γ⁺₁ = ε} {ρ₂ = ._ , _} [ P.refl ] P.refl =
      [ P.refl ]
    ↑⁺-cong {Γ⁺₁ = Γ⁺ ▻ σ} ρ₁≅ρ₂ P.refl =
      ↑-cong (↑⁺-cong ρ₁≅ρ₂ (P.refl {x = [ Γ⁺ ]})) P.refl

    ↑₊-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁} {Γ₊₁}
                {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} {Γ₊₂} →
              ρ₁ ≅-⇨ ρ₂ → Γ₊₁ ≅-Ctxt₊ Γ₊₂ → ρ₁ ↑₊ Γ₊₁ ≅-⇨ ρ₂ ↑₊ Γ₊₂
    ↑₊-cong {ρ₁ = _ , _} {Γ₊₁ = ε} {ρ₂ = ._ , _} [ P.refl ] P.refl =
      [ P.refl ]
    ↑₊-cong {Γ₊₁ = σ ◅ Γ₊} ρ₁≅ρ₂ P.refl =
      ↑₊-cong (↑-cong ρ₁≅ρ₂ P.refl) (P.refl {x = [ Γ₊ ]})

  id-cong : ∀ {Γ₁ Γ₂} → Γ₁ ≅-Ctxt Γ₂ → id[ Γ₁ ] ≅-⇨ id[ Γ₂ ]
  id-cong P.refl = [ P.refl ]

  wk⁺-cong : ∀ {Γ₁} {Γ⁺₁ : Ctxt⁺ Γ₁} {Γ₂} {Γ⁺₂ : Ctxt⁺ Γ₂} →
             Γ⁺₁ ≅-Ctxt⁺ Γ⁺₂ → wk⁺ Γ⁺₁ ≅-⇨ wk⁺ Γ⁺₂
  wk⁺-cong P.refl = [ P.refl ]

  wk₊-cong : ∀ {Γ₁} {Γ₊₁ : Ctxt₊ Γ₁} {Γ₂} {Γ₊₂ : Ctxt₊ Γ₂} →
             Γ₊₁ ≅-Ctxt₊ Γ₊₂ → wk₊ Γ₊₁ ≅-⇨ wk₊ Γ₊₂
  wk₊-cong P.refl = [ P.refl ]

  wk-cong : ∀ {Γ₁} {σ₁ : Type Γ₁} {Γ₂} {σ₂ : Type Γ₂} →
            σ₁ ≅-Type σ₂ → wk[ σ₁ ] ≅-⇨ wk[ σ₂ ]
  wk-cong P.refl = [ P.refl ]

  sub-cong : ∀ {Γ₁ σ₁} {t₁ : Γ₁ ⊢ σ₁} {Γ₂ σ₂} {t₂ : Γ₂ ⊢ σ₂} →
             t₁ ≅-⊢ t₂ → sub t₁ ≅-⇨ sub t₂
  sub-cong P.refl = [ P.refl ]

  abstract

    -- Some lemmas relating variables to lifting.

    /∋-↑ : ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ▻ σ ∋ τ) (ρ : Sub T ρ̂) →
           x /∋ ρ ↑ ≅-⊢ x /∋ (wk-subst[ σ / ρ ] ρ ▻⇨ var · zero)
    /∋-↑ x ρ = /∋-cong (P.refl {x = [ x ]}) (unfold-↑ ρ)

    zero-/∋-↑ : ∀ {Γ Δ} σ {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) →
                zero[ σ ] /∋ ρ ↑ ≅-⊢ var · zero[ σ / ρ ]
    zero-/∋-↑ σ ρ = begin
      [ zero[ σ ] /∋ ρ ↑                        ]  ≡⟨ /∋-↑ zero[ σ ] ρ ⟩
      [ zero[ σ ] /∋ (wk-subst ρ ▻⇨ var · zero) ]  ≡⟨ P.refl ⟩
      [ var · zero                              ]  ∎

    suc-/∋-↑ : ∀ {Γ Δ τ} σ {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ τ) (ρ : Sub T ρ̂) →
               suc[ σ ] x /∋ ρ ↑ ≅-⊢ x /∋ wk-subst[ σ / ρ ] ρ
    suc-/∋-↑ σ x ρ = begin
      [ suc[ σ ] x /∋ ρ ↑                        ]  ≡⟨ /∋-↑ (suc[ σ ] x) ρ ⟩
      [ suc[ σ ] x /∋ (wk-subst ρ ▻⇨ var · zero) ]  ≡⟨ P.refl ⟩
      [ x /∋ wk-subst ρ                          ]  ∎

  -- One can weaken either before or after looking up a variable.
  -- (Note that this lemma holds definitionally, unlike the
  -- corresponding lemma in deBruijn.Substitution.Data.Simple.)

  /∋-wk-subst : ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ τ) (ρ : Sub T ρ̂) →
                x /∋ wk-subst[ σ ] ρ ≅-⊢ weaken[ σ ] · (x /∋ ρ)
  /∋-wk-subst x ρ = P.refl

  abstract

    -- A corollary.

    /∋-wk-subst-var :
      ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ}
      (ρ : Sub T ρ̂) (x : Γ ∋ τ) (y : Δ ∋ τ / ρ) →
      x /∋               ρ ≅-⊢ var ·          y →
      x /∋ wk-subst[ σ ] ρ ≅-⊢ var · suc[ σ ] y
    /∋-wk-subst-var ρ x y hyp = begin
      [ x /∋ wk-subst ρ    ]  ≡⟨ P.refl ⟩
      [ weaken · (x /∋ ρ)  ]  ≡⟨ weaken-cong P.refl hyp ⟩
      [ weaken · (var · y) ]  ≡⟨ weaken-var y ⟩
      [ var · suc y        ]  ∎

    -- The identity substitution has no effect.

    /-id : ∀ {Γ} (σ : Type Γ) → σ / id ≅-Type σ
    /-id σ = P.refl

    /⁺-id : ∀ {Γ} (Γ⁺ : Ctxt⁺ Γ) → Γ⁺ /⁺ id ≅-Ctxt⁺ Γ⁺
    /⁺-id Γ⁺ = begin
      [ Γ⁺ /⁺ id ]  ≡⟨ P.refl ⟩
      [ Γ⁺ /̂⁺ îd ]  ≡⟨ /̂⁺-îd Γ⁺ ⟩
      [ Γ⁺       ]  ∎

    /₊-id : ∀ {Γ} (Γ₊ : Ctxt₊ Γ) → Γ₊ /₊ id ≅-Ctxt₊ Γ₊
    /₊-id Γ₊ = begin
      [ Γ₊ /₊ id ]  ≡⟨ P.refl ⟩
      [ Γ₊ /̂₊ îd ]  ≡⟨ /̂₊-îd Γ₊ ⟩
      [ Γ₊       ]  ∎

    mutual

      /∋-id : ∀ {Γ σ} (x : Γ ∋ σ) → x /∋ id ≅-⊢ var · x
      /∋-id {Γ = ε}     ()
      /∋-id {Γ = Γ ▻ σ} x = begin
        [ x /∋ id ↑               ]  ≡⟨ /∋-↑ x id ⟩
        [ x /∋ (wk ▻⇨ var · zero) ]  ≡⟨ lemma x ⟩
        [ var · x                 ]  ∎
        where
        lemma : ∀ {τ} (x : Γ ▻ σ ∋ τ) →
                x /∋ (wk[ σ ] ▻⇨ var · zero) ≅-⊢ var · x
        lemma zero    = P.refl
        lemma (suc x) = /∋-wk x

      -- Weakening a variable is equivalent to incrementing it.

      /∋-wk : ∀ {Γ σ τ} (x : Γ ∋ τ) →
              x /∋ wk[ σ ] ≅-⊢ var · suc[ σ ] x
      /∋-wk x = /∋-wk-subst-var id x x (/∋-id x)

    -- The n-ary lifting of the identity substitution is the identity
    -- substitution.

    id-↑⁺ : ∀ {Γ} (Γ⁺ : Ctxt⁺ Γ) → id ↑⁺ Γ⁺ ≅-⇨ id[ Γ ++⁺ Γ⁺ ]
    id-↑⁺ ε        = id ∎-⟶
    id-↑⁺ (Γ⁺ ▻ σ) =
      (id ↑⁺ Γ⁺) ↑  ≅-⟶⟨ ↑-cong (id-↑⁺ Γ⁺) P.refl ⟩
      id ↑          ∎-⟶

    id-↑₊ : ∀ {Γ} (Γ₊ : Ctxt₊ Γ) → id ↑₊ Γ₊ ≅-⇨ id[ Γ ++₊ Γ₊ ]
    id-↑₊ ε        = id ∎-⟶
    id-↑₊ (σ ◅ Γ₊) =
      id ↑ ↑₊ Γ₊  ≅-⟶⟨ [ P.refl ] ⟩
      id   ↑₊ Γ₊  ≅-⟶⟨ id-↑₊ Γ₊ ⟩
      id          ∎-⟶

    -- The identity substitution has no effect even if lifted.

    /∋-id-↑⁺ : ∀ {Γ} Γ⁺ {σ} (x : Γ ++⁺ Γ⁺ ∋ σ) →
               x /∋ id ↑⁺ Γ⁺ ≅-⊢ var · x
    /∋-id-↑⁺ Γ⁺ x = begin
      [ x /∋ id ↑⁺ Γ⁺ ]  ≡⟨ /∋-cong (P.refl {x = [ x ]}) (id-↑⁺ Γ⁺) ⟩
      [ x /∋ id       ]  ≡⟨ /∋-id x ⟩
      [ var · x       ]  ∎

    /∋-id-↑₊ : ∀ {Γ} Γ₊ {σ} (x : Γ ++₊ Γ₊ ∋ σ) →
               x /∋ id ↑₊ Γ₊ ≅-⊢ var · x
    /∋-id-↑₊ Γ₊ x = begin
      [ x /∋ id ↑₊ Γ₊ ]  ≡⟨ /∋-cong (P.refl {x = [ x ]}) (id-↑₊ Γ₊) ⟩
      [ x /∋ id       ]  ≡⟨ /∋-id x ⟩
      [ var · x       ]  ∎

    -- If ρ is morally a renaming, then "deep application" of ρ to a
    -- variable is still a variable.

    /∋-↑⁺ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ}
            (ρ : Sub T ρ̂) (f : [ Var ⟶ Var ] ρ̂) →
            (∀ {σ} (x : Γ ∋ σ) → x /∋ ρ ≅-⊢ var · (f · x)) →
            ∀ Γ⁺ {σ} (x : Γ ++⁺ Γ⁺ ∋ σ) →
            x /∋ ρ ↑⁺ Γ⁺ ≅-⊢ var · (lift f Γ⁺ · x)
    /∋-↑⁺ ρ f hyp ε        x    = hyp x
    /∋-↑⁺ ρ f hyp (Γ⁺ ▻ σ) zero = begin
      [ zero[ σ ] /∋ (ρ ↑⁺ Γ⁺) ↑ ]  ≡⟨ zero-/∋-↑ σ (ρ ↑⁺ Γ⁺) ⟩
      [ var · zero               ]  ∎
    /∋-↑⁺ ρ f hyp (Γ⁺ ▻ σ) (suc x) = begin
      [ suc[ σ ] x /∋ (ρ ↑⁺ Γ⁺) ↑        ]  ≡⟨ suc-/∋-↑ σ x (ρ ↑⁺ Γ⁺) ⟩
      [ x /∋ wk-subst (ρ ↑⁺ Γ⁺)          ]  ≡⟨ P.refl ⟩
      [ weaken · (x /∋ ρ ↑⁺ Γ⁺)          ]  ≡⟨ weaken-cong P.refl (/∋-↑⁺ ρ f hyp Γ⁺ x) ⟩
      [ weaken · (var · (lift f Γ⁺ · x)) ]  ≡⟨ weaken-var (lift f Γ⁺ · x) ⟩
      [ var · suc (lift f Γ⁺ · x)        ]  ∎

    -- "Deep weakening" of a variable can be expressed without
    -- reference to the weaken function.

    /∋-wk-↑⁺ : ∀ {Γ σ} Γ⁺ {τ} (x : Γ ++⁺ Γ⁺ ∋ τ) →
               x /∋ wk[ σ ] ↑⁺ Γ⁺ ≅-⊢
               var · (lift weaken∋[ σ ] Γ⁺ · x)
    /∋-wk-↑⁺ = /∋-↑⁺ wk weaken∋ /∋-wk

    /∋-wk-↑⁺-↑⁺ : ∀ {Γ σ} Γ⁺ Γ⁺⁺ {τ} (x : Γ ++⁺ Γ⁺ ++⁺ Γ⁺⁺ ∋ τ) →
                  x /∋ wk[ σ ] ↑⁺ Γ⁺ ↑⁺ Γ⁺⁺ ≅-⊢
                  var · (lift (lift weaken∋[ σ ] Γ⁺) Γ⁺⁺ · x)
    /∋-wk-↑⁺-↑⁺ Γ⁺ = /∋-↑⁺ (wk ↑⁺ Γ⁺) (lift weaken∋ Γ⁺) (/∋-wk-↑⁺ Γ⁺)

    -- Two n-ary liftings can be merged into one.

    ↑⁺-⁺++⁺ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) Γ⁺ Γ⁺⁺ →
              ρ ↑⁺ (Γ⁺ ⁺++⁺ Γ⁺⁺) ≅-⇨ ρ ↑⁺ Γ⁺ ↑⁺ Γ⁺⁺
    ↑⁺-⁺++⁺ ρ Γ⁺ ε         = ρ ↑⁺ Γ⁺ ∎-⟶
    ↑⁺-⁺++⁺ ρ Γ⁺ (Γ⁺⁺ ▻ σ) =
      (ρ ↑⁺ (Γ⁺ ⁺++⁺ Γ⁺⁺)) ↑  ≅-⟶⟨ ↑-cong (↑⁺-⁺++⁺ ρ Γ⁺ Γ⁺⁺)
                                          (drop-subst-Type F.id (++⁺-++⁺ Γ⁺ Γ⁺⁺)) ⟩
      (ρ ↑⁺ Γ⁺ ↑⁺ Γ⁺⁺) ↑      ∎-⟶

    ↑₊-₊++₊ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) Γ₊ Γ₊₊ →
              ρ ↑₊ (Γ₊ ₊++₊ Γ₊₊) ≅-⇨ ρ ↑₊ Γ₊ ↑₊ Γ₊₊
    ↑₊-₊++₊ ρ ε        Γ₊₊ = ρ ↑₊ Γ₊₊ ∎-⟶
    ↑₊-₊++₊ ρ (σ ◅ Γ₊) Γ₊₊ =
      ρ ↑ ↑₊ (Γ₊ ₊++₊ Γ₊₊)  ≅-⟶⟨ ↑₊-₊++₊ (ρ ↑) Γ₊ Γ₊₊ ⟩
      ρ ↑ ↑₊ Γ₊ ↑₊ Γ₊₊      ∎-⟶


module Web.URI.Port where

open import Web.URI.Port.Primitive public using ( Port? ; :80 ; ε )


module Mystuff where

-- open import Axiom.Extensionality.Propositional as AEP
open import Categories.Category.Cartesian.Bundle
open import Categories.Category.CartesianClosed.Canonical
open import Categories.Category.Core
open import Categories.Category.Slice
-- open import Categories.Functor
open import Categories.Category.BinaryProducts
-- open import Categories.Morphism
open import Categories.Object.Exponential -- 𝒞 hiding (repack)
open import Data.Product
open import Function using (const)
open import Level
open import Relation.Binary.Core using (Rel)
open import Relation.Binary.PropositionalEquality
open Relation.Binary.PropositionalEquality.≡-Reasoning

private
  variable
    a b c d e : Level

-- so painful
_⋆_ : ∀ {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
      (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
      ((x : A) → C (g x))
f ⋆ g = λ x → f (g x)

simple : Category (suc zero) zero zero
simple =
 record
  -- structure
  { Obj = Set × Set
  ; _⇒_ = _⇒_
  ; _≈_ = _≡_
  ; id  = (λ z → z) , proj₁
  ; _∘_ = _∘_
  -- properties
  ; assoc     = refl
  ; sym-assoc = refl
  ; identityˡ  = refl
  ; identityʳ  = refl
  ; identity² = refl
  -- whew, they're all trivial!
  ; equiv = record { refl = refl ; sym = sym ; trans = trans }
  ; ∘-resp-≈ = ∘-resp
  }
  where
  _⇒_ : Rel (Set × Set) zero
  (i , x) ⇒ (j , y) = (i → j) × (x × i → y)
  _∘_ : {A B C : Set × Set} → B ⇒ C → A ⇒ B → A ⇒ C
  _∘_ {i , x} {j , y} {_} (u , f) (v , g) =
   (λ t → u (v t)) , λ t → f (g t , v (proj₂ t))
  ∘-resp :
    {A B C : Set × Set} {f h : B ⇒ C} {g i : A ⇒ B} →
    --------------------------------------------------
    f ≡ h → g ≡ i → (f ∘ g) ≡ (h ∘ i)
  ∘-resp {A} {B} {C} {f} {h} {g} {i} x y =
   trans (cong (λ t → t ∘ g) x) (cong (λ t → h ∘ t) y)

data t : Set where
 ⊤ : t

!-unique-lemma : ∀ (x : t) → ⊤ ≡ x
!-unique-lemma ⊤ = refl

postulate
 -- I'm lazy.
 respSetC : {A B C : Set} {f h : B → C} {g i : A → B} →
  f ≡ h →
  g ≡ i →
  (λ a → f (g a)) ≡ (λ a → h (i a))
 extensionality : ∀ {A B : Set} {f g : A → B} →
  (∀ (x : A) → f x ≡ g x) →
  f ≡ g

-- I need the category of Sets...
SetC : Category (suc zero) zero zero
SetC =
 record
  { Obj = Set
  ; _⇒_ = λ x y → x → y
  ; _≈_ = _≡_
  ; id = λ x → x
  ; _∘_ = λ f g a → f (g a)
  ; assoc = refl
  ; sym-assoc = refl
  ; identityˡ = refl
  ; identityʳ = refl
  ; identity² = refl
  ; equiv = record { refl = refl ; sym = sym ; trans = trans }
  ; ∘-resp-≈ = respSetC
  }

_·_ : {I : Set} {A B C : Set} → (B × I → C) → (A × I → B) → A × I → C
_·_ {I} f g (x , i) = f (g(x , i) , i)

fiber-of-simple : {I : Set} → Category (suc zero) zero zero
fiber-of-simple {I} =
 record
  { Obj = Set
  ; _⇒_ = λ X Y → X × I → Y
  ; _≈_ = _≡_
  ; id  = proj₁
  ; _∘_ = _·_ -- this is the Kleisli composition
  ; assoc     = refl
  ; sym-assoc = refl
  ; identityˡ  = refl
  ; identityʳ  = refl
  ; identity² = refl
  ; equiv = record { refl = refl ; sym = sym ; trans = trans }
  ; ∘-resp-≈ = rresp
  }
  where
  rresp : {A B C : Set} {f h : B × I → C} {g i : A × I → B} → f ≡ h → g ≡ i → (f · g) ≡ (h · i)
  rresp {A} {B} {C} {f} {h} {g} {i} x y = trans (cong (λ t → t · g) x) (cong (_·_ h) y)

-- each fiber of a simple fibration is cartesian
fiber-of-simple-cart : ∀ {I : Set} → CartesianCategory (suc zero) zero zero
fiber-of-simple-cart {I} =
 record
  { U = fiber-of-simple {I}
  ; cartesian =
    record
     { terminal =
       record { ⊤ = t
           ; ⊤-is-terminal =
             record
              { ! = const ⊤
              ; !-unique =
                λ f → extensionality (λ x → !-unique-lemma (f x))
              }
           }
     ; products =
       record
        { product = λ {A} {B} →
          record
           { A×B = A × B
           ; π₁ = λ x → proj₁ (proj₁ x)
           ; π₂ = λ x → proj₂ (proj₁ x)
           ; ⟨_,_⟩ = λ f g t → f t , g t
           ; project₁ = refl
           ; project₂ = refl
           ; unique = λ {refl refl → refl}
           } } } }

-- but also the total category is cartesian.
simple-cart : CartesianCategory (suc zero) zero zero
simple-cart = record
 { U = simple
 ; cartesian = record
   { terminal = record { ⊤ = t , t
                       ; ⊤-is-terminal =
                         record { ! = const ⊤ , const ⊤
                                ; !-unique = bang-uniq
                                } }
   ; products = record { product = λ {A} {B} → record
              { A×B = (proj₁ A × proj₁ B) , (proj₂ A × proj₂ B)
              ; π₁ = proj₁ , λ x → proj₁ (proj₁ x)
              ; π₂ = proj₂ , (λ x → proj₂ (proj₁ x))
              ; ⟨_,_⟩ = ⟨_,_⟩
              ; project₁ = refl
              ; project₂ = refl
              ; unique = λ {refl refl → refl}
              } } } }
              where
               bang-uniq :
                {A : Category.Obj simple}
                -------------------------
                (f : (simple Category.⇒ A) (t , t)) →
                --------------------------------------
                (simple Category.≈ (const ⊤ , const ⊤)) f
               bang-uniq {I , X} (u , k) =
                cong₂ Data.Product._,_
                 (extensionality (λ x → !-unique-lemma (u x)))
                 (extensionality (λ x → !-unique-lemma (k x)))
               ⟨_,_⟩ :
                {A B C : Set × Set} →
                (simple Category.⇒ C) A →
                (simple Category.⇒ C) B →
                (simple Category.⇒ C) ((proj₁ A × proj₁ B) , (proj₂ A × proj₂ B))
               ⟨_,_⟩ {A0 , A1} {B0 , B1} {C0 , C1} (u , h) (v , k) =
                (λ x → (u x) , (v x)) , λ x → (h x) , (k x)

fib-of-simple-ccc : {I : Set} → CartesianClosed (fiber-of-simple {I})
fib-of-simple-ccc {I} =
 record
  { ⊤ = t
  ; _×_ = _×_
  ; ! = λ x → ⊤
  ; π₁ = proj₁ ⋆ proj₁
  ; π₂ = proj₂ ⋆ proj₁
  ; ⟨_,_⟩ = λ f g ci → (f ci) , (g ci)
  ; !-unique = λ f → extensionality λ x → !-unique-lemma (f x)
  ; π₁-comp = refl
  ; π₂-comp = refl
  ; ⟨,⟩-unique = λ {refl refl → refl}
  ; _^_ = λ A B → B → A
  ; eval = evev
  ; curry = λ f ci a → f (((proj₁ ci) , a) , (proj₂ ci))
  ; eval-comp = refl
  ; curry-resp-≈ = λ {refl → refl}
  ; curry-unique = λ {refl → refl}
  }
  where
  evev : {B A : Category.Obj (fiber-of-simple {I})} → (fiber-of-simple {I} Category.⇒ ((A → B) × A)) B
  evev ((f , a) , i) = f a

{-
the arrow category has objects the morphisms of `Set` and
morphisms the commutative squares

A → B
↓   ↓
C → D
-}
arrow : Category (suc zero) zero zero
arrow = record
  { Obj = Σ (Set × Set) (λ x → proj₁ x → proj₂ x)
  ; _⇒_ = arr
  ; _≈_ = _≡_
  ; id = (λ z → z) , λ z → z
  ; _∘_ = λ {A} {B} {C} f g → comp {A} {B} {C} f g
  ; assoc = refl
  ; sym-assoc = refl
  ; identityˡ = refl
  ; identityʳ = refl
  ; identity² = refl
  ; equiv = record { refl = refl ; sym = sym ; trans = trans }
  ; ∘-resp-≈ = λ {refl refl → refl}
  }
  where
  arr : Rel (Σ (Set × Set) (λ x → proj₁ x → proj₂ x)) zero
  arr ((a , b) , x1) ((c , d) , y1) = (a → c) × (b → d)
  comp : {A B C : Σ (Set × Set) (λ x → proj₁ x → proj₂ x)} → arr B C → arr A B → arr A C
  comp {A} {B} {C} (f0 , f1) (g0 , g1) = (λ x → f0 (g0 x)) , λ x → f1 (g1 x)

arrow-ccc : CartesianClosed arrow
arrow-ccc = record
 { ⊤ = (t , t) , (λ _ → ⊤)
 ; _×_ = prod
 ; ! = (λ _ → ⊤) , (λ _ → ⊤)
 ; π₁ = proj₁ , proj₁
 ; π₂ = proj₂ , proj₂
 ; ⟨_,_⟩ = λ {A} {B} {C} f g → pair {A} {B} {C} f g
 ; !-unique = λ {A} → bang-uniq {A}
 ; π₁-comp = refl
 ; π₂-comp = refl
 ; ⟨,⟩-unique = λ {refl refl → refl}
 ; _^_ = to-the
 ; eval = λ {B} {A} → ev {B} {A}
 ; curry = λ {C} {A} {B} x → cur {C} {A} {B} x
 ; eval-comp = refl
 ; curry-resp-≈ = λ {refl → refl}
 ; curry-unique = {!   !}
 }
 where
 prod : Category.Obj arrow → Category.Obj arrow → Category.Obj arrow
 prod ((X , Y) , u) ((A , B) , v) =
  ((X × A) , (Y × B)) , λ x → (u (proj₁ x)) , (v (proj₂ x))
 pair : {C A B : Category.Obj arrow} →
  (arrow Category.⇒ C) A →
  (arrow Category.⇒ C) B →
  (arrow Category.⇒ C) (prod A B)
 pair {(X , Y) , u} {(A , B) , v} {(E , F) , w} (f0 , f1) (g0 , g1) =
  (λ x → (f0 x) , (g0 x)) , (λ x → (f1 x) , (g1 x))
 bang-uniq : {A : Category.Obj arrow} →
  (f : (arrow Category.⇒ A) ((t , t) , (λ _ → ⊤))) →
  ((λ _ → ⊤) , (λ _ → ⊤)) ≡ f
 bang-uniq (f0 , f1) =
  cong₂ _,_
   (extensionality λ x → !-unique-lemma (f0 x))
   (extensionality (λ x → !-unique-lemma (f1 x)))
 to-the : Category.Obj arrow →
  Category.Obj arrow →
  Category.Obj arrow
 to-the ((B0 , B1) , u) ((A0 , A1) , v) =
  (p , (A1 → B1)) , (λ x a1 → proj₂ (proj₁ x) a1)
   where
   p : Set
   p = Σ ((A0 → B0) × (A1 → B1)) (λ r → (λ x → u ((proj₁ r) x)) ≡ (λ x → (proj₂ r) (v x)))
 -- ^ it's the pullback-hom
 -- λ x → u (s x) ≡ λ x → t (v x)
 ev : {B A : Category.Obj arrow} → (arrow Category.⇒ prod (to-the B A) A) B
 ev {(B0 , B1) , u} {(A0 , A1)  , v} = dis , dat
  where
  dis : proj₁ (proj₁ (prod (to-the ((B0 , B1) , u) ((A0 , A1) , v)) ((A0 , A1) , v))) → B0
  dis ((d , p) , a0) = (proj₁ d) a0
  dat : proj₂ (proj₁ (prod (to-the ((B0 , B1) , u) ((A0 , A1) , v)) ((A0 , A1) , v))) → B1
  dat (fst , snd) = fst snd
 cur : {C A B : Category.Obj arrow} →
  (arrow Category.⇒ (prod C A)) B →
  (arrow Category.⇒ C) (to-the B A)
 cur {(C0 , C1) , u} {(A0 , A1) , v} {(B0 , B1) , w} (fst , snd) =
  (λ x → ((λ t → fst (x , t)) , λ t → snd (u x , t)) , extensionality (λ a0 → {!   !})) , (λ z z₁ → snd (z , z₁))


{-# OPTIONS --safe #-} -- implies --no-sized-types

module Issue3517.M where

open import Issue3517.S

f : (i : Size) (j : Size< i) → Size< j → Size< i
f i j k = k


postulate
  ℤ     : Set
  n     : ℤ
  -_ _! : ℤ → ℤ

-- Note that an unrelated prefix/postfix operator can be combined with
-- itself:

ok : ℤ
ok = n ! ! ! !

also-ok : ℤ
also-ok = - - - - - - - n


open import DeBruijn

infix 8 _*

_* : ∀ {n} → Term n → Term n
(# x) *       = # x
(ƛ M) *       = ƛ M *
((ƛ M) · N) * = M * [ N * ]
(L · N) *     = L * · N *


module _ where

open import utility
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import calculus
open import context-properties
open import Esterel.Lang.Binding


{-

This file contains:
  - Eliminators of direct limit, especially an index-shifting version;
  - Connectivity of inclusion maps.

-}
{-# OPTIONS --safe #-}
module Cubical.HITs.SequentialColimit.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function

open import Cubical.Data.Nat hiding (elim)
open import Cubical.HITs.SequentialColimit.Base
open import Cubical.Homotopy.Connected

private
  variable
    ℓ ℓ' : Level

module _
  (X : Sequence ℓ) where

  open Sequence

  private
    inl∞ : (n : ℕ) → X .space n → Lim→ X
    inl∞ n = inl {n = n}

  record ElimData (P : Lim→ X → Type ℓ') : Type (ℓ-max ℓ ℓ') where
    field
      finl  : {k : ℕ}(x : X .space k) → P (inl x)
      fpush : {k : ℕ}(x : X .space k) → PathP (λ i → P (push x i)) (finl x) (finl (X .map x))

  record ElimShiftData (n : ℕ)(P : Lim→ X → Type ℓ') : Type (ℓ-max ℓ ℓ') where
    field
      finl  : {k : ℕ}(x : X .space (k + n)) → P (inl x)
      fpush : {k : ℕ}(x : X .space (k + n)) → PathP (λ i → P (push x i)) (finl x) (finl (X .map x))

  open ElimData
  open ElimShiftData

  ElimData→ElimShiftData : (n : ℕ)(P : Lim→ X → Type ℓ')
    → ElimData P → ElimShiftData n P
  ElimData→ElimShiftData n P datum .finl  = datum .finl
  ElimData→ElimShiftData n P datum .fpush = datum .fpush

  -- Preliminary lemmas
  -- The difficulty is mainly due to natural numbers having no strict +-commutativity

  private
    alg-path : (a b : ℕ) → a + (1 + b) ≡ 1 + (a + b)
    alg-path a b = +-assoc a 1 b ∙ (λ i → +-comm a 1 i + b)

  module _
    (P : Lim→ X → Type ℓ')
    (datum : ElimShiftData 0 P) where

    +-zero-0 : refl ≡ +-zero 0
    +-zero-0 i j = isSet→SquareP (λ i j → isSetℕ) refl refl refl (+-zero 0) j i

    finl'-filler : (k : ℕ) → (i : I) → (x : X .space (+-zero k i)) → P (inl x)
    finl'-filler k i = transport-filler (λ i → (x : X .space (+-zero k i)) → P (inl x)) (datum .finl) i

    finl' : (k : ℕ) → (x : X .space k) → P (inl x)
    finl' k = finl'-filler k i1

    finl'-0-eq : datum .finl ≡ finl' 0
    finl'-0-eq = sym (transportRefl _)
      ∙ (λ j → transport (λ i → (x : X .space (+-zero-0 j i)) → P (inl x)) (datum .finl {k = 0}))

    fpush' : (k : ℕ)
      → (x : X .space k)
      → PathP (λ i → P (push x i)) (finl' k x) (finl' (1 + k) (X .map x))
    fpush' k = transport
      (λ i → (x : X .space (+-zero k i)) →
        PathP (λ i → P (push x i)) (finl'-filler k i x) (finl'-filler (1 + k) i (X .map x))) (datum .fpush)

    ElimShiftData0→ElimData : ElimData P
    ElimShiftData0→ElimData .finl  = finl'  _
    ElimShiftData0→ElimData .fpush = fpush' _

  module _
    (n : ℕ)(P : Lim→ X → Type ℓ')
    (datum : ElimShiftData (1 + n) P) where

    alg-path-0 : (b : ℕ) → refl ≡ alg-path 0 b
    alg-path-0 b i j = isSet→SquareP (λ i j → isSetℕ) refl refl refl (alg-path 0 b) j i

    finl-n-filler : (k : ℕ) → (i : I) → ((x : X .space (alg-path k n i)) → P (inl x))
    finl-n-filler k i = transport-filler (λ i → (x : X .space (alg-path k n i)) → P (inl x)) (datum .finl) i

    finl-n : (k : ℕ) → (x : X .space ((1 + k) + n)) → P (inl x)
    finl-n k = finl-n-filler k i1

    fpush-n : (k : ℕ)
      → (x : X .space ((1 + k) + n))
      → PathP (λ i → P (push x i)) (finl-n k x) (finl-n (1 + k) (X .map x))
    fpush-n k =
      transport
        (λ i → (x : X .space (alg-path k n i)) →
          PathP (λ i → P (push x i)) (finl-n-filler k i x) (finl-n-filler (1 + k) i (X .map x))) (datum .fpush)

    finl-0-filler : (x : X .space n) → (i : I) → P (push x i)
    finl-0-filler x i = transport-filler (λ i → P (push x (~ i))) (datum .finl {k = 0} (X .map x)) (~ i)

    finl-0 : (x : X .space n) → P (inl x)
    finl-0 x = finl-0-filler x i0

    finl-0-eq : datum .finl {k = 0} ≡ finl-n 0
    finl-0-eq = sym (transportRefl _)
      ∙ (λ j → transport (λ i → (x : X .space (alg-path-0 n j i)) → P (inl x)) (datum .finl {k = 0}))

    fpush-0 :
        (x : X .space n)
      → PathP (λ i → P (push x i)) (finl-0 x) (finl-n 0 (X .map x))
    fpush-0 x i =
      hcomp (λ j → λ
          { (i = i0) → finl-0 x
          ; (i = i1) → finl-0-eq j (X .map x) })
        (finl-0-filler x i)

    elimShiftDataSuc : ElimShiftData n P
    elimShiftDataSuc .finl  {k = 0} = finl-0
    elimShiftDataSuc .finl  {k = suc k} = finl-n k
    elimShiftDataSuc .fpush {k = 0} = fpush-0
    elimShiftDataSuc .fpush {k = suc k} = fpush-n k

  -- The eliminators

  elim :
      (P : Lim→ X → Type ℓ')
    → ElimData P
    → (x : Lim→ X) → P x
  elim P datum (inl x) = datum .finl x
  elim P datum (push x i) = datum .fpush x i

  elimShift : (n : ℕ)
    → (P : Lim→ X → Type ℓ')
    → ElimShiftData n P
    → (x : Lim→ X) → P x
  elimShift 0 _ datum = elim _ (ElimShiftData0→ElimData _ datum)
  elimShift (suc n) _ datum = elimShift n _ (elimShiftDataSuc _ _ datum)

  elimShiftβ : (n : ℕ)(k : ℕ)
    → (P : Lim→ X → Type ℓ')
    → (datum : ElimShiftData n P)
    → elimShift _ _ datum ∘ inl∞ (k + n) ≡ datum .finl
  elimShiftβ 0 0 _ datum = sym (finl'-0-eq _ datum)
  elimShiftβ 0 (suc k) P datum =
    transport (λ i → elimShift _ _ datum ∘ inl∞ (+-zero (suc k) (~ i))
      ≡ finl'-filler P datum (suc k) (~ i)) refl
  elimShiftβ (suc n) 0 _ datum =
      elimShiftβ n _ _ (elimShiftDataSuc _ _ datum)
    ∙ sym (finl-0-eq _ _ datum)
  elimShiftβ (suc n) (suc k) P datum =
    transport (λ i → elimShift _ _ datum ∘ inl∞ (alg-path (suc k) n (~ i))
      ≡ finl-n-filler n P datum (suc k) (~ i))
      (elimShiftβ n (suc (suc k)) P (elimShiftDataSuc _ _ datum))

  -- Lemma to lift sections

  open Iso

  private
    transpSec :
      (n : ℕ)(Y : Lim→ X → Type ℓ')
      (sec : (x : X .space n) → Y (inl x))
      → (x : X .space n) → Y (inl (X .map x))
    transpSec n Y sec x = transport (λ i → Y (push x i)) (sec x)

    module _
      (d : ℕ)(n : ℕ)
      (conn : isConnectedFun d (X .map {n = n}))
      (Y : Lim→ X → TypeOfHLevel ℓ' d) where

      module _
        (sec : (x : X .space n) → Y (inl (X .map x)) .fst) where

        lift-iso = elim.isIsoPrecompose _ d (Y ∘ inl) conn

        liftSec' : (x : X .space (1 + n)) → Y (inl x) .fst
        liftSec' = lift-iso .inv sec

        liftSecPath' : (x : X .space n) → sec x ≡ liftSec' (X .map x)
        liftSecPath' x i = lift-iso .rightInv sec (~ i) x

      module _
        (sec : (x : X .space n) → Y (inl x) .fst) where

        liftSec : (x : X .space (1 + n)) → Y (inl x) .fst
        liftSec = liftSec' (transpSec n (λ x → Y x .fst) sec)

        liftSecPath :
          (x : X .space n)
          → PathP (λ i → Y (push x i) .fst) (sec x) (liftSec (X .map x))
        liftSecPath x i =
          hcomp (λ j → λ
            { (i = i0) → sec x
            ; (i = i1) → liftSecPath'
                (transpSec n (λ x → Y x .fst) sec) x j })
          (transport-filler (λ i → Y (push x i) .fst) (sec x) i)

  module _
    (d : ℕ)(n : ℕ)
    (conn : (k : ℕ) → isConnectedFun d (X .map {n = k + n})) where

    private
      module _
        (Y : Lim→ X → TypeOfHLevel ℓ' d) where

        lifting : (k : ℕ)(sec : (x : X .space n) → Y (inl x) .fst)
          → (x : X .space (k + n)) → Y (inl x) .fst
        lifting 0 sec = sec
        lifting (suc k) sec = liftSec d _ (conn _) Y (lifting k sec)

        liftingPath : (k : ℕ)(sec : (x : X .space n) → Y (inl x) .fst)
          → (x : X .space (k + n))
          → PathP (λ i → Y (push x i) .fst) (lifting k sec x) (lifting (1 + k) sec (X .map x))
        liftingPath k sec = liftSecPath d _ (conn _) Y (lifting k sec)

        liftingData : ((x : X .space n) → Y (inl x) .fst) → ElimShiftData n (λ x → Y x .fst)
        liftingData sec .finl  = lifting _ sec
        liftingData sec .fpush = liftingPath _ sec

        hasSectionInl∘ : hasSection (λ (sec : (x : Lim→ X) → Y x .fst) → sec ∘ inl {n = n})
        hasSectionInl∘ .fst sec = elimShift  _ _   (liftingData sec)
        hasSectionInl∘ .snd sec = elimShiftβ _ _ _ (liftingData sec)

    -- Connectivity of inclusion map

    isConnectedInl∞ : isConnectedFun d (inl∞ n)
    isConnectedInl∞ = elim.isConnectedPrecompose _ _ hasSectionInl∘


open import Nat
open import Prelude
open import contexts
open import dynamics-core
open import type-assignment-unicity

module canonical-indeterminate-forms where

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at num type
  data cif-num : (Δ : hctx) (d : ihexp) → Set where
    CIFNPlus1 : ∀{Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ]
        ((d == d1 ·+ d2) ×
         (Δ , ∅ ⊢ d1 :: num) ×
         (Δ , ∅ ⊢ d2 :: num) ×
         (d1 indet) ×
         (d2 final)
        )
        → cif-num Δ d
    CIFNPlus2 : ∀{Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ]
        ((d == d1 ·+ d2) ×
         (Δ , ∅ ⊢ d1 :: num) ×
         (Δ , ∅ ⊢ d2 :: num) ×
         (d1 final) ×
         (d2 indet)
        )
        → cif-num Δ d
    CIFNAp : ∀{Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: τ2 ==> num) ×
         (Δ , ∅ ⊢ d2 :: τ2) ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
        → cif-num Δ d
    CIFNCase : ∀{Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ x ∈ Nat ] Σ[ d2 ∈ ihexp ] Σ[ y ∈ Nat ] Σ[ d3 ∈ ihexp ]
      Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ]
        ((d == case d1 x d2 y d3) ×
         (Δ , ∅ ⊢ d1 :: τ1 ⊕ τ2) ×
         (Δ , ■ (x , τ1) ⊢ d2 :: num) ×
         (Δ , ■ (y , τ2) ⊢ d3 :: num) ×
         (d1 indet) ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inl τ d') ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inr τ d') ×
         ((τ3 τ4 τ3' τ4' : htyp) (d' : ihexp) →
           d1 ≠ (d' ⟨(τ3 ⊕ τ4) ⇒ (τ3' ⊕ τ4')⟩))
        )
        → cif-num Δ d
    CIFNFst : ∀{Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == fst d') ×
         (Δ , ∅ ⊢ d' :: num ⊠ τ') ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-num Δ d
    CIFNSnd : ∀{Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == snd d') ×
         (Δ , ∅ ⊢ d' :: τ' ⊠ num) ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-num Δ d
    CIFNEHole : ∀{Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: num [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-num Δ d
    CIFNNEHole : ∀{Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: num [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-num Δ d
    CIFNCast : ∀{Δ d} →
      Σ[ d' ∈ ihexp ]
        ((d == d' ⟨ ⦇-⦈ ⇒ num ⟩) ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈) ×
         (d' indet) ×
         ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩))
        )
        → cif-num Δ d
    CIFNFailedCast : ∀{Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == d' ⟨ τ' ⇒⦇-⦈⇏ num ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (τ' ≠ num)
        )
        → cif-num Δ d

  canonical-indeterminate-forms-num : ∀{Δ d} →
                                      Δ , ∅ ⊢ d :: num →
                                      d indet →
                                      cif-num Δ d
  canonical-indeterminate-forms-num TANum ()
  canonical-indeterminate-forms-num (TAPlus wt wt₁) (IPlus1 x x₁) = CIFNPlus1 (_ , _ , refl , wt , wt₁ , x , x₁)
  canonical-indeterminate-forms-num (TAPlus wt wt₁) (IPlus2 x x₁) = CIFNPlus2 (_ , _  , refl , wt , wt₁ , x , x₁)
  canonical-indeterminate-forms-num (TAVar x₁) ()
  canonical-indeterminate-forms-num (TAAp wt wt₁) (IAp x ind x₁) = CIFNAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-num {Δ = Δ} (TACase {τ1 = τ1} {τ2 = τ2} {x = x} {d1 = d1} {y = y} {d2 = d2} wt _ wt₁ _ wt₂) (ICase ninl ninr ncast ind) = CIFNCase (_ , _ , _ , _ , _ , _ , _ , refl , wt , tr (λ Γ' → Δ , Γ' ⊢ d1 :: num) (extend-empty x τ1) wt₁ , tr (λ Γ' → Δ , Γ' ⊢ d2 :: num) (extend-empty y τ2) wt₂ , ind , ninl , ninr , ncast)
  canonical-indeterminate-forms-num (TAFst wt) (IFst x x₁ ind) = CIFNFst (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-num (TASnd wt) (ISnd x x₁ ind) = CIFNSnd (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-num (TAEHole x x₁) IEHole = CIFNEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-num (TANEHole x wt x₁) (INEHole x₂) = CIFNNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-num (TACast wt x) (ICastHoleGround x₁ ind x₂) = CIFNCast (_ , refl , wt , ind , x₁)
  canonical-indeterminate-forms-num (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = CIFNFailedCast (_ , _ , refl , x , x₅ , x₇)

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at arrow type
  data cif-arr : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where
    CIFAEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: (τ1 ==> τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-arr Δ d τ1 τ2
    CIFANEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: (τ1 ==> τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-arr Δ d τ1 τ2
    CIFAAp : ∀{d Δ τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2' ∈ htyp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: τ2' ==> (τ1 ==> τ2)) ×
         (Δ , ∅ ⊢ d2 :: τ2') ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFACase : ∀{Δ d τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ x ∈ Nat ] Σ[ d2 ∈ ihexp ] Σ[ y ∈ Nat ] Σ[ d3 ∈ ihexp ]
      Σ[ τ3 ∈ htyp ] Σ[ τ4 ∈ htyp ]
        ((d == case d1 x d2 y d3) ×
         (Δ , ∅ ⊢ d1 :: τ3 ⊕ τ4) ×
         (Δ , ■ (x , τ3) ⊢ d2 :: τ1 ==> τ2) ×
         (Δ , ■ (y , τ4) ⊢ d3 :: τ1 ==> τ2) ×
         (d1 indet) ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inl τ d') ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inr τ d') ×
         ((τ5 τ6 τ5' τ6' : htyp) (d' : ihexp) →
           d1 ≠ (d' ⟨(τ5 ⊕ τ6) ⇒ (τ5' ⊕ τ6')⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFAFst : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == fst d') ×
         (Δ , ∅ ⊢ d' :: (τ1 ==> τ2) ⊠ τ') ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFASnd : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == snd d') ×
         (Δ , ∅ ⊢ d' :: τ' ⊠ (τ1 ==> τ2)) ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFACast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ]
        ((d == d' ⟨ (τ1' ==> τ2') ⇒ (τ1 ==> τ2) ⟩) ×
         (Δ , ∅ ⊢ d' :: τ1' ==> τ2') ×
         (d' indet) ×
         ((τ1' ==> τ2') ≠ (τ1 ==> τ2))
        )
       → cif-arr Δ d τ1 τ2
    CIFACastHole : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ]
        ((d == (d' ⟨ ⦇-⦈ ⇒ ⦇-⦈ ==> ⦇-⦈ ⟩)) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈) ×
         (d' indet) ×
         ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFAFailedCast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == (d' ⟨ τ' ⇒⦇-⦈⇏ ⦇-⦈ ==> ⦇-⦈ ⟩) ) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (τ' ≠ (⦇-⦈ ==> ⦇-⦈))
        )
        → cif-arr Δ d τ1 τ2

  canonical-indeterminate-forms-arr : ∀{Δ d τ1 τ2 } →
                                      Δ , ∅ ⊢ d :: (τ1 ==> τ2) →
                                      d indet →
                                      cif-arr Δ d τ1 τ2
  canonical-indeterminate-forms-arr (TAVar x₁) ()
  canonical-indeterminate-forms-arr (TALam _ wt) ()
  canonical-indeterminate-forms-arr (TAAp wt wt₁) (IAp x ind x₁) = CIFAAp (_ , _ , _ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-arr {Δ = Δ} (TACase {τ1 = τ1} {τ2 = τ2} {τ = τ3 ==> τ4} {x = x} {d1 = d1} {y = y} {d2 = d2} wt _ wt₁ _ wt₂) (ICase ninl ninr ncast ind) = CIFACase (_ , _ , _ , _ , _ , _ , _ , refl , wt , tr (λ Γ' → Δ , Γ' ⊢ d1 :: τ3 ==> τ4) (extend-empty x τ1) wt₁ , tr (λ Γ' → Δ , Γ' ⊢ d2 :: τ3 ==> τ4) (extend-empty y τ2) wt₂ , ind , ninl , ninr , ncast)
  canonical-indeterminate-forms-arr (TAFst wt) (IFst x x₁ ind) = CIFAFst (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-arr (TASnd wt) (ISnd x x₁ ind) = CIFASnd (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-arr (TAEHole x x₁) IEHole = CIFAEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-arr (TANEHole x wt x₁) (INEHole x₂) = CIFANEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-arr (TACast wt x) (ICastArr x₁ ind) = CIFACast (_ , _ , _ , _ , _ , refl , wt , ind , x₁)
  canonical-indeterminate-forms-arr (TACast wt TCHole2) (ICastHoleGround x₁ ind GArrHole) = CIFACastHole (_ , refl , refl , refl , wt , ind , x₁)
  canonical-indeterminate-forms-arr (TAFailedCast x x₁ GArrHole x₃) (IFailedCast x₄ x₅ GArrHole x₇) = CIFAFailedCast (_ , _ , refl , refl , refl , x , x₅ , x₇)

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at sum type
  data cif-sum : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where
    CIFSEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: (τ1 ⊕ τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-sum Δ d τ1 τ2
    CIFSNEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: (τ1 ⊕ τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-sum Δ d τ1 τ2
    CIFSAp : ∀{d Δ τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2' ∈ htyp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: τ2' ==> (τ1 ⊕ τ2)) ×
         (Δ , ∅ ⊢ d2 :: τ2') ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
        → cif-sum Δ d τ1 τ2
    CIFSInl : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ]
        ((d == inl τ2 d') ×
         (Δ , ∅ ⊢ d' :: τ1) ×
         (d' indet)
        )
        → cif-sum Δ d τ1 τ2
    CIFSInr : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ]
        ((d == inr τ1 d') ×
         (Δ , ∅ ⊢ d' :: τ2) ×
         (d' indet)
        )
        → cif-sum Δ d τ1 τ2
    CIFSCase : ∀{Δ d τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ x ∈ Nat ] Σ[ d2 ∈ ihexp ] Σ[ y ∈ Nat ] Σ[ d3 ∈ ihexp ]
      Σ[ τ3 ∈ htyp ] Σ[ τ4 ∈ htyp ]
        ((d == case d1 x d2 y d3) ×
         (Δ , ∅ ⊢ d1 :: τ3 ⊕ τ4) ×
         (Δ , ■ (x , τ3) ⊢ d2 :: τ1 ⊕ τ2) ×
         (Δ , ■ (y , τ4) ⊢ d3 :: τ1 ⊕ τ2) ×
         (d1 indet) ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inl τ d') ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inr τ d') ×
         ((τ5 τ6 τ5' τ6' : htyp) (d' : ihexp) →
           d1 ≠ (d' ⟨(τ5 ⊕ τ6) ⇒ (τ5' ⊕ τ6')⟩))
        )
        → cif-sum Δ d τ1 τ2
    CIFSFst : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == fst d') ×
         (Δ , ∅ ⊢ d' :: (τ1 ⊕ τ2) ⊠ τ') ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-sum Δ d τ1 τ2
    CIFSSnd : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == snd d') ×
         (Δ , ∅ ⊢ d' :: τ' ⊠ (τ1 ⊕ τ2)) ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-sum Δ d τ1 τ2
    CIFSCast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ]
        ((d == d' ⟨ (τ1' ⊕ τ2') ⇒ (τ1 ⊕ τ2) ⟩) ×
         (Δ , ∅ ⊢ d' :: τ1' ⊕ τ2') ×
         (d' indet) ×
         ((τ1' ⊕ τ2') ≠ (τ1 ⊕ τ2))
        )
       → cif-sum Δ d τ1 τ2
    CIFSCastHole : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ]
        ((d == (d' ⟨ ⦇-⦈ ⇒ ⦇-⦈ ⊕ ⦇-⦈ ⟩)) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈) ×
         (d' indet) ×
         ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩))
        )
        → cif-sum Δ d τ1 τ2
    CIFSFailedCast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == (d' ⟨ τ' ⇒⦇-⦈⇏ ⦇-⦈ ⊕ ⦇-⦈ ⟩) ) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (τ' ≠ (⦇-⦈ ⊕ ⦇-⦈))
        )
        → cif-sum Δ d τ1 τ2

  canonical-indeterminate-forms-sum : ∀{Δ d τ1 τ2 } →
                                      Δ , ∅ ⊢ d :: (τ1 ⊕ τ2) →
                                      d indet →
                                      cif-sum Δ d τ1 τ2
  canonical-indeterminate-forms-sum (TAAp wt wt₁) (IAp x ind x₁) = CIFSAp (_ , _ , _ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-sum (TAInl wt) (IInl ind) = CIFSInl (_ , refl , wt , ind)
  canonical-indeterminate-forms-sum (TAInr wt) (IInr ind) = CIFSInr (_ , refl , wt , ind)
  canonical-indeterminate-forms-sum {Δ = Δ} (TACase {τ1 = τ1} {τ2 = τ2} {τ = τ3 ⊕ τ4} {x = x} {d1 = d1} {y = y} {d2 = d2} wt _ wt₁ _ wt₂) (ICase ninl ninr ncast ind) = CIFSCase (_ , _ , _ , _ , _ , _ , _ , refl , wt , tr (λ Γ' → Δ , Γ' ⊢ d1 :: (τ3 ⊕ τ4)) (extend-empty x τ1) wt₁ , tr (λ Γ' → Δ , Γ' ⊢ d2 :: (τ3 ⊕ τ4)) (extend-empty y τ2) wt₂ , ind , ninl , ninr , ncast)
  canonical-indeterminate-forms-sum (TAFst wt) (IFst x x₁ ind) = CIFSFst (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-sum (TASnd wt) (ISnd x x₁ ind) = CIFSSnd (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-sum (TAEHole x x₁) IEHole = CIFSEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-sum (TANEHole x wt x₁) (INEHole x₂) = CIFSNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-sum (TACast wt x) (ICastSum x₁ ind) = CIFSCast (_ , _ , _ , _ , _ , refl , wt , ind , x₁)
  canonical-indeterminate-forms-sum (TACast wt x) (ICastHoleGround x₁ ind GSumHole) = CIFSCastHole (_ , refl , refl , refl , wt , ind , x₁)
  canonical-indeterminate-forms-sum (TAFailedCast wt x x₁ x₂) (IFailedCast x₃ x₄ GSumHole x₆) = CIFSFailedCast (_ , _ , refl , refl , refl , wt , x₄ , x₆)
  canonical-indeterminate-forms-sum (TAVar x) ()

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at product type
  data cif-prod : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where
    CIFPEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: (τ1 ⊠ τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-prod Δ d τ1 τ2
    CIFPNEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: (τ1 ⊠ τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-prod Δ d τ1 τ2
    CIFPAp : ∀{d Δ τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2' ∈ htyp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: τ2' ==> (τ1 ⊠ τ2)) ×
         (Δ , ∅ ⊢ d2 :: τ2') ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
        → cif-prod Δ d τ1 τ2
    CIFPCase : ∀{Δ d τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ x ∈ Nat ] Σ[ d2 ∈ ihexp ] Σ[ y ∈ Nat ] Σ[ d3 ∈ ihexp ]
      Σ[ τ3 ∈ htyp ] Σ[ τ4 ∈ htyp ]
        ((d == case d1 x d2 y d3) ×
         (Δ , ∅ ⊢ d1 :: τ3 ⊕ τ4) ×
         (Δ , ■ (x , τ3) ⊢ d2 :: τ1 ⊠ τ2) ×
         (Δ , ■ (y , τ4) ⊢ d3 :: τ1 ⊠ τ2) ×
         (d1 indet) ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inl τ d') ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inr τ d') ×
         ((τ5 τ6 τ5' τ6' : htyp) (d' : ihexp) →
           d1 ≠ (d' ⟨(τ5 ⊕ τ6) ⇒ (τ5' ⊕ τ6')⟩))
        )
        → cif-prod Δ d τ1 τ2
    CIFPPair1 : ∀{Δ d τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ]
        ((d == ⟨ d1 , d2 ⟩) ×
         (Δ , ∅ ⊢ d1 :: τ1) ×
         (Δ , ∅ ⊢ d2 :: τ2) ×
         d1 indet ×
         d2 final
        )
        → cif-prod Δ d τ1 τ2
    CIFPPair2 : ∀{Δ d τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ]
        ((d == ⟨ d1 , d2 ⟩) ×
         (Δ , ∅ ⊢ d1 :: τ1) ×
         (Δ , ∅ ⊢ d2 :: τ2) ×
         d1 final ×
         d2 indet
        )
        → cif-prod Δ d τ1 τ2
    CIFPFst : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == fst d') ×
         (Δ , ∅ ⊢ d' :: (τ1 ⊠ τ2) ⊠ τ') ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-prod Δ d τ1 τ2
    CIFPSnd : ∀{Δ d τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == snd d') ×
         (Δ , ∅ ⊢ d' :: τ' ⊠ (τ1 ⊠ τ2)) ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-prod Δ d τ1 τ2
    CIFPCast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ]
        ((d == d' ⟨ (τ1' ⊠ τ2') ⇒ (τ1 ⊠ τ2) ⟩) ×
         (Δ , ∅ ⊢ d' :: τ1' ⊠ τ2') ×
         (d' indet) ×
         ((τ1' ⊠ τ2') ≠ (τ1 ⊠ τ2))
        )
       → cif-prod Δ d τ1 τ2
    CIFPCastHole : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ]
        ((d == (d' ⟨ ⦇-⦈ ⇒ ⦇-⦈ ⊠ ⦇-⦈ ⟩)) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈) ×
         (d' indet) ×
         ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩))
        )
        → cif-prod Δ d τ1 τ2
    CIFPFailedCast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == (d' ⟨ τ' ⇒⦇-⦈⇏ ⦇-⦈ ⊠ ⦇-⦈ ⟩) ) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (τ' ≠ (⦇-⦈ ⊠ ⦇-⦈))
        )
        → cif-prod Δ d τ1 τ2

  canonical-indeterminate-forms-prod : ∀{Δ d τ1 τ2} →
                                       Δ , ∅ ⊢ d :: (τ1 ⊠ τ2) →
                                       d indet →
                                       cif-prod Δ d τ1 τ2
  canonical-indeterminate-forms-prod (TAVar x) ()
  canonical-indeterminate-forms-prod (TAAp wt wt₁) (IAp x ind x₁) = CIFPAp (_ , _ , _ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-prod {Δ = Δ} (TACase {τ1 = τ1} {τ2 = τ2} {τ = τ3 ⊠ τ4} {x = x} {d1 = d1} {y = y} {d2 = d2} wt _ wt₁ _ wt₂) (ICase ninl ninr ncast ind) = CIFPCase (_ , _ , _ , _ , _ , _ , _ , refl , wt , tr (λ Γ' → Δ , Γ' ⊢ d1 :: (τ3 ⊠ τ4)) (extend-empty x τ1) wt₁ , tr (λ Γ' → Δ , Γ' ⊢ d2 :: (τ3 ⊠ τ4)) (extend-empty y τ2) wt₂ , ind , ninl , ninr , ncast)
  canonical-indeterminate-forms-prod (TAPair wt wt₁) (IPair1 ind x) = CIFPPair1 (_ , _ , refl , wt , wt₁ , ind , x)
  canonical-indeterminate-forms-prod (TAPair wt wt₁) (IPair2 x ind) = CIFPPair2 (_ , _ , refl , wt , wt₁ , x , ind)
  canonical-indeterminate-forms-prod (TAFst wt) (IFst x x₁ ind) = CIFPFst (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-prod (TASnd wt) (ISnd x x₁ ind) = CIFPSnd (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-prod (TAEHole x x₁) IEHole = CIFPEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-prod (TANEHole x wt x₁) (INEHole x₂) = CIFPNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-prod (TACast wt x) (ICastProd x₁ ind) = CIFPCast (_ , _ , _ , _ , _ , refl , wt , ind , x₁)
  canonical-indeterminate-forms-prod (TACast wt x) (ICastHoleGround x₁ ind GProdHole) = CIFPCastHole (_ , refl , refl , refl , wt , ind , x₁)
  canonical-indeterminate-forms-prod (TAFailedCast wt x GProdHole x₂) (IFailedCast x₃ x₄ GProdHole x₆) = CIFPFailedCast (_ , _ , refl , refl , refl , wt , x₄ , x₆)

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at hole type
  data cif-hole : (Δ : hctx) (d : ihexp) → Set where
    CIFHEHole : ∀{Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: ⦇-⦈ [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-hole Δ d
    CIFHNEHole : ∀{Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: ⦇-⦈ [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-hole Δ d
    CIFHAp : ∀{Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: (τ2 ==> ⦇-⦈)) ×
         (Δ , ∅ ⊢ d2 :: τ2) ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
      → cif-hole Δ d
    CIFHCase : ∀{Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ x ∈ Nat ] Σ[ d2 ∈ ihexp ] Σ[ y ∈ Nat ] Σ[ d3 ∈ ihexp ]
      Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ]
        ((d == case d1 x d2 y d3) ×
         (Δ , ∅ ⊢ d1 :: τ1 ⊕ τ2) ×
         (Δ , ■ (x , τ1) ⊢ d2 :: ⦇-⦈) ×
         (Δ , ■ (y , τ2) ⊢ d3 :: ⦇-⦈) ×
         (d1 indet) ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inl τ d') ×
         ((τ : htyp) (d' : ihexp) → d1 ≠ inr τ d') ×
         ((τ3 τ4 τ3' τ4' : htyp) (d' : ihexp) →
           d1 ≠ (d' ⟨(τ3 ⊕ τ4) ⇒ (τ3' ⊕ τ4')⟩))
        )
        → cif-hole Δ d
    CIFHFst : ∀{Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == fst d') ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈ ⊠ τ') ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-hole Δ d
    CIFHSnd : ∀{Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == snd d') ×
         (Δ , ∅ ⊢ d' :: τ' ⊠ ⦇-⦈) ×
         (d' indet) ×
         ((d1 d2 : ihexp) → d' ≠ ⟨ d1 , d2 ⟩) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d'' : ihexp) →
           d' ≠ (d'' ⟨(τ3 ⊠ τ4) ⇒ (τ3' ⊠ τ4')⟩))
        )
        → cif-hole Δ d
    CIFHCast : ∀{Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == d' ⟨ τ' ⇒ ⦇-⦈ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (d' indet)
        )
      → cif-hole Δ d

  canonical-indeterminate-forms-hole : ∀{Δ d} →
                                       Δ , ∅ ⊢ d :: ⦇-⦈ →
                                       d indet →
                                       cif-hole Δ d
  canonical-indeterminate-forms-hole (TAVar x₁) ()
  canonical-indeterminate-forms-hole (TAAp wt wt₁) (IAp x ind x₁) = CIFHAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-hole {Δ = Δ} (TACase {τ1 = τ1} {τ2 = τ2} {x = x} {d1 = d1} {y = y} {d2 = d2} wt _ wt₁ _ wt₂) (ICase ninl ninr ncast ind) = CIFHCase (_ , _ , _ , _ , _ , _ , _ , refl , wt , tr (λ Γ' → Δ , Γ' ⊢ d1 :: ⦇-⦈) (extend-empty x τ1) wt₁ , tr (λ Γ' → Δ , Γ' ⊢ d2 :: ⦇-⦈) (extend-empty y τ2) wt₂ , ind , ninl , ninr , ncast)
  canonical-indeterminate-forms-hole (TAFst wt) (IFst x x₁ ind) = CIFHFst (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-hole (TASnd wt) (ISnd x x₁ ind) = CIFHSnd (_ , _ , refl , wt , ind , x , x₁)
  canonical-indeterminate-forms-hole (TAEHole x x₁) IEHole = CIFHEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-hole (TANEHole x wt x₁) (INEHole x₂) = CIFHNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-hole (TACast wt x) (ICastGroundHole x₁ ind) = CIFHCast (_ , _ , refl , wt , x₁ , ind)
  canonical-indeterminate-forms-hole (TACast wt x) (ICastHoleGround x₁ ind ())
  canonical-indeterminate-forms-hole (TAFailedCast x x₁ () x₃) (IFailedCast x₄ x₅ x₆ x₇)

  canonical-indeterminate-forms-coverage : ∀{Δ d τ} →
                                           Δ , ∅ ⊢ d :: τ →
                                           d indet →
                                           τ ≠ num →
                                           ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) →
                                           ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ⊕ τ2)) →
                                           ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ⊠ τ2)) →
                                           τ ≠ ⦇-⦈ →
                                           ⊥
  canonical-indeterminate-forms-coverage {τ = num} wt ind nn na ns np nh = nn refl
  canonical-indeterminate-forms-coverage {τ = ⦇-⦈} wt ind nn na ns np nh = nh refl
  canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} wt ind nn na ns np nh = na τ τ₁ refl
  canonical-indeterminate-forms-coverage {τ = τ ⊕ τ₁} wt ind nn na ns np nh = ns τ τ₁ refl
  canonical-indeterminate-forms-coverage {τ = τ ⊠ τ₁} wt ind nn na ns np nh = np τ τ₁ refl