diff --git a/.gitignore b/.gitignore index 171a389..dd81004 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,4 @@ *.agdai +debruijn/no-positivity-core-type.agda +debruijn/no-positivity-core-exp.agda +debruijn/no-positivity-core.agda \ No newline at end of file diff --git a/Dockerfile b/Dockerfile index a7010c0..ba24418 100644 --- a/Dockerfile +++ b/Dockerfile @@ -3,5 +3,6 @@ run cabal update run cabal install alex run cabal install happy run cabal install Agda-2.5.4.2 +# Warning: Agda version may be out of date copy . . cmd ["agda" , "-v", "2" , "all.agda"] diff --git a/Nat.agda b/Nat.agda index 28d1b4b..2539e6d 100644 --- a/Nat.agda +++ b/Nat.agda @@ -22,3 +22,115 @@ module Nat where natEQ (1+ x) (1+ y) with natEQ x y natEQ (1+ x) (1+ .x) | Inl refl = Inl refl ... | Inr b = Inr (λ x₁ → b (1+inj x y x₁)) + + natEQrefl : {x : Nat} -> natEQ x x == Inl refl + natEQrefl {x} with natEQ x x + ... | Inl refl = refl + ... | Inr neq = abort (neq refl) + + natEQneq : {x y : Nat} -> (neq : ((x == y) → ⊥)) -> natEQ x y == Inr neq + natEQneq {x} {y} neq with natEQ x y + ... | Inl refl = abort (neq refl) + ... | Inr neq' = inr-inj (funext (λ eq → abort (neq eq))) + where + inr-inj : ∀{a a'} -> a == a' -> Inr a == Inr a' + inr-inj eq rewrite eq = refl + + data _<_ : Nat → Nat → Set where + LTZ : ∀{n} -> Z < 1+ n + LTS : ∀{n m} -> n < m -> 1+ n < 1+ m + + natLT : (n m : Nat) -> ((n < m) + ¬(n < m)) + natLT Z Z = Inr (λ ()) + natLT Z (1+ n) = Inl LTZ + natLT (1+ n) Z = Inr (λ ()) + natLT (1+ n) (1+ m) with natLT n m + ... | Inl p = Inl (LTS p) + ... | Inr p = Inr (\{(LTS p') -> p p'}) + + lt-1+ : {x : Nat} -> x < 1+ x + lt-1+ {Z} = LTZ + lt-1+ {1+ x'} = LTS lt-1+ + + lt-ne : {x y : Nat} -> x < y -> (x == y) → ⊥ + lt-ne LTZ = \ () + lt-ne (LTS {n} {m} p) = \eq -> lt-ne p ((1+inj n m eq)) + + lt-antisym : {x y : Nat} -> x < y -> y < x -> ⊥ + lt-antisym LTZ = λ () + lt-antisym (LTS p) (LTS p') = lt-antisym p p' + + lt-gtz : {x y : Nat} -> y < x -> Σ[ z ∈ Nat ] (x == 1+ z) + lt-gtz (LTZ {n}) = n , refl + lt-gtz (LTS {n} {m} p) = let p1 , p2 = lt-gtz p in 1+ p1 , foo p2 + where + foo : {x y : Nat} -> x == y -> 1+ x == 1+ y + foo eq rewrite eq = refl + + lt-1+-inj : {x y : Nat} -> 1+ x < 1+ y -> x < y + lt-1+-inj (LTS p) = p + + lt-trans-1+ : {x y z : Nat} -> x < y -> y < z -> 1+ x < z + lt-trans-1+ LTZ (LTS LTZ) = LTS LTZ + lt-trans-1+ LTZ (LTS (LTS p)) = LTS LTZ + lt-trans-1+ (LTS p) (LTS p') = LTS (lt-trans-1+ p p') + + lt-right-incr : {x y : Nat} -> x < y -> x < 1+ y + lt-right-incr LTZ = LTZ + lt-right-incr (LTS p) = LTS (lt-right-incr p) + + lt-trans : {x y z : Nat} -> x < y -> y < z -> x < z + lt-trans LTZ (LTS p) = LTZ + lt-trans (LTS p) (LTS p') = lt-right-incr (lt-trans-1+ p p') + + lt-right-incr-neq : {x y : Nat} -> x < 1+ y -> ((x == y) -> ⊥) -> x < y + lt-right-incr-neq {y = 0} LTZ d = abort (d refl) + lt-right-incr-neq {y = (1+ y')} LTZ d = LTZ + lt-right-incr-neq {y = 0} (LTS ()) d + lt-right-incr-neq {x = (1+ x')} {y = (1+ y')} (LTS a) d = LTS (lt-right-incr-neq {x = x'} {y = y'} a λ x → d (foo x)) + where + foo : {a b : Nat} -> a == b -> (1+ a) == (1+ b) + foo eq rewrite eq = refl + + lt-lte-is-lt : {a b c : Nat} -> (a < b) -> (b < (1+ c)) -> (a < c) + lt-lte-is-lt {a = Z} {c = Z} lt LTZ = lt + lt-lte-is-lt {a = Z} {c = Z} lt (LTS ()) + lt-lte-is-lt {a = Z} {c = 1+ c} lt lte = LTZ + lt-lte-is-lt {a = 1+ a} {c = Z} lt LTZ = lt + lt-lte-is-lt {a = 1+ a} {c = Z} lt (LTS ()) + lt-lte-is-lt {a = 1+ a} {b = 1+ b} {c = 1+ c} (LTS lt) (LTS lte) = LTS (lt-lte-is-lt lt lte) + + trichotomy : (a b : Nat) -> (a < b + b < a + a == b) + trichotomy Z Z = Inr (Inr refl) + trichotomy (1+ a) Z = Inr (Inl LTZ) + trichotomy Z (1+ b) = Inl LTZ + trichotomy (1+ a) (1+ b) with trichotomy a b + ... | Inl x = Inl (LTS x) + ... | Inr (Inl x) = Inr (Inl (LTS x)) + ... | Inr (Inr x) rewrite x = Inr (Inr refl) + + trichotomy-lemma : {a b : Nat} -> (a == b → ⊥) -> (a < b → ⊥) -> (b < a) + trichotomy-lemma {a = a} {b = b} neq nlt with trichotomy a b + ... | Inl x = abort (nlt x) + ... | Inr (Inl x) = x + ... | Inr (Inr x) = abort (neq x) + + _nat+_ : (n m : Nat) → Nat + Z nat+ n = n + (1+ n) nat+ m = 1+ (n nat+ m) + + nat+Z : (n : Nat) → n nat+ Z == n + nat+Z Z = refl + nat+Z (1+ n) rewrite nat+Z n = refl + + nat+1+ : (n m : Nat) → n nat+ 1+ m == 1+ (n nat+ m) + nat+1+ Z m = refl + nat+1+ (1+ n) m rewrite nat+1+ n m = refl + + nat+assoc : (n m l : Nat) → n nat+ (m nat+ l) == (n nat+ m) nat+ l + nat+assoc Z m l = refl + nat+assoc (1+ n) m l rewrite nat+assoc n m l = refl + + nat+comm : (n m : Nat) → n nat+ m == m nat+ n + nat+comm Z m rewrite nat+Z m = refl + nat+comm (1+ n) m rewrite nat+1+ m n rewrite nat+comm n m = refl \ No newline at end of file diff --git a/Prelude.agda b/Prelude.agda index 69572b8..7233f5c 100644 --- a/Prelude.agda +++ b/Prelude.agda @@ -8,6 +8,11 @@ module Prelude where abort : ∀ {C : Set} → ⊥ → C abort () + -- negation + open import Agda.Primitive using (Level) + ¬_ : ∀ {ℓ : Level} → Set ℓ → Set ℓ + ¬ A = A → ⊥ + -- unit data ⊤ : Set where <> : ⊤ @@ -43,7 +48,7 @@ module Prelude where -- disequality _≠_ : {l : Level} {A : Set l} → (a b : A) → Set l - a ≠ b = (a == b) → ⊥ + a ≠ b = ¬ (a == b) {-# BUILTIN EQUALITY _==_ #-} @@ -91,3 +96,11 @@ module Prelude where -- non-equality is commutative flip : {A : Set} {x y : A} → (x == y → ⊥) → (y == x → ⊥) flip neq eq = neq (! eq) + + -- equality is symmetric + sym : {A : Set} {x y : A} → (x == y) → (y == x) + sym refl = refl + + -- bi-implication + _↔_ : {l1 : Level} {l2 : Level} → (Set l1) → (Set l2) → Set (lmax l1 l2) + a ↔ b = (a → b) × (b → a) diff --git a/README.md b/README.md index 2e6de4f..7d404be 100644 --- a/README.md +++ b/README.md @@ -1,354 +1,39 @@ -# hazelnut-dynamics-agda -This repository is the mechanization of the work described in our -[POPL19 paper](https://arxiv.org/pdf/1805.00155). It includes all of the -definitions and proofs from Section 3, as claimed in Sec. 3.4 (Agda -Mechanization). +# hazelnut-polymorphism-agda +This repository is the De Bruijn version of the mechanization of the work described in our TFP24 paper. -# How To Check These Proofs +# Where To Find Each Theorm -These proofs are known to check under `Agda 2.6.2`. The most direct, if -not the easiest, option to check the proofs is to install that version of -Agda or one compatible with it, download the code in this repo, and run -`agda all.agda` at the command line. +The main syntctic categories and judgements are found in [core-type.agda](core-type.agda), [core-exp.agda](core-exp.agda), and [core.agda](core.agda). De Bruijn index operations and substitutions are defined in [core-subst.agda](core-subst.agda). -Alternatively, we have provided a [Docker file](Dockerfile) to make it -easier to build that environment and check the proofs. To use it, first -install [Docker](https://www.docker.com/products/docker-desktop), make sure -the Docker daemon is running, and clone this repository to your local -machine. Then, at a command line inside that clone, run +The proofs of each part of Theorem 5 can be found in: -``` -docker build -t hazel-popl19 . -``` +- [elaborability.agda](elaborability.agda) +- [elaboration-generality.agda](elaboration-generality.agda) +- [elaboration-unicity.agda](elaboration-unicity.agda) +- [typed-elaboration.agda](typed-elaboration.agda) +- [type-assignment-unicity.agda](type-assignment-unicity.agda) -This may take a fair amount of time. When it finishes, run +The proofs of each part of Theorem 1 (Type Safety) can be found in: -``` -docker run hazel-popl19 -``` +- [preservation.agda](preservation.agda) +- [progress.agda](progress.agda) -This should take less than a minute, produce a lot of output as Agda checks -each module and function, and end with either the line `Finished all.` or -`Loading all (/all.agdai).` to indicate success, depending on Docker-level -caching. +The proofs of each part of Theorem 6 can be found in: -Most text editors that support Agda can be configured to use the version -instead a Docker container instead of your host machine, so you can -experiment with or evolve this code without making too much of a mess. For -some example instructions, see [the docker-agda -repo](https://github.com/banacorn/docker-agda). +- [complete-elaboration.agda](complete-elaboration.agda) +- [complete-preservation.agda](complete-preservation.agda) +- [complete-progress.agda](complete-progress.agda) -# Where To Find Each Theorem +The proof of Theorem 2 can be found in: -All of the judgements defined in the paper are given in -[core.agda](core.agda). The syntax is meant to mirror the on-paper notation -as closely as possible, with some small variations because of the -limitations of Agda syntax. +- [parametricity.agda](parametricity.agda) -For easy reference, the proofs for the theorems in order of appearance in -the paper text can be found as follows: +The proof of Theorem 3 and Corollary 2 can be found in: -- Theorem 3.1, _Typed Elaboration_, is in - [typed-elaboration.agda](typed-elaboration.agda). -- Theorem 3.2, _Type Assignment Unicity_, is in - [type-assignment-unicity.agda](type-assignment-unicity.agda). -- Theorem 3.3, _Elaborability_, is in - [elaborability.agda](elaborability.agda). -- Theorem 3.4, _Elaboration Generality_, is in - [elaboration-generality.agda](elaboration-generality.agda). -- Theorem 3.5, _Elaboration Unicity_, is in - [elaboration-unicity.agda](elaboration-unicity.agda). -- Definition 3.6, _Identity Substitution_, is in [core.agda](core.agda) on - line 31. -- Definition 3.7, _Substitution Typing_, is in [core.agda](core.agda) on - line 252. -- Theorem 3.8, _Finality_, is in [finality.agda](finality.agda). -- Lemma 3.9, _Grounding_, is in [grounding.agda](grounding.agda). -- Theorem 3.10, _Preservation_, is in - [preservation.agda](preservation.agda). -- Theorem 3.11, _Progress_, is in [progress.agda](progress.agda). -- Theorem 3.12, _Complete Elaboration_, is in - [complete-elaboration.agda](complete-elaboration.agda). -- Theorem 3.13, _Complete Preservation_, is in - [complete-preservation.agda](complete-preservation.agda). -- Theorem 3.14, _Complete Progress_, is in - [complete-progress.agda](complete-progress.agda). -- Proposition 3.15, _Sensibility_, is taken as a postulate in - [continuity.agda](continuity.agda). Sensibility for a slightly different - and richer language is proven in the mechanization of our - [POPL17](https://arxiv.org/pdf/1607.04180) work. -- Corollary 3.16, _Continuity_, is in - [continuity.agda](continuity.agda). Though we did not explicitly claim a - mechanization of this claim, we give a proof is given in terms of a few - postulates encoding the results from Omar et al., POPL 2017. +- [parametricity2.agda](parametricity.agda) + - Lemma 1: [parametricity2-lemmas1.agda](parametricity2-lemmas1.agda) + - Lemma 2: [parametricity2-lemmas2.agda](parametricity2-lemmas2.agda) -The extended paper with an appendix goes into more detail for some lemmas -and definitions omitted from the main paper, some of which have been -mechanized as well. Those can be found as follows: +The proof of Theorem 4 (the Static Gradual Guarantee) can be found in: -- A.1, _Substitution_, is defined in [core.agda](core.agda) at line 294, as - `[_/_]_` for terms and `apply-env` for substitutions `σ`. -- Lemma A.1, _Substitution_ is in - [lemmas-subst-ta.agda](lemmas-subst-ta.agda). -- Lemma A.2, _Canonical Value Forms_, is in - [canonical-value-forms.agda](canonical-value-forms.agda). -- Lemma A.3, _Canonical Boxed Forms_, is in - [canonical-boxed-forms.agda](canonical-value-forms.agda). -- Lemma A.4, _Canonical Indeterminate Forms_, is in - [canonical-indeterminate-forms.agda](canonical-value-forms.agda). -- A.3, _Complete Programs_, is defined in [core.agda](core.agda) at line - 160. -- Definition A.5, _Typing Context Completeness_, is defined in - [core.agda](core.agda) at line 183. -- Lemma A.6, _Complete Consistency_, is in - [lemmas-complete.agda](lemmas-complete.agda) as `complete-consistency` on - line 19. -- Lemma A.7, _Complete Casts_, is in [cast-inert.agda](cast-inert.agda) as - `complete-casts` on line 31. -- A.4, _Multiple Steps_, is defined in [core.agda](core.agda) on line 470. - -# Description of Agda Files - -The theorem statements rely on a variety of lemmas and smaller claims or -observations that aren't explicitly mentioned in the paper text. What -follows is a rough description of what to expect from each source file; -more detail is provided in the comments inside each. - -On paper, we typically take it for granted that we can silently α-rename -terms to equivalent terms whenever a collision of bound names is -inconvenient. In a mechanization, we do not have that luxury and instead -must be explicit in our treatment of binders in one way or another. In our -development here, we assume that all terms are in an α-normal form where -binders are globally not reused. - -That manifests in this development where we have chosen to add premises -that binders are unique within a term or disjoint between terms when -needed. These premises are fairly benign, since α-equivalence tells us they -can always be satisfied without changing the meaning of the term in -question. Other standard approaches include using de Bruijn indices, -Abstract Binding Trees, HOAS, or PHOAS to actually rewrite the terms when -needed. We have chosen not to use these techniques because _almost all_ of -the theory we're interested in does not need them and their overhead -quickly becomes pervasive, obfuscating the actual points of interest. - -Similarly, we make explicit some premises about disjointness of contexts or -variables being apart from contexts in some of the premises of some rules -that would typically be taken as read in an on-paper presentation. This is -a slightly generalized version of Barendrecht's convention (Barendregt, -1984), which we also used in our [POPL17 -mechanization](https://github.com/hazelgrove/agda-popl17) for the same -reason. - -Since the type system for external terms is bidirectional, the judgments -defining it are mutually recursive. That means that anything type-directed -is very likely to also be mutually recursive. The grammar of internal -expressions is also mutually recursive with the definition of substitution -environments. All told, a fair number of theorems are mutually recursive as -this percolates through. We try to name things in a suggestive way, using -`x-synth` and `x-ana` for the two halves of a theorem named `x`. - -Both hole and type contexts are encoded as Agda functions from natural -numbers to optional contents. In practice these mappings are always -finite. We represent finite substitutions and substitution environments -explicitly as inductive datatypes, `_,_⊢_:s:_`and `env` from -[core.agda](core.agda) respectively, taking advantage of the fact that the -base case in our semantics is always the identity substitution. This allows -us to reason about substitutions in a well-founded way that passes the Agda -termination checker. - -## Postulates - -We have benign postulates in two places: - -- First, we postulate function extensionality in -[Prelude.agda](Prelude.agda), because it is known to be independent from -Agda and we use it to reason about contexts. - -- Second, in [continuity.agda](continuity.agda), we postulate some - judgemental forms and theorems from our POPL17 mechanization in order to - demonstrate the connections to it described in the paper. We also - postulate some glue code that allows us to use those theorems in this - work. - -There are no other postulates in this development. - -## Meta -- [all.agda](all.agda) is morally a make file: it includes every module in - every other file, so running `$ agda all.agda` on a clean clone of this - repository will recheck every proof from scratch. It is known to load - cleanly with `Agda version 2.6.2`; we have not tested it on any other - version. - -## Prelude and Datatypes - -These files give definitions and syntactic sugar for common elements of -type theory (sum types, products, sigmas, etc.) and natural numbers that -are used pervasively throughout the rest of the development. - -- [Nat.agda](Nat.agda) -- [Prelude.agda](Prelude.agda) - -## Core Definitions - -- [contexts.agda](contexts.agda) defines contexts as functions from natural - numbers to possible contents and proves a collection of lemmas that makes - this definition practical. -- [core.agda](core.agda) gives the definitions of all the grammars and - judgements in the order presented in the paper as types and metafunctions - in Agda. It also includes the definition of the judgements that are used - implicitly on paper but need to be made explicit in a mechanization. - -## Structural Properties - -- [contraction.agda](contraction.agda) argues that contexts are the same up - to contraction, and therefore that every judgement that uses them enjoys - the contraction property. Note that this proof is given for any sort of - context, so it establishes contraction in both the type and hole contexts - for those judgements that have both. -- [exchange.agda](exchange.agda) argues that contexts are the same up to - exchange, and therefore that every judgement that uses the enjoys the - exchange property. As above, this proof establishes exchange in both the - type and hole contexts for those jugements that have both. -- [weakening.agda](weakening.agda) argues the weakening properties for - those judgements where we needed it in the other proofs. This is not - every weakening property for every judgement, and indeed some of them _do - not_ enjoy weakening in every argument. - - For example, the elaborations do not support weakening in the typing - context because the rule for substitution typing requires that the lowest - substitution be exactly the identity, not something that can be weakened - to the identity. (See the definition of `STAId` on line 254 of - [core.agda](core.agda).) In practice, this is not a problem because you - wouldn't want to add anything there just to weaken it away, and allowing - imprecision here would break the [unicity of - elaboration](elaboration-unicity.agda). - -## Theorems - -### Canonical Forms - -Together, these files give the canonical forms lemma for the language. - -- [canonical-boxed-forms.agda](canonical-boxed-forms.agda) -- [canonical-indeterminate-forms.agda](canonical-indeterminate-forms.agda) -- [canonical-value-forms.agda](canonical-value-forms.agda) - -### Metatheory of Type Assignment - -- [type-assignment-unicity.agda](type-assignment-unicity.agda) argues that - the type assignment system assigns at most one type to any term. - -### Metatheory of Elaboration - -- [elaboration-generality.agda](elaboration-generality.agda) argues that - the elaboration judgements respect the bidirectional typing system. -- [elaborability.agda](elaborability.agda) argues that any well typed - external term can be elaborated to a internal term. -- [elaboration-unicity.agda](elaboration-unicity.agda) argues that - elaboration produces at most one result. -- [typed-elaboration.agda](typed-elaboration.agda) argues that the - elaboration respects the type assignment system. - -### Type Safety - -These files contain proofs of type safety for the internal language. Note -that we only give a dynamic semantics for the internal language, which is -related to the external language through elaboration. - -- [progress.agda](progress.agda) argues that any well typed internal - expression either steps, is a boxed value, or is indeterminate. -- [progress-checks.agda](progress-checks.agda) argues that the clauses in - the conclusion of progress are pairwise disjoint---i.e. that no - expression both steps and is a boxed value, and so on. -- [preservation.agda](preservation.agda) argues that stepping preserves - type assignment. - - This is the main place that our assumption about α-normal terms appears: - the statement of preservation makes explicit the standard on-paper - convention that binders not be reused in its argument. - -We also argue that our dynamics is a conservative extension in the sense -that if you use it to evaluate terms that happen to have no holes in them, -you get the standard type safety theorems you might expect for the -restricted fragment without holes. - -- [complete-elaboration.agda](complete-elaboration.agda) argues that the - elaboration of a complete external term produces a complete internal - term. -- [complete-preservation.agda](complete-preservation.agda) argues that - stepping a complete term produces a complete term that is assigned the - same type, again with an explicit assumption about binder uniqueness. -- [complete-progress.agda](complete-progress.agda) argues that complete - terms are either a value or step. - -### Metatheory of Continuity - -- [continuity.agda](continuity.agda) includes a sketch of a proof of - continuity. This is built on postulates of a result from our POPL17 work - and a few properties that would need to be proven about the expression - forms from that work and the α-normal requirement we have in this work. - -## Lemmas and Smaller Claims - - -These files each establish smaller claims that are either not mentioned in -the paper or mentioned only in passing. In terms of complexity and -importance, they're somewhere between a lemma and a theorem. - -- [binders-disjoint-checks.agda](binders-disjoint-checks.agda) contains - some proofs that demonstrate that `binders-disjoint` acts as - expected. That judgement is defined inductively only on its left - argument; since Agda datatypes do not define functions, explicit lemmas - are needed to get the expected reduction behaivour in the right argument. -- [cast-inert.agda](cast-inert.agda) gives a judgemental removal of - identity casts and argues that doing so does not change the type of the - expression. It would also be possible to argue that removing the identity - casts produces a term that evaluates in the same way---but identity cast - removal is a syntactic operation that goes under binders while our - evaluation semantics does not. To establish that result, we'd need to - also give an equational theory of evaluation compatible with the given - one. -- [disjointness.agda](disjointness.agda) characterizes the output hole - contexts produced in elaboration, including disjointness guarantees - needed in the proofs of [Elaborability](elaborability.agda) and - [Elaboration Generality](elaboration-generality.agda). -- [dom-eq.agda](dom-eq.agda) defines when two contexts have the same - domain, regardless of the range type or contents, and some operations - that preserve that property. This is used in the proofs in - [disjointness.agda](disjointness.agda). -- [finality.agda](finality.agda) argues that a final expression doesn't - step, and only multi-steps to itself. More properties of this nature are - proven in [progress-checks.agda](progress-checks.agda) but not called out - explicitly in the paper. -- [focus-formation.agda](focus-formation.agda) argues that every `ε` is an - evaluation context. As noted in [core.agda](core.agda), because we elide - the boxed-in-red finality premises from the stepping rules, every `ε` is - trivially an evaluation context, so this proof is extremely immediate; it - would be slightly more involved if those premises were in place. -- [ground-decidable.agda](ground-decidable.agda) argues that every type is - either ground or not. -- [grounding.agda](grounding.agda) argues the grounding property. -- [holes-disjoint-checks.agda](holes-disjoint-checks.agda) contains some - checks on and lemmas for using the `holes-disjoint` judgement. Like - `binders-disjoint`, `holes-disjoint` is defined inductively on only its - left argument, so there's similar overhead. -- [htype-decidable.agda](htype-decidable.agda) argues that every pair of - types are either equal or not. -- [synth-unicity.agda](synth-unicity.agda) argues that the synthesis - judgement produces at most one type for a term. - -These files contain technical lemmas for the corresponding judgement or -theorem. They are generally not surprising once stated, although it's -perhaps not immediate why they're needed, and they tend to obfuscate the -actual proof text. They are corralled into their own modules in an effort -to aid readability. - -- [lemmas-complete.agda](lemmas-complete.agda) -- [lemmas-consistency.agda](lemmas-consistency.agda) -- [lemmas-disjointness.agda](lemmas-disjointness.agda) -- [lemmas-freshness.agda](lemmas-freshness.agda) -- [lemmas-gcomplete.agda](lemmas-gcomplete.agda) -- [lemmas-ground.agda](lemmas-ground.agda) -- [lemmas-matching.agda](lemmas-matching.agda) -- [lemmas-progress-checks.agda](lemmas-progress-checks.agda) -- [lemmas-subst-ta.agda](lemmas-subst-ta.agda) +- [graduality.agda](graduality.agda) diff --git a/ae-reviews.txt b/ae-reviews.txt deleted file mode 100644 index 1b8cfc6..0000000 --- a/ae-reviews.txt +++ /dev/null @@ -1,216 +0,0 @@ -POPL'19 AEC Paper #36 Reviews and Comments -=========================================================================== -Paper #36 Live Functional Programming with Typed Holes - - -Review #36A -=========================================================================== -* Updated: 29 Oct 2018 5:55:37am EDT - -Overall merit -------------- -3. Weak accept - -Reviewer expertise ------------------- -2. Some familiarity - -Artifact summary ----------------- -The paper develops dynamic semantics for incomplete functional programs with the -goal of enhancing live program editing experience in an IDE. The artefact -supplied by the authors is: - - 1. an Agda mechanization of metatheory presented in Section 3 of the paper. - - 2. an OCaml implementation of system described in the paper (there's a small - fragment of code written in Coq) - -Both artefacts are available as online GitHub repositories with the source code. -Authors have also provided a Docker file to install a container with all the -software required to build the Agda formalization. Prototype implementation is -also freely accessible online at www.hazel.org. - -General assesment ------------------ -# Artefact 1 - Agda mechanization - -The main strength of the artefact is that it provides formal proofs of theorems -formulated by the authors, thus proving correctness of the proposed metatheory. -Authors have provided a good table of contents that lists where exactly in the -source code are the proofs of theorems from Section 3 of the paper. The source -code itself is well written - clean and with enough comments. - -One minor complaint would be the fact that the artefact relies on an old (2.5 -year) version of Agda, and thus building the artefact from source is -burdensome (requires installing an old version of GHC). However, with Agda's lack of guarantees on backward compatibility, -it probably makes little sense to update to the latest version anyway. A docker -file provided by the authors mitigates the problem. - -In my opinion this artefact meets the expectations set by the paper and deserves -an "accept". - -# Artefact 2 - OCaml implementation - -The main strength of this artefact is that it allows interactive experimentation -with the proposed system. However, I feel that there is a significant mismatch -between what the paper promises and what the artefact actually delivers. -Concretely, the paper suggest that the implementation provides various syntactic -sugar constructs (tuples, recursive data types), but the only way to have these -is using Church encodings. Importantly, this does *NOT* invalidate findings of the paper. -The implemented system is expressive enough to support the claims that authors -make. However, given the introduction to and mock-ups shown in Section 2, a -reader will most likely expect more from the implementation. Moreover, I found -the source code lacking comments. Implementation of semantics in Coq has some, -but not too many. This makes reading the source code difficult. - -I feel that this artefact falls short of the expectations set by the paper. At -this point I rate it as a "weak reject", but if authors make changes discussed -in the comments (and summarized below) my rating will go up. - -Suggestions for improvement ---------------------------- -Regarding the first artefact, please provide additional instructions how to run -Agda installation from a Docker container with agda-mode in Emacs. - -Regarding the second artefact, please update the paper to give reader an -accurate expectation of what the artefact actually implements. Most -importantly, please point out that reproducing examples in the paper requires -Church encodings. This is not obvious from the text and figures. -Perhaps prepare an extended version of the paper that contains an appendix with -the actual code of the examples? - - - -Comment @A1 by Cyrus Omar ---------------------------------------------------------------------------- -Thank you for your feedback. - -1. Agda is rapidly evolving, and makes no guarantee of backwards compatibility between releases, so we have pinned our work on Hazelnut and now Hazelnut Live to a stable version of Agda. It is possible to connect Emacs to a Dockerized version of Agda: https://github.com/banacorn/docker-agda. We would be happy to include those instructions in the final version of the artifact. - -2. You can play with Hazel on hazel.org, and its source code is available on Github: https://github.com/hazelgrove/hazel. We would be happy to submit a snapshot of Hazel for review if requested, but it is rapidly evolving and the primary contribution of this paper is Hazelnut Live, so we focused on submitting the finished mechanization of Hazelnut Live for review. - - -Comment @A2 by Reviewer A ---------------------------------------------------------------------------- -Re 1. Being able to run agda-mode with a docker version of Agda looks like an improvement. And I do realize that even if you updated the development to the latest version of Agda there is no guarantee that it will compile correctly with any of the future versions. So I will not insist on that. - -Re 2. Indeed, formalization of the metatheory is the primary contribution. But the paper demonstrates a working system that implements these ideas and it makes one want to experiment with it - it is much more interesting to explore such a system in an interactive way rather than look at the proofs of its correctness! I realize that Hazel is evolving but I don't see it as an obstacle to submitting it as an artefact. Just create a git tag in the repository to mark the version used to obtain results in the paper. This will ensure that anyone in the future can easily reproduce results from the paper by checking out a corresponding tag. I dare to make a bold statement that it might be very useful to you, the developers, as well. Imagine yourselves in a few years writing a paper about some newest developments in Hazel and being able to easily go back to an older version of the project to compare its features with the latest version. - - -Comment @A3 by Cyrus Omar ---------------------------------------------------------------------------- -OK, I confirmed with the AEC chairs that we can add the snapshot of the implementation for evaluation, so we made a release on GitHub: - -https://github.com/hazelgrove/hazel/releases/tag/popl19aec-final - -The installation instructions are available in the README.md file, and a prebuilt version of Hazel is available for use in the browser at `popl19aec-www/hazel.html`. - -We will include this in the final artifact as requested. - - -Comment @A4 by Reviewer A ---------------------------------------------------------------------------- -Thank you. Please give me some time to play with the implementation and update my review. - - -Comment @A5 by Reviewer A ---------------------------------------------------------------------------- -I just watched the Strange Loop talk on Hazel. As I understand it the current implementation is more-or-less the same as shown during that talk and the screenshots in the paper are mock-ups of an intended user interface. That being said, how do I: - -1. construct tuples? -2. construct lists? -3. use a map? - -I'd like to implement code that is semantically equivalent to what is shown in Fig.1 in the paper. I would appreciate if you could help me make the first steps. - - -Comment @A6 by Cyrus Omar ---------------------------------------------------------------------------- -Yes, as detailed in the introductory part of Sec. 2, the language features shown in use in the figures in the paper are mocked up. - -The easiest way to implement the examples from Sec. 2 are by using Church encodings. See attached for a simple example demonstrating lists and map. The second screenshots demonstrates that the sidebar displays 3 closures as expected from the discussion around Fig. 1. - - -Comment @A7 by Reviewer A ---------------------------------------------------------------------------- -> The easiest way to implement the examples from Sec. 2 are by using Church encodings. - -Allow me to quote from introduction to Section 2: -"some 'syntactic and semantic sugar' (...) was not available in Hazel as of this writing, e.g. - [A] pattern matching in function arguments, - [B] list notation - [C] and record labels (currently there are only tuples). [A, B, and C added by me]" - - 1. [C] suggests that I can use tuples (not Church encodings of tuples) - 2. [B] suggests that I can have lists (again, I would assume recursive data types - not Church encodings), except that they don't have a convenient notation of the form `[1,2,3]`, so I have to say something like `Cons 1 (Cons 2 (Cons 2 Nil))`. - 3. [A] suggests that I can take apart these data types - lists, tuples - with pattern matching, except that I can't say: - ``` - map f nil = _ - map f (cons x xs) = _ - ``` - and have to do this instead: - ``` - map f xs = case xs of { nil -> _; cons x xs' -> _ } - ``` - -So the paper gives an impression that the system is more powerful that it actually seems to be. Is that correct? - - -Comment @A8 by Cyrus Omar ---------------------------------------------------------------------------- -1. Apologies -- we did have tuples in a version of the code at the time of submission, but they were lost during a refactoring a few months ago (the plan was to add a "comma" operator into the infix operator syntax instead of having a separate tuple form, but that change isn't done yet). I should have remembered to mention that in my response earlier. We will remove the claim that there are tuples in the final version of the paper being prepared right now. - -2. We did not claim that there were recursive datatypes in the implementation, only that lists can be expressed. They can be expressed using the Church encodings as just discussed, or alternatively with a sum type with a type hole in recursive position. - -3. The phrase "pattern matching in function arguments" simply referred to the fact that we only show pattern matching in argument position in the examples in the paper -- we did not show an explicit case/match. There is in fact a case expression in Hazel and there is no support for nested patterns there. You can, however, case analyze on lists expressed as a sum type using this case form. - -We will rewrite the sentence you highlighted to make the status of our implementation more clear in the final version of the paper being prepared right now. The fundamental claim -- that you can express the examples in Sec. 2 in our current implementation with some "encoding tricks" and that all of the live programming features demonstrated in the figures in Sec. 2 are implemented -- holds. - - - -Review #36B -=========================================================================== -* Updated: 28 Oct 2018 1:32:54pm EDT - -Overall merit -------------- -5. Strong accept - -Reviewer expertise ------------------- -4. Expert - -Artifact summary ----------------- -This paper presents Hazelnut, a functional language with support for both term- and type-level holes representing incomplete programs. Term-level holes are treated as stuck terms, while type-level holes behave like the 'any' type from gradual typing. - -The artefact consists of an Agda formalization of the Hazelnut Live core language and its metatheoretical properties, including preservation and progress for both incomplete and complete programs. - -General assesment ------------------ -I believe this artefact lives up to the expectations set by the paper. The Agda code is written in a clear way and closely follows the definitions and theorems in the paper. All theorems in the paper are proven (except for Theorem 4.2, which the paper does not claim to be formalized). Congratulations to the authors for the effort put into formalizing everything in such a disciplined way! - -The choice to represent variables as unique names and contexts as functions is a bit surprising, I would have expected a more standard approach using de Bruijn-indices. But since this does not seem to cause any serious problems (aside from requiring functional extensionality) I don't see this as a negative point. - -The code itself seems easy enough to modify and/or extend, although bigger extensions such as adding polymorphic types would probably require some re-thinking of the basic definitions. - -There are two minor questions I had that I'd like to see addressed either in the code or the paper: -- Why is there a separate constructor for the identity substitution instead of it being defined as in the paper? -- Is there a particular reason why the proof of commutativity (Theorem 4.2) is not part of the formalization? If there was some kind of obstacle (other than lack of time) that prevented this, it would be interesting to know. - ---------------------------------------------------- - -Below are some questions that I had while reading the paper but are not related directly to the artefact: - -I wonder how hole filling works for type holes, since all type holes are considered to be equal. In particular, it's possible to type the identity function at type ⦇⦈ -> ⦇⦈ but then fill in the two holes with different types, thus causing the function to become ill-typed. Wouldn't it be better to also give IDs to type holes? Otherwise it seems like you would run into a problem that you start with a program that is accepted, fill some holes, and end up with a program that is rejected even though all the hole fills were valid. - -To formulate the above question in a different way: I believe the analogous statement of commutativity (Theorem 4.2) does not hold for filling of type holes. Is this correct? - -Did you also consider the dual to hole filling, i.e. turning an existing sub-expression into a non-empty hole containing that subexpression? This seems like it would be another useful operation to have for editing code. Of course this does not preserve the dynamic semantics, but one would expect it at least preserves well-typedness. - -Suggestions for improvement ---------------------------- -- In recent versions of Agda, the idiom brackets ⦇⦈ are reserved symbols, preventing the code from compiling. A simple search-and-replace (I replaced ⦇ by ⦇- and ⦈ by -⦈) fixed the problem. If it is not too much effort, it would be nice to rename these in the final version of the artefact as well. - -- A minor inconsistency between the paper and the Agda code: the rule FBoxedVal in the paper is called FBoxed in the Agda code. diff --git a/all.agda b/all.agda index 7125a0e..5470bcb 100644 --- a/all.agda +++ b/all.agda @@ -1,53 +1,41 @@ open import Nat open import Prelude -open import contexts +open import core-type +open import core-exp +open import core-subst open import core -open import lemmas-gcomplete - -open import disjointness -open import dom-eq -open import holes-disjoint-checks -open import lemmas-disjointness -open import lemmas-freshness - -open import finality -open import focus-formation -open import ground-decidable -open import grounding +open import weakening +open import eq-dec +open import ground-dec -open import lemmas-subst-ta -open import htype-decidable +open import lemmas-index open import lemmas-consistency +open import lemmas-prec +open import lemmas-meet open import lemmas-ground -open import lemmas-matching -open import synth-unicity +open import lemmas-ctx +open import lemmas-wf +open import lemmas-subst +open import lemmas-complete + +open import typing-subst open import elaborability open import elaboration-generality open import elaboration-unicity -open import type-assignment-unicity open import typed-elaboration +open import type-assignment-unicity -open import canonical-boxed-forms -open import canonical-indeterminate-forms -open import canonical-value-forms - -open import lemmas-progress-checks open import preservation -open import progress -open import progress-checks +open import progress -open import cast-inert open import complete-elaboration open import complete-preservation open import complete-progress -open import lemmas-complete -open import contraction -open import exchange -open import weakening +open import parametricity +open import graduality -open import binders-disjoint-checks -open import continuity +module all where diff --git a/binders-disjoint-checks.agda b/binders-disjoint-checks.agda deleted file mode 100644 index dfb56e6..0000000 --- a/binders-disjoint-checks.agda +++ /dev/null @@ -1,83 +0,0 @@ -open import Prelude -open import Nat -open import core - - -module binders-disjoint-checks where - -- these are fairly mechanical lemmas that show that the - -- judgementally-defined binders-disjoint is really a type-directed - -- function - mutual - lem-bdσ-lam : ∀{σ x τ d} → binders-disjoint-σ σ (·λ_[_]_ x τ d) → binders-disjoint-σ σ d - lem-bdσ-lam BDσId = BDσId - lem-bdσ-lam (BDσSubst x₁ bd) = BDσSubst (lem-bd-lam x₁) (lem-bdσ-lam bd) - - lem-bd-lam : ∀{ d1 x τ1 d} → binders-disjoint d1 (·λ_[_]_ x τ1 d) → binders-disjoint d1 d - lem-bd-lam BDConst = BDConst - lem-bd-lam BDVar = BDVar - lem-bd-lam (BDLam bd (UBLam2 x₂ x₃)) = BDLam (lem-bd-lam bd) x₃ - lem-bd-lam (BDHole x₁) = BDHole (lem-bdσ-lam x₁) - lem-bd-lam (BDNEHole x₁ bd) = BDNEHole (lem-bdσ-lam x₁) (lem-bd-lam bd) - lem-bd-lam (BDAp bd bd₁) = BDAp (lem-bd-lam bd) (lem-bd-lam bd₁) - lem-bd-lam (BDCast bd) = BDCast (lem-bd-lam bd) - lem-bd-lam (BDFailedCast bd) = BDFailedCast (lem-bd-lam bd) - - mutual - lem-bdσ-hole : ∀{d u σ σ'} → binders-disjoint-σ σ ⦇⌜ d ⌟⦈⟨ u , σ' ⟩ → binders-disjoint-σ σ d - lem-bdσ-hole BDσId = BDσId - lem-bdσ-hole (BDσSubst x bd) = BDσSubst (lem-bd-hole x) (lem-bdσ-hole bd) - - lem-bd-hole : ∀{d1 d u σ} → binders-disjoint d1 ⦇⌜ d ⌟⦈⟨ u , σ ⟩ → binders-disjoint d1 d - lem-bd-hole BDConst = BDConst - lem-bd-hole BDVar = BDVar - lem-bd-hole (BDLam bd (UBNEHole x₁ x₂)) = BDLam (lem-bd-hole bd) x₂ - lem-bd-hole (BDHole x) = BDHole (lem-bdσ-hole x) - lem-bd-hole (BDNEHole x bd) = BDNEHole (lem-bdσ-hole x) (lem-bd-hole bd) - lem-bd-hole (BDAp bd bd₁) = BDAp (lem-bd-hole bd) (lem-bd-hole bd₁) - lem-bd-hole (BDCast bd) = BDCast (lem-bd-hole bd) - lem-bd-hole (BDFailedCast bd) = BDFailedCast (lem-bd-hole bd) - - mutual - lem-bdσ-cast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ (d ⟨ τ1 ⇒ τ2 ⟩) → binders-disjoint-σ σ d - lem-bdσ-cast BDσId = BDσId - lem-bdσ-cast (BDσSubst x bd) = BDσSubst (lem-bd-cast x) (lem-bdσ-cast bd) - - lem-bd-cast : ∀{d1 d τ1 τ2} → binders-disjoint d1 (d ⟨ τ1 ⇒ τ2 ⟩) → binders-disjoint d1 d - lem-bd-cast BDConst = BDConst - lem-bd-cast BDVar = BDVar - lem-bd-cast (BDLam bd (UBCast x₁)) = BDLam (lem-bd-cast bd) x₁ - lem-bd-cast (BDHole x) = BDHole (lem-bdσ-cast x) - lem-bd-cast (BDNEHole x bd) = BDNEHole (lem-bdσ-cast x) (lem-bd-cast bd) - lem-bd-cast (BDAp bd bd₁) = BDAp (lem-bd-cast bd) (lem-bd-cast bd₁) - lem-bd-cast (BDCast bd) = BDCast (lem-bd-cast bd) - lem-bd-cast (BDFailedCast bd) = BDFailedCast (lem-bd-cast bd) - - mutual - lem-bdσ-failedcast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) → binders-disjoint-σ σ d - lem-bdσ-failedcast BDσId = BDσId - lem-bdσ-failedcast (BDσSubst x bd) = BDσSubst (lem-bd-failedcast x) (lem-bdσ-failedcast bd) - - lem-bd-failedcast : ∀{d1 d τ1 τ2} → binders-disjoint d1 (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) → binders-disjoint d1 d - lem-bd-failedcast BDConst = BDConst - lem-bd-failedcast BDVar = BDVar - lem-bd-failedcast (BDLam bd (UBFailedCast x₁)) = BDLam (lem-bd-failedcast bd) x₁ - lem-bd-failedcast (BDHole x) = BDHole (lem-bdσ-failedcast x) - lem-bd-failedcast (BDNEHole x bd) = BDNEHole (lem-bdσ-failedcast x) (lem-bd-failedcast bd) - lem-bd-failedcast (BDAp bd bd₁) = BDAp (lem-bd-failedcast bd) (lem-bd-failedcast bd₁) - lem-bd-failedcast (BDCast bd) = BDCast (lem-bd-failedcast bd) - lem-bd-failedcast (BDFailedCast bd) = BDFailedCast (lem-bd-failedcast bd) - - mutual - lem-bdσ-into-cast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ d → binders-disjoint-σ σ (d ⟨ τ1 ⇒ τ2 ⟩) - lem-bdσ-into-cast BDσId = BDσId - lem-bdσ-into-cast (BDσSubst x bd) = BDσSubst (lem-bd-into-cast x) (lem-bdσ-into-cast bd) - - lem-bd-into-cast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint d1 (d2 ⟨ τ1 ⇒ τ2 ⟩) - lem-bd-into-cast BDConst = BDConst - lem-bd-into-cast BDVar = BDVar - lem-bd-into-cast (BDLam bd x₁) = BDLam (lem-bd-into-cast bd) (UBCast x₁) - lem-bd-into-cast (BDHole x) = BDHole (lem-bdσ-into-cast x) - lem-bd-into-cast (BDNEHole x bd) = BDNEHole (lem-bdσ-into-cast x) (lem-bd-into-cast bd) - lem-bd-into-cast (BDAp bd bd₁) = BDAp (lem-bd-into-cast bd) (lem-bd-into-cast bd₁) - lem-bd-into-cast (BDCast bd) = BDCast (lem-bd-into-cast bd) - lem-bd-into-cast (BDFailedCast bd) = BDFailedCast (lem-bd-into-cast bd) diff --git a/canonical-boxed-forms.agda b/canonical-boxed-forms.agda deleted file mode 100644 index ab748ba..0000000 --- a/canonical-boxed-forms.agda +++ /dev/null @@ -1,74 +0,0 @@ -open import Nat -open import Prelude -open import contexts -open import core - -open import canonical-value-forms - -module canonical-boxed-forms where - canonical-boxed-forms-b : ∀{Δ d} → - Δ , ∅ ⊢ d :: b → - d boxedval → - d == c - canonical-boxed-forms-b (TAVar _) (BVVal ()) - canonical-boxed-forms-b wt (BVVal v) = canonical-value-forms-b wt v - - -- this type gives somewhat nicer syntax for the output of the canonical - -- forms lemma for boxed values at arrow type - data cbf-arr : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where - CBFLam : ∀{Δ d τ1 τ2} → - (Σ[ x ∈ Nat ] Σ[ d' ∈ ihexp ] - (d == (·λ x [ τ1 ] d') × Δ , ■ (x , τ1) ⊢ d' :: τ2)) - → cbf-arr Δ d τ1 τ2 - CBFCastArr : ∀{Δ d τ1 τ2} → - (Σ[ d' ∈ ihexp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ] - (d == (d' ⟨ τ1' ==> τ2' ⇒ τ1 ==> τ2 ⟩) × - (τ1' ==> τ2' ≠ τ1 ==> τ2) × - (Δ , ∅ ⊢ d' :: τ1' ==> τ2'))) - → cbf-arr Δ d τ1 τ2 - - canonical-boxed-forms-arr : ∀{Δ d τ1 τ2 } → - Δ , ∅ ⊢ d :: (τ1 ==> τ2) → - d boxedval → - cbf-arr Δ d τ1 τ2 - canonical-boxed-forms-arr (TAVar x₁) (BVVal ()) - canonical-boxed-forms-arr (TALam f wt) (BVVal v) = CBFLam (canonical-value-forms-arr (TALam f wt) v) - canonical-boxed-forms-arr (TAAp wt wt₁) (BVVal ()) - canonical-boxed-forms-arr (TAEHole x x₁) (BVVal ()) - canonical-boxed-forms-arr (TANEHole x wt x₁) (BVVal ()) - canonical-boxed-forms-arr (TACast wt x) (BVVal ()) - canonical-boxed-forms-arr (TACast wt x) (BVArrCast x₁ bv) = CBFCastArr (_ , _ , _ , refl , x₁ , wt) - canonical-boxed-forms-arr (TAFailedCast x x₁ x₂ x₃) (BVVal ()) - - canonical-boxed-forms-hole : ∀{Δ d} → - Δ , ∅ ⊢ d :: ⦇-⦈ → - d boxedval → - Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] - ((d == d' ⟨ τ' ⇒ ⦇-⦈ ⟩) × - (τ' ground) × - (Δ , ∅ ⊢ d' :: τ')) - canonical-boxed-forms-hole (TAVar x₁) (BVVal ()) - canonical-boxed-forms-hole (TAAp wt wt₁) (BVVal ()) - canonical-boxed-forms-hole (TAEHole x x₁) (BVVal ()) - canonical-boxed-forms-hole (TANEHole x wt x₁) (BVVal ()) - canonical-boxed-forms-hole (TACast wt x) (BVVal ()) - canonical-boxed-forms-hole (TACast wt x) (BVHoleCast x₁ bv) = _ , _ , refl , x₁ , wt - canonical-boxed-forms-hole (TAFailedCast x x₁ x₂ x₃) (BVVal ()) - - canonical-boxed-forms-coverage : ∀{Δ d τ} → - Δ , ∅ ⊢ d :: τ → - d boxedval → - τ ≠ b → - ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) → - τ ≠ ⦇-⦈ → - ⊥ - canonical-boxed-forms-coverage TAConst (BVVal x) nb na nh = nb refl - canonical-boxed-forms-coverage (TAVar x₁) (BVVal ()) nb na nh - canonical-boxed-forms-coverage (TALam _ wt) (BVVal x₁) nb na nh = na _ _ refl - canonical-boxed-forms-coverage (TAAp wt wt₁) (BVVal ()) nb na nh - canonical-boxed-forms-coverage (TAEHole x x₁) (BVVal ()) nb na nh - canonical-boxed-forms-coverage (TANEHole x wt x₁) (BVVal ()) nb na nh - canonical-boxed-forms-coverage (TACast wt x) (BVVal ()) nb na nh - canonical-boxed-forms-coverage (TACast wt x) (BVArrCast x₁ bv) nb na nh = na _ _ refl - canonical-boxed-forms-coverage (TACast wt x) (BVHoleCast x₁ bv) nb na nh = nh refl - canonical-boxed-forms-coverage (TAFailedCast x x₁ x₂ x₃) (BVVal ()) diff --git a/canonical-indeterminate-forms.agda b/canonical-indeterminate-forms.agda deleted file mode 100644 index 88455b1..0000000 --- a/canonical-indeterminate-forms.agda +++ /dev/null @@ -1,215 +0,0 @@ -open import Nat -open import Prelude -open import contexts -open import 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 base type - data cif-base : (Δ : hctx) (d : ihexp) → Set where - CIFBEHole : ∀ {Δ d} → - Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] - ((d == ⦇-⦈⟨ u , σ ⟩) × - ((u :: b [ Γ ]) ∈ Δ) × - (Δ , ∅ ⊢ σ :s: Γ) - ) - → cif-base Δ d - CIFBNEHole : ∀ {Δ d} → - Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] - ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) × - (Δ , ∅ ⊢ d' :: τ') × - (d' final) × - ((u :: b [ Γ ]) ∈ Δ) × - (Δ , ∅ ⊢ σ :s: Γ) - ) - → cif-base Δ d - CIFBAp : ∀ {Δ d} → - Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ] - ((d == d1 ∘ d2) × - (Δ , ∅ ⊢ d1 :: τ2 ==> b) × - (Δ , ∅ ⊢ d2 :: τ2) × - (d1 indet) × - (d2 final) × - ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩)) - ) - → cif-base Δ d - CIFBCast : ∀ {Δ d} → - Σ[ d' ∈ ihexp ] - ((d == d' ⟨ ⦇-⦈ ⇒ b ⟩) × - (Δ , ∅ ⊢ d' :: ⦇-⦈) × - (d' indet) × - ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩)) - ) - → cif-base Δ d - CIFBFailedCast : ∀ {Δ d} → - Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] - ((d == d' ⟨ τ' ⇒⦇-⦈⇏ b ⟩) × - (Δ , ∅ ⊢ d' :: τ') × - (τ' ground) × - (τ' ≠ b) - ) - → cif-base Δ d - - canonical-indeterminate-forms-base : ∀{Δ d} → - Δ , ∅ ⊢ d :: b → - d indet → - cif-base Δ d - canonical-indeterminate-forms-base TAConst () - canonical-indeterminate-forms-base (TAVar x₁) () - canonical-indeterminate-forms-base (TAAp wt wt₁) (IAp x ind x₁) = CIFBAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x) - canonical-indeterminate-forms-base (TAEHole x x₁) IEHole = CIFBEHole (_ , _ , _ , refl , x , x₁) - canonical-indeterminate-forms-base (TANEHole x wt x₁) (INEHole x₂) = CIFBNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁) - canonical-indeterminate-forms-base (TACast wt x) (ICastHoleGround x₁ ind x₂) = CIFBCast (_ , refl , wt , ind , x₁) - canonical-indeterminate-forms-base (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = CIFBFailedCast (_ , _ , 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 - 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 (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 GHole) = CIFACastHole (_ , refl , refl , refl , wt , ind , x₁) - canonical-indeterminate-forms-arr (TAFailedCast x x₁ GHole x₃) (IFailedCast x₄ x₅ GHole 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 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 - 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 (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 → - τ ≠ b → - ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) → - τ ≠ ⦇-⦈ → - ⊥ - canonical-indeterminate-forms-coverage TAConst () nb na nh - canonical-indeterminate-forms-coverage (TAVar x₁) () nb na nh - canonical-indeterminate-forms-coverage (TALam _ wt) () nb na nh - canonical-indeterminate-forms-coverage {τ = b} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = nb refl - canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = nh refl - canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = na τ τ₁ refl - canonical-indeterminate-forms-coverage {τ = b} (TAEHole x x₁) IEHole nb na nh = nb refl - canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAEHole x x₁) IEHole nb na nh = nh refl - canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAEHole x x₁) IEHole nb na nh = na τ τ₁ refl - canonical-indeterminate-forms-coverage {τ = b} (TANEHole x wt x₁) (INEHole x₂) nb na nh = nb refl - canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TANEHole x wt x₁) (INEHole x₂) nb na nh = nh refl - canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TANEHole x wt x₁) (INEHole x₂) nb na nh = na τ τ₁ refl - canonical-indeterminate-forms-coverage (TACast wt x) (ICastArr x₁ ind) nb na nh = na _ _ refl - canonical-indeterminate-forms-coverage (TACast wt x) (ICastGroundHole x₁ ind) nb na nh = nh refl - canonical-indeterminate-forms-coverage {τ = b} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = nb refl - canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = nh refl - canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = na τ τ₁ refl - canonical-indeterminate-forms-coverage {τ = b} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ z _ _₁ → z refl - canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ _ _₁ z → z refl - canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ _ z _₁ → z τ τ₁ refl diff --git a/canonical-value-forms.agda b/canonical-value-forms.agda deleted file mode 100644 index 1df293a..0000000 --- a/canonical-value-forms.agda +++ /dev/null @@ -1,62 +0,0 @@ -open import Nat -open import Prelude -open import contexts -open import core - -module canonical-value-forms where - canonical-value-forms-b : ∀{Δ d} → - Δ , ∅ ⊢ d :: b → - d val → - d == c - canonical-value-forms-b TAConst VConst = refl - canonical-value-forms-b (TAVar x₁) () - canonical-value-forms-b (TAAp wt wt₁) () - canonical-value-forms-b (TAEHole x x₁) () - canonical-value-forms-b (TANEHole x wt x₁) () - canonical-value-forms-b (TACast wt x) () - canonical-value-forms-b (TAFailedCast wt x x₁ x₂) () - - canonical-value-forms-arr : ∀{Δ d τ1 τ2} → - Δ , ∅ ⊢ d :: (τ1 ==> τ2) → - d val → - Σ[ x ∈ Nat ] Σ[ d' ∈ ihexp ] - ((d == (·λ x [ τ1 ] d')) × - (Δ , ■ (x , τ1) ⊢ d' :: τ2)) - canonical-value-forms-arr (TAVar x₁) () - canonical-value-forms-arr (TALam _ wt) VLam = _ , _ , refl , wt - canonical-value-forms-arr (TAAp wt wt₁) () - canonical-value-forms-arr (TAEHole x x₁) () - canonical-value-forms-arr (TANEHole x wt x₁) () - canonical-value-forms-arr (TACast wt x) () - canonical-value-forms-arr (TAFailedCast x x₁ x₂ x₃) () - - -- this argues (somewhat informally, because you still have to inspect - -- the types of the theorems above and manually verify this property) - -- that we didn't miss any cases above; this intentionally will make this - -- file fail to typecheck if we added more types, hopefully forcing us to - -- remember to add canonical forms lemmas as appropriate - canonical-value-forms-coverage1 : ∀{Δ d τ} → - Δ , ∅ ⊢ d :: τ → - d val → - τ ≠ b → - ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) → - ⊥ - canonical-value-forms-coverage1 TAConst VConst = λ z _ → z refl - canonical-value-forms-coverage1 (TAVar x₁) () - canonical-value-forms-coverage1 (TALam _ wt) VLam = λ _ z → z _ _ refl - canonical-value-forms-coverage1 (TAAp wt wt₁) () - canonical-value-forms-coverage1 (TAEHole x x₁) () - canonical-value-forms-coverage1 (TANEHole x wt x₁) () - canonical-value-forms-coverage1 (TACast wt x) () - canonical-value-forms-coverage1 (TAFailedCast wt x x₁ x₂) () - - canonical-value-forms-coverage2 : ∀{Δ d} → - Δ , ∅ ⊢ d :: ⦇-⦈ → - d val → - ⊥ - canonical-value-forms-coverage2 (TAVar x₁) () - canonical-value-forms-coverage2 (TAAp wt wt₁) () - canonical-value-forms-coverage2 (TAEHole x x₁) () - canonical-value-forms-coverage2 (TANEHole x wt x₁) () - canonical-value-forms-coverage2 (TACast wt x) () - canonical-value-forms-coverage2 (TAFailedCast wt x x₁ x₂) () diff --git a/cast-inert.agda b/cast-inert.agda deleted file mode 100644 index c0737c8..0000000 --- a/cast-inert.agda +++ /dev/null @@ -1,62 +0,0 @@ -open import Nat -open import Prelude -open import core -open import contexts -open import typed-elaboration -open import lemmas-gcomplete -open import lemmas-complete -open import progress-checks -open import finality - -module cast-inert where - -- if a term is compelete and well typed, then the casts inside are all - -- identity casts and there are no failed casts - cast-inert : ∀{Δ Γ d τ} → - d dcomplete → - Δ , Γ ⊢ d :: τ → - cast-id d - cast-inert dc TAConst = CIConst - cast-inert dc (TAVar x₁) = CIVar - cast-inert (DCLam dc x₁) (TALam x₂ wt) = CILam (cast-inert dc wt) - cast-inert (DCAp dc dc₁) (TAAp wt wt₁) = CIAp (cast-inert dc wt) (cast-inert dc₁ wt₁) - cast-inert () (TAEHole x x₁) - cast-inert () (TANEHole x wt x₁) - cast-inert (DCCast dc x x₁) (TACast wt x₂) - with complete-consistency x₂ x x₁ - ... | refl = CICast (cast-inert dc wt) - cast-inert () (TAFailedCast wt x x₁ x₂) - - -- in a well typed complete internal expression, every cast is the - -- identity cast. - complete-casts : ∀{Γ Δ d τ1 τ2} → - Γ , Δ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 → - d ⟨ τ1 ⇒ τ2 ⟩ dcomplete → - τ1 == τ2 - complete-casts wt comp with cast-inert comp wt - complete-casts wt comp | CICast qq = refl - - -- relates expressions to the same thing with all identity casts - -- removed. note that this is a syntactic rewrite and it goes under - -- binders. - data no-id-casts : ihexp → ihexp → Set where - NICConst : no-id-casts c c - NICVar : ∀{x} → no-id-casts (X x) (X x) - NICLam : ∀{x τ d d'} → no-id-casts d d' → no-id-casts (·λ x [ τ ] d) (·λ x [ τ ] d') - NICHole : ∀{u} → no-id-casts (⦇-⦈⟨ u ⟩) (⦇-⦈⟨ u ⟩) - NICNEHole : ∀{d d' u} → no-id-casts d d' → no-id-casts (⦇⌜ d ⌟⦈⟨ u ⟩) (⦇⌜ d' ⌟⦈⟨ u ⟩) - NICAp : ∀{d1 d2 d1' d2'} → no-id-casts d1 d1' → no-id-casts d2 d2' → no-id-casts (d1 ∘ d2) (d1' ∘ d2') - NICCast : ∀{d d' τ} → no-id-casts d d' → no-id-casts (d ⟨ τ ⇒ τ ⟩) d' - NICFailed : ∀{d d' τ1 τ2} → no-id-casts d d' → no-id-casts (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) (d' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) - - -- removing identity casts doesn't change the type - no-id-casts-type : ∀{Γ Δ d τ d' } → Δ , Γ ⊢ d :: τ → - no-id-casts d d' → - Δ , Γ ⊢ d' :: τ - no-id-casts-type TAConst NICConst = TAConst - no-id-casts-type (TAVar x₁) NICVar = TAVar x₁ - no-id-casts-type (TALam x₁ wt) (NICLam nic) = TALam x₁ (no-id-casts-type wt nic) - no-id-casts-type (TAAp wt wt₁) (NICAp nic nic₁) = TAAp (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁) - no-id-casts-type (TAEHole x x₁) NICHole = TAEHole x x₁ - no-id-casts-type (TANEHole x wt x₁) (NICNEHole nic) = TANEHole x (no-id-casts-type wt nic) x₁ - no-id-casts-type (TACast wt x) (NICCast nic) = no-id-casts-type wt nic - no-id-casts-type (TAFailedCast wt x x₁ x₂) (NICFailed nic) = TAFailedCast (no-id-casts-type wt nic) x x₁ x₂ diff --git a/check.sh b/check.sh deleted file mode 100755 index c6280d3..0000000 --- a/check.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/bash - -## display the difference between the sorted listing of all agda files in -## the directory and the names of modules imported (commented out or not) -## in all.agda - -colordiff -u <(ls *.agda | xargs basename -s '.agda' | sort | grep -v 'all') <(cat all.agda | gsed 's/\s*--\s*//' | gsed 's/\s*open\s*import\s*//' | gsed '/^$/d' | sort) diff --git a/complete-elaboration.agda b/complete-elaboration.agda index f58d226..2981adc 100644 --- a/complete-elaboration.agda +++ b/complete-elaboration.agda @@ -1,57 +1,67 @@ open import Nat open import Prelude +open import core-type +open import core-exp open import core -open import contexts -open import typed-elaboration -open import lemmas-gcomplete open import lemmas-complete module complete-elaboration where + + comp-synth : ∀{Γ e τ} → + Γ gcomplete → + e ecomplete → + Γ ⊢ e => τ → + τ tcomplete + comp-synth gc ECConst SConst = TCBase + comp-synth gc (ECAsc x ec) (SAsc x₁ x₂) = x + comp-synth gc ECVar (SVar x) = inctx-complete gc x + comp-synth gc (ECLam1 ec) () + comp-synth gc (ECLam2 ec x) (SLam x₁ syn) = TCArr x (comp-synth (GCVar gc x) ec syn) + comp-synth gc (ECTLam ec) (STLam syn) = TCForall (comp-synth (GCTVar gc) ec syn) + comp-synth gc (ECAp ec ec₁) (SAp syn meet x₁) with meet-complete (comp-synth gc ec syn) meet + ... | TCArr tc tc₁ = tc₁ + comp-synth gc (ECTAp x ec) (STAp x₁ syn meet refl) with meet-complete (comp-synth gc ec syn) meet + ... | TCForall tc = TTSub-complete x tc + + mutual - complete-elaboration-synth : ∀{e τ Γ Δ d} → - Γ gcomplete → - e ecomplete → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - (d dcomplete × τ tcomplete × Δ == ∅) - complete-elaboration-synth gc ec ESConst = DCConst , TCBase , refl - complete-elaboration-synth gc ec (ESVar x₁) = DCVar , gc _ _ x₁ , refl - complete-elaboration-synth gc (ECLam2 ec x₁) (ESLam x₂ exp) - with complete-elaboration-synth (gcomp-extend gc x₁ x₂) ec exp - ... | ih1 , ih2 , ih3 = DCLam ih1 x₁ , TCArr x₁ ih2 , ih3 - complete-elaboration-synth gc (ECAp ec ec₁) (ESAp _ _ x MAHole x₂ x₃) - with comp-synth gc ec x - ... | () - complete-elaboration-synth gc (ECAp ec ec₁) (ESAp {Δ1 = Δ1} {Δ2 = Δ2} _ _ x MAArr x₂ x₃) - with comp-synth gc ec x - ... | TCArr t1 t2 - with complete-elaboration-ana gc ec (TCArr t1 t2) x₂ | complete-elaboration-ana gc ec₁ t1 x₃ - ... | ih1 , _ , ih4 | ih2 , _ , ih3 = DCAp (DCCast ih1 (comp-ana gc x₂ ih1) (TCArr t1 t2)) (DCCast ih2 (comp-ana gc x₃ ih2) t1) , - t2 , - tr (λ qq → (qq ∪ Δ2) == ∅) (! ih4) (tr (λ qq → (∅ ∪ qq) == ∅) (! ih3) refl) + complete-elaboration-synth : ∀{e τ Γ d} → + Γ gcomplete → + e ecomplete → + Γ ⊢ e ⇒ τ ~> d → + (d dcomplete × τ tcomplete) + + complete-elaboration-synth gc ec ESConst = DCConst , TCBase + complete-elaboration-synth gc ec (ESVar inctx) = DCVar , inctx-complete gc inctx + complete-elaboration-synth gc (ECLam2 ec tc) (ESLam wf elab) with complete-elaboration-synth (GCVar gc tc) ec elab + ... | dc' , tc' = (DCLam dc' tc) , TCArr tc tc' + complete-elaboration-synth gc (ECAp ec ec₁) (ESAp syn meet ana1 ana2) with meet-complete (comp-synth gc ec syn) meet + ... | TCArr tc1 tc2 with complete-elaboration-ana gc ec (TCArr tc1 tc2) ana1 + ... | dc' , tc' with complete-elaboration-ana gc ec₁ tc1 ana2 + ... | dc'' , tc'' = (DCAp (DCCast dc' tc' (TCArr tc1 tc2)) (DCCast dc'' tc'' tc1)) , tc2 complete-elaboration-synth gc () ESEHole - complete-elaboration-synth gc () (ESNEHole _ exp) - complete-elaboration-synth gc (ECAsc x ec) (ESAsc x₁) + complete-elaboration-synth gc () (ESNEHole exp) + complete-elaboration-synth gc (ECAsc x ec) (ESAsc wf x₁) with complete-elaboration-ana gc ec x x₁ - ... | ih1 , _ , ih2 = DCCast ih1 (comp-ana gc x₁ ih1) x , x , ih2 - - complete-elaboration-ana : ∀{e τ τ' Γ Δ d} → - Γ gcomplete → - e ecomplete → - τ tcomplete → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - (d dcomplete × τ' tcomplete × Δ == ∅) - complete-elaboration-ana gc (ECLam1 ec) () (EALam x₁ MAHole exp) - complete-elaboration-ana gc (ECLam1 ec) (TCArr t1 t2) (EALam x₁ MAArr exp) - with complete-elaboration-ana (gcomp-extend gc t1 x₁) ec t2 exp - ... | ih , ih3 , ih2 = DCLam ih t1 , TCArr t1 ih3 , ih2 - complete-elaboration-ana gc ec tc (EASubsume x x₁ x₂ x₃) - with complete-elaboration-synth gc ec x₂ - ... | ih1 , ih2 , ih3 = ih1 , ih2 , ih3 + ... | dc' , tc' = DCCast dc' tc' x , x + complete-elaboration-synth gc (ECTLam ec) (ESTLam elab) with complete-elaboration-synth (GCTVar gc) ec elab + ... | dc' , tc' = DCTLam dc' , TCForall tc' + complete-elaboration-synth gc (ECTAp ec tc) (ESTAp wf syn meet ana refl) with meet-complete (comp-synth gc tc syn) meet + ... | TCForall tc'' with complete-elaboration-ana gc tc (TCForall tc'') ana + ... | thing = (DCTAp ec (DCCast (π1 thing) (π2 thing) (TCForall tc''))) , TTSub-complete ec tc'' - -- this is just a convenience since it shows up a few times above - comp-ana : ∀{Γ e τ d τ' Δ} → - Γ gcomplete → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - d dcomplete → - τ' tcomplete - comp-ana gc ex dc = complete-ta gc (π2 (typed-elaboration-ana ex)) dc + complete-elaboration-ana : ∀{e τ τ' Γ d} → + Γ gcomplete → + e ecomplete → + τ tcomplete → + Γ ⊢ e ⇐ τ ~> d :: τ' → + (d dcomplete × τ' tcomplete) + + complete-elaboration-ana gc (ECLam1 ec) tc (EALam meet ana) with meet-complete tc meet + ... | TCArr tc1 tc2 with complete-elaboration-ana (GCVar gc tc1) ec tc2 ana + ... | dc' , tc' = DCLam dc' tc1 , TCArr tc1 tc' + complete-elaboration-ana gc ec tc (EASubsume x syn meet) with complete-elaboration-synth gc ec syn | meet-complete tc meet + ... | dc' , tc' | tc'' = DCCast dc' tc' tc'' , tc'' + complete-elaboration-ana x (ECTLam x₂) x₁ (EATLam meet ana) with meet-complete x₁ meet + ... | TCForall tc with complete-elaboration-ana (GCTVar x) x₂ tc ana + ... | dc , tc' = DCTLam dc , TCForall tc' diff --git a/complete-preservation.agda b/complete-preservation.agda index 9f1252e..c695900 100644 --- a/complete-preservation.agda +++ b/complete-preservation.agda @@ -1,67 +1,63 @@ open import Nat open import Prelude +open import core-type open import core -open import contexts -open import preservation +open import lemmas-consistency +open import lemmas-wf +open import lemmas-subst +open import lemmas-complete module complete-preservation where - -- if you substitute a complete term into a complete term, the result is - -- still complete. - cp-subst : ∀ {x d1 d2} → - d1 dcomplete → - d2 dcomplete → - ([ d2 / x ] d1) dcomplete - cp-subst {x = y} (DCVar {x = x}) dc2 with natEQ x y - cp-subst DCVar dc2 | Inl refl = dc2 - cp-subst DCVar dc2 | Inr x₂ = DCVar - cp-subst DCConst dc2 = DCConst - cp-subst {x = x} (DCLam {x = y} dc1 x₂) dc2 with natEQ y x - cp-subst (DCLam dc1 x₃) dc2 | Inl refl = DCLam dc1 x₃ - cp-subst (DCLam dc1 x₃) dc2 | Inr x₂ = DCLam (cp-subst dc1 dc2) x₃ - cp-subst (DCAp dc1 dc2) dc3 = DCAp (cp-subst dc1 dc3) (cp-subst dc2 dc3) - cp-subst (DCCast dc1 x₁ x₂) dc2 = DCCast (cp-subst dc1 dc2) x₁ x₂ - -- this just lets me pull the particular x out of a derivation; it's not - -- bound in any of the constructors explicitly since it's only in the - -- lambda case; so below i have no idea how else to get a name for it, - -- instead of leaving it dotted in the context - lem-proj : {x : Nat} {d : ihexp} { τ : htyp} → (·λ_[_]_ x τ d) dcomplete → Σ[ y ∈ Nat ] (y == x) - lem-proj {x} (DCLam dc x₁) = x , refl + complete-wt-filling : ∀{ ε Γ d τ d' } → + d dcomplete → + Γ ⊢ d :: τ → + d == ε ⟦ d' ⟧ → + Σ[ τ' ∈ htyp ] (Γ ⊢ d' :: τ' × d' dcomplete) + complete-wt-filling dc wt FHOuter = _ , wt , dc + complete-wt-filling (DCAp dc _) (TAAp wt _) (FHAp1 fill) = complete-wt-filling dc wt fill + complete-wt-filling (DCAp _ dc) (TAAp _ wt) (FHAp2 fill) = complete-wt-filling dc wt fill + complete-wt-filling (DCTAp _ dc) (TATAp _ wt _) (FHTAp fill) = complete-wt-filling dc wt fill + complete-wt-filling (DCCast dc _ _) (TACast wt _ _) (FHCast fill) = complete-wt-filling dc wt fill - -- a complete well typed term steps to a complete term. - cp-rhs : ∀{d τ d' Δ} → - d dcomplete → - Δ , ∅ ⊢ d :: τ → - d ↦ d' → - d' dcomplete - cp-rhs dc TAConst (Step FHOuter () FHOuter) - cp-rhs dc (TAVar x₁) stp = abort (somenotnone (! x₁)) - cp-rhs dc (TALam _ wt) (Step FHOuter () FHOuter) - -- this case is a little more complicated than it feels like it ought to - -- be, just from horsing around with agda implicit variables. - cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) with lem-proj dc - cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl with cp-subst {x = x} dc dc₁ - ... | qq with natEQ x x - cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl | DCLam qq x₁ | Inl refl = cp-subst qq dc₁ - cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl | qq | Inr x₁ = abort (x₁ refl) - cp-rhs (DCAp (DCCast dc (TCArr x x₁) (TCArr x₂ x₃)) dc₁) (TAAp (TACast wt x₄) wt₁) (Step FHOuter ITApCast FHOuter) = DCCast (DCAp dc (DCCast dc₁ x₂ x)) x₁ x₃ - cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step (FHAp1 x) x₁ (FHAp1 x₂)) = DCAp (cp-rhs dc wt (Step x x₁ x₂)) dc₁ - cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step (FHAp2 x) x₁ (FHAp2 x₂)) = DCAp dc (cp-rhs dc₁ wt₁ (Step x x₁ x₂)) - cp-rhs () (TAEHole x x₁) stp - cp-rhs () (TANEHole x wt x₁) stp - cp-rhs (DCCast dc x x₁) (TACast wt x₂) (Step FHOuter ITCastID FHOuter) = dc - cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITCastSucceed x₃) FHOuter) - cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITCastFail x₃ x₄ x₅) FHOuter) - cp-rhs (DCCast dc x ()) (TACast wt x₂) (Step FHOuter (ITGround x₃) FHOuter) - cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITExpand x₃) FHOuter) - cp-rhs (DCCast dc x x₁) (TACast wt x₂) (Step (FHCast x₃) x₄ (FHCast x₅)) = DCCast (cp-rhs dc wt (Step x₃ x₄ x₅)) x x₁ - cp-rhs () (TAFailedCast wt x x₁ x₂) stp + complete-wt-different-fill : ∀{d ε d1 d2 d'} → + d dcomplete → + d2 dcomplete → + d == ε ⟦ d1 ⟧ → + d' == ε ⟦ d2 ⟧ → + d' dcomplete + complete-wt-different-fill dc1 dc2 FHOuter FHOuter = dc2 + complete-wt-different-fill (DCAp dc1 dc3) dc2 (FHAp1 fill1) (FHAp1 fill2) = DCAp (complete-wt-different-fill dc1 dc2 fill1 fill2) dc3 + complete-wt-different-fill (DCAp dc1 dc3) dc2 (FHAp2 fill1) (FHAp2 fill2) = DCAp dc1 (complete-wt-different-fill dc3 dc2 fill1 fill2) + complete-wt-different-fill (DCTAp tc dc1) dc2 (FHTAp fill1) (FHTAp fill2) = DCTAp tc (complete-wt-different-fill dc1 dc2 fill1 fill2) + complete-wt-different-fill (DCCast dc1 tc1 tc2) dc2 (FHCast fill1) (FHCast fill2) = DCCast (complete-wt-different-fill dc1 dc2 fill1 fill2) tc1 tc2 - -- this is the main result of this file. - complete-preservation : ∀{d τ d' Δ} → - binders-unique d → - d dcomplete → - Δ , ∅ ⊢ d :: τ → - d ↦ d' → - (Δ , ∅ ⊢ d' :: τ) × (d' dcomplete) - complete-preservation bd dc wt stp = preservation bd wt stp , cp-rhs dc wt stp + complete-preservation-trans : ∀{d τ d'} → + d dcomplete → + ∅ ⊢ d :: τ → + d →> d' → + d' dcomplete + complete-preservation-trans _ TAConst () + complete-preservation-trans _ TAEHole () + complete-preservation-trans _ (TAVar _) () + complete-preservation-trans _ (TALam _ _) () + complete-preservation-trans _ (TATLam _) () + complete-preservation-trans _ (TANEHole _) () + complete-preservation-trans (DCCast dc _ _) _ ITCastID = dc + complete-preservation-trans (DCCast _ () _) _ (ITCastSucceed _) + complete-preservation-trans (DCCast _ () _) _ (ITCastFail _ _ _) + complete-preservation-trans (DCCast _ _ ()) _ (ITGround _) + complete-preservation-trans (DCCast _ () _) _ (ITExpand _) + complete-preservation-trans _ (TAFailedCast _ _ _ _) () + complete-preservation-trans (DCTAp tc (DCTLam dc)) _ ITTLam = TtSub-complete tc dc + complete-preservation-trans (DCAp (DCLam dc1 _) dc2) _ ITLam = ttSub-complete dc2 dc1 + complete-preservation-trans (DCAp (DCCast dc1 (TCArr tc1 tc2) (TCArr tc3 tc4)) dc2) _ ITApCast = DCCast (DCAp dc1 (DCCast dc2 tc3 tc1)) tc2 tc4 + complete-preservation-trans (DCTAp tc1 (DCCast dc (TCForall tc2) (TCForall tc3))) _ ITTApCast = DCCast (DCTAp tc1 dc) (TTSub-complete tc1 tc2) (TTSub-complete tc1 tc3) + + complete-preservation : ∀{d τ d'} → + d dcomplete → + ∅ ⊢ d :: τ → + d ↦ d' → + d' dcomplete + complete-preservation dc wt (Step fill1 trans fill2) with complete-wt-filling dc wt fill1 + ... | _ , wt' , dc' = complete-wt-different-fill dc (complete-preservation-trans dc' wt' trans) fill1 fill2 \ No newline at end of file diff --git a/complete-progress.agda b/complete-progress.agda index 16959b2..24c0b1c 100644 --- a/complete-progress.agda +++ b/complete-progress.agda @@ -1,27 +1,26 @@ open import Nat open import Prelude +open import core-type +open import core-exp open import core -open import contexts - open import progress -open import htype-decidable + open import lemmas-complete module complete-progress where - -- as in progress, we define a datatype for the possible outcomes of - -- progress for readability. - data okc : (d : ihexp) (Δ : hctx) → Set where - V : ∀{d Δ} → d val → okc d Δ - S : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → okc d Δ + data okc : (d : ihexp) → Set where + V : ∀{d} → d val → okc d + S : ∀{d} → Σ[ d' ∈ ihexp ] (d ↦ d') → okc d - complete-progress : {Δ : hctx} {d : ihexp} {τ : htyp} → - Δ , ∅ ⊢ d :: τ → - d dcomplete → - okc d Δ + complete-progress : {d : ihexp} {τ : htyp} → + ∅ ⊢ d :: τ → + d dcomplete → + okc d complete-progress wt comp with progress wt - complete-progress wt comp | I x = abort (lem-ind-comp comp x) - complete-progress wt comp | S x = S x - complete-progress wt comp | BV (BVVal x) = V x - complete-progress wt (DCCast comp x₂ ()) | BV (BVHoleCast x x₁) - complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVArrCast x₁ x₂) = abort (x₁ (complete-consistency x x₃ x₄)) + complete-progress wt comp | I ind = abort (complete-indet comp ind) + complete-progress wt comp | S step = S step + complete-progress wt comp | BV (BVVal v) = V v + complete-progress wt (DCCast _ _ ()) | BV (BVHoleCast _ _) + complete-progress (TACast _ _ con) (DCCast _ tc1 tc2) | BV (BVArrCast neq _) = abort (neq (complete-consistency con tc1 tc2)) + complete-progress (TACast _ _ con) (DCCast _ tc1 tc2) | BV (BVForallCast neq _) = abort (neq (complete-consistency con tc1 tc2)) \ No newline at end of file diff --git a/contexts.agda b/contexts.agda deleted file mode 100644 index 286d53b..0000000 --- a/contexts.agda +++ /dev/null @@ -1,304 +0,0 @@ -open import Prelude -open import Nat - -module contexts where - -- variables are named with naturals in ė. therefore we represent - -- contexts as functions from names for variables (nats) to possible - -- bindings. - _ctx : Set → Set - A ctx = Nat → Maybe A - - -- convenient shorthand for the (unique up to fun. ext.) empty context - ∅ : {A : Set} → A ctx - ∅ _ = None - - infixr 100 ■_ - - -- the domain of a context is those naturals which cuase it to emit some τ - dom : {A : Set} → A ctx → Nat → Set - dom {A} Γ x = Σ[ τ ∈ A ] (Γ x == Some τ) - - -- membership, or presence, in a context - _∈_ : {A : Set} (p : Nat × A) → (Γ : A ctx) → Set - (x , y) ∈ Γ = (Γ x) == Some y - - -- this packages up an appeal to context memebership into a form that - -- lets us retain more information - ctxindirect : {A : Set} (Γ : A ctx) (n : Nat) → Σ[ a ∈ A ] (Γ n == Some a) + Γ n == None - ctxindirect Γ n with Γ n - ctxindirect Γ n | Some x = Inl (x , refl) - ctxindirect Γ n | None = Inr refl - - -- apartness for contexts - _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set - x # Γ = (Γ x) == None - - -- disjoint contexts are those which share no mappings - _##_ : {A : Set} → A ctx → A ctx → Set - _##_ {A} Γ Γ' = ((n : Nat) → dom Γ n → n # Γ') × ((n : Nat) → dom Γ' n → n # Γ) - - -- contexts give at most one binding for each variable - ctxunicity : {A : Set} → {Γ : A ctx} {n : Nat} {t t' : A} → - (n , t) ∈ Γ → - (n , t') ∈ Γ → - t == t' - ctxunicity {n = n} p q with natEQ n n - ctxunicity p q | Inl refl = someinj (! p · q) - ctxunicity _ _ | Inr x≠x = abort (x≠x refl) - - -- warning: this is union, but it assumes WITHOUT CHECKING that the - -- domains are disjoint. this is inherently asymmetric, and that's - -- reflected throughout the development that follows - _∪_ : {A : Set} → A ctx → A ctx → A ctx - (C1 ∪ C2) x with C1 x - (C1 ∪ C2) x | Some x₁ = Some x₁ - (C1 ∪ C2) x | None = C2 x - - -- the singleton context - ■_ : {A : Set} → (Nat × A) → A ctx - (■ (x , a)) y with natEQ x y - (■ (x , a)) .x | Inl refl = Some a - ... | Inr _ = None - - -- context extension - _,,_ : {A : Set} → A ctx → (Nat × A) → A ctx - (Γ ,, (x , t)) = Γ ∪ (■ (x , t)) - - infixl 10 _,,_ - - -- used below in proof of ∪ commutativity and associativity - lem-dom-union1 : {A : Set} {C1 C2 : A ctx} {x : Nat} → - C1 ## C2 → - dom C1 x → - (C1 ∪ C2) x == C1 x - lem-dom-union1 {A} {C1} {C2} {x} (d1 , d2) D with C1 x - lem-dom-union1 (d1 , d2) D | Some x₁ = refl - lem-dom-union1 (d1 , d2) D | None = abort (somenotnone (! (π2 D))) - - lem-dom-union2 : {A : Set} {C1 C2 : A ctx} {x : Nat} → - C1 ## C2 → - dom C1 x → - (C2 ∪ C1) x == C1 x - lem-dom-union2 {A} {C1} {C2} {x} (d1 , d2) D with ctxindirect C2 x - lem-dom-union2 {A} {C1} {C2} {x} (d1 , d2) D | Inl x₁ = abort (somenotnone (! (π2 x₁) · d1 x D )) - lem-dom-union2 {A} {C1} {C2} {x} (d1 , d2) D | Inr x₁ with C2 x - lem-dom-union2 (d1 , d2) D | Inr x₂ | Some x₁ = abort (somenotnone x₂) - lem-dom-union2 (d1 , d2) D | Inr x₁ | None = refl - - -- if the contexts in question are disjoint, then union is commutative - ∪comm : {A : Set} → (C1 C2 : A ctx) → C1 ## C2 → (C1 ∪ C2) == (C2 ∪ C1) - ∪comm C1 C2 (d1 , d2)= funext guts - where - lem-apart-union1 : {A : Set} (C1 C2 : A ctx) (x : Nat) → x # C1 → x # C2 → x # (C1 ∪ C2) - lem-apart-union1 C1 C2 x apt1 apt2 with C1 x - lem-apart-union1 C1 C2 x apt1 apt2 | Some x₁ = abort (somenotnone apt1) - lem-apart-union1 C1 C2 x apt1 apt2 | None = apt2 - - lem-apart-union2 : {A : Set} (C1 C2 : A ctx) (x : Nat) → x # C1 → x # C2 → x # (C2 ∪ C1) - lem-apart-union2 C1 C2 x apt1 apt2 with C2 x - lem-apart-union2 C1 C2 x apt1 apt2 | Some x₁ = abort (somenotnone apt2) - lem-apart-union2 C1 C2 x apt1 apt2 | None = apt1 - - guts : (x : Nat) → (C1 ∪ C2) x == (C2 ∪ C1) x - guts x with ctxindirect C1 x | ctxindirect C2 x - guts x | Inl (π1 , π2) | Inl (π3 , π4) = abort (somenotnone (! π4 · d1 x (π1 , π2))) - guts x | Inl x₁ | Inr x₂ = tr (λ qq → qq == (C2 ∪ C1) x) (! (lem-dom-union1 (d1 , d2) x₁)) (tr (λ qq → C1 x == qq) (! (lem-dom-union2 (d1 , d2) x₁)) refl) - guts x | Inr x₁ | Inl x₂ = tr (λ qq → (C1 ∪ C2) x == qq) (! (lem-dom-union1 (d2 , d1) x₂)) (tr (λ qq → qq == C2 x) (! (lem-dom-union2 (d2 , d1) x₂)) refl) - guts x | Inr x₁ | Inr x₂ = tr (λ qq → qq == (C2 ∪ C1) x) (! (lem-apart-union1 C1 C2 x x₁ x₂)) (tr (λ qq → None == qq) (! (lem-apart-union2 C1 C2 x x₁ x₂)) refl) - - - -- an element in the left of a union is in the union - x∈∪l : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ → (n , x) ∈ (Γ ∪ Γ') - x∈∪l Γ Γ' n x xin with Γ n - x∈∪l Γ Γ' n x₁ xin | Some x = xin - x∈∪l Γ Γ' n x () | None - - -- an element in the right of a union is in the union as long as the - -- contexts are disjoint; this asymmetry reflects the asymmetry in the - -- definition of union - x∈∪r : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → - (n , x) ∈ Γ' → - Γ' ## Γ → - (n , x) ∈ (Γ ∪ Γ') - x∈∪r Γ Γ' n x nx∈ disj = tr (λ qq → (n , x) ∈ qq) (∪comm _ _ disj) (x∈∪l Γ' Γ n x nx∈) - - -- an element is in the context formed with just itself - x∈■ : {A : Set} (n : Nat) (a : A) → (n , a) ∈ (■ (n , a)) - x∈■ n a with natEQ n n - x∈■ n a | Inl refl = refl - x∈■ n a | Inr x = abort (x refl) - - -- if an index is in the domain of a singleton context, it's the only - -- index in the context - lem-dom-eq : {A : Set} {y : A} {n m : Nat} → - dom (■ (m , y)) n → - n == m - lem-dom-eq {n = n} {m = m} (π1 , π2) with natEQ m n - lem-dom-eq (π1 , π2) | Inl refl = refl - lem-dom-eq (π1 , π2) | Inr x = abort (somenotnone (! π2)) - - -- a singleton context formed with an index apart from a context is - -- disjoint from that context - lem-apart-sing-disj : {A : Set} {n : Nat} {a : A} {Γ : A ctx} → - n # Γ → - (■ (n , a)) ## Γ - lem-apart-sing-disj {A} {n} {a} {Γ} apt = asd1 , asd2 - where - asd1 : (n₁ : Nat) → dom (■ (n , a)) n₁ → n₁ # Γ - asd1 m d with lem-dom-eq d - asd1 .n d | refl = apt - - asd2 : (n₁ : Nat) → dom Γ n₁ → n₁ # (■ (n , a)) - asd2 m (π1 , π2) with natEQ n m - asd2 .n (π1 , π2) | Inl refl = abort (somenotnone (! π2 · apt )) - asd2 m (π1 , π2) | Inr x = refl - - -- the only index of a singleton context is in its domain - lem-domsingle : {A : Set} (p : Nat) (q : A) → dom (■ (p , q)) p - lem-domsingle p q with natEQ p p - lem-domsingle p q | Inl refl = q , refl - lem-domsingle p q | Inr x₁ = abort (x₁ refl) - - - -- dual of above - lem-disj-sing-apart : {A : Set} {n : Nat} {a : A} {Γ : A ctx} → - (■ (n , a)) ## Γ → - n # Γ - lem-disj-sing-apart {A} {n} {a} {Γ} (d1 , d2) = d1 n (lem-domsingle n a) - - -- the singleton context can only produce one non-none result - lem-insingeq : {A : Set} {x x' : Nat} {τ τ' : A} → - (■ (x , τ)) x' == Some τ' → - τ == τ' - lem-insingeq {A} {x} {x'} {τ} {τ'} eq with lem-dom-eq (τ' , eq) - lem-insingeq {A} {x} {.x} {τ} {τ'} eq | refl with natEQ x x - lem-insingeq refl | refl | Inl refl = refl - lem-insingeq eq | refl | Inr x₁ = abort (somenotnone (! eq)) - - -- if an index doesn't appear in a context, and the union of that context - -- with a singleton does produce a result, it must have come from the singleton - lem-apart-union-eq : {A : Set} {Γ : A ctx} {x x' : Nat} {τ τ' : A} → - x' # Γ → - (Γ ∪ ■ (x , τ)) x' == Some τ' → - τ == τ' - lem-apart-union-eq {A} {Γ} {x} {x'} {τ} {τ'} apart eq with Γ x' - lem-apart-union-eq apart eq | Some x = abort (somenotnone apart) - lem-apart-union-eq apart eq | None = lem-insingeq eq - - -- if an index not in a singleton context produces a result from that - -- singleton unioned with another context, the result must have come from - -- the other context - lem-neq-union-eq : {A : Set} {Γ : A ctx} {x x' : Nat} {τ τ' : A} → - x' ≠ x → - (Γ ∪ ■ (x , τ)) x' == Some τ' → - Γ x' == Some τ' - lem-neq-union-eq {A} {Γ} {x} {x'} {τ} {τ'} neq eq with Γ x' - lem-neq-union-eq neq eq | Some x = eq - lem-neq-union-eq {A} {Γ} {x} {x'} {τ} {τ'} neq eq | None with natEQ x x' - lem-neq-union-eq neq eq | None | Inl x₁ = abort ((flip neq) x₁) - lem-neq-union-eq neq eq | None | Inr x₁ = abort (somenotnone (! eq)) - - -- extending a context with a new index produces the result paired with - -- that index. - ctx-top : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → - (n # Γ) → - (n , a) ∈ (Γ ,, (n , a)) - ctx-top Γ n a apt = x∈∪r Γ (■ (n , a)) n a (x∈■ n a) (lem-apart-sing-disj apt) - - -- if a union of a singleton and a ctx produces no result, the argument - -- index must be apart from the ctx and disequal to the index of the - -- singleton - lem-union-none : {A : Set} {Γ : A ctx} {a : A} {x x' : Nat} - → (Γ ∪ ■ (x , a)) x' == None - → (x ≠ x') × (x' # Γ) - lem-union-none {A} {Γ} {a} {x} {x'} emp with ctxindirect Γ x' - lem-union-none {A} {Γ} {a} {x} {x'} emp | Inl (π1 , π2) with Γ x' - lem-union-none emp | Inl (π1 , π2) | Some x = abort (somenotnone emp) - lem-union-none {A} {Γ} {a} {x} {x'} emp | Inl (π1 , π2) | None with natEQ x x' - lem-union-none emp | Inl (π1 , π2) | None | Inl x₁ = abort (somenotnone (! π2)) - lem-union-none emp | Inl (π1 , π2) | None | Inr x₁ = x₁ , refl - lem-union-none {A} {Γ} {a} {x} {x'} emp | Inr y with Γ x' - lem-union-none emp | Inr y | Some x = abort (somenotnone emp) - lem-union-none {A} {Γ} {a} {x} {x'} emp | Inr y | None with natEQ x x' - lem-union-none emp | Inr y | None | Inl refl = abort (somenotnone emp) - lem-union-none emp | Inr y | None | Inr x₁ = x₁ , refl - - - --- lemmas building up to a proof of associativity of ∪ - ctxignore1 : {A : Set} (x : Nat) (C1 C2 : A ctx) → x # C1 → (C1 ∪ C2) x == C2 x - ctxignore1 x C1 C2 apt with ctxindirect C1 x - ctxignore1 x C1 C2 apt | Inl x₁ = abort (somenotnone (! (π2 x₁) · apt)) - ctxignore1 x C1 C2 apt | Inr x₁ with C1 x - ctxignore1 x C1 C2 apt | Inr x₂ | Some x₁ = abort (somenotnone (x₂)) - ctxignore1 x C1 C2 apt | Inr x₁ | None = refl - - ctxignore2 : {A : Set} (x : Nat) (C1 C2 : A ctx) → x # C2 → (C1 ∪ C2) x == C1 x - ctxignore2 x C1 C2 apt with ctxindirect C2 x - ctxignore2 x C1 C2 apt | Inl x₁ = abort (somenotnone (! (π2 x₁) · apt)) - ctxignore2 x C1 C2 apt | Inr x₁ with C1 x - ctxignore2 x C1 C2 apt | Inr x₂ | Some x₁ = refl - ctxignore2 x C1 C2 apt | Inr x₁ | None = x₁ - - ctxcollapse1 : {A : Set} → (C1 C2 C3 : A ctx) (x : Nat) → - (x # C3) → - (C2 ∪ C3) x == C2 x → - (C1 ∪ (C2 ∪ C3)) x == (C1 ∪ C2) x - ctxcollapse1 C1 C2 C3 x apt eq with C2 x - ctxcollapse1 C1 C2 C3 x apt eq | Some x₁ with C1 x - ctxcollapse1 C1 C2 C3 x apt eq | Some x₂ | Some x₁ = refl - ctxcollapse1 C1 C2 C3 x apt eq | Some x₁ | None with C2 x - ctxcollapse1 C1 C2 C3 x apt eq | Some x₂ | None | Some x₁ = refl - ctxcollapse1 C1 C2 C3 x apt eq | Some x₁ | None | None = apt - ctxcollapse1 C1 C2 C3 x apt eq | None with C1 x - ctxcollapse1 C1 C2 C3 x apt eq | None | Some x₁ = refl - ctxcollapse1 C1 C2 C3 x apt eq | None | None with C2 x - ctxcollapse1 C1 C2 C3 x apt eq | None | None | Some x₁ = refl - ctxcollapse1 C1 C2 C3 x apt eq | None | None | None = eq - - ctxcollapse2 : {A : Set} → (C1 C2 C3 : A ctx) (x : Nat) → - (x # C2) → - (C2 ∪ C3) x == C3 x → - (C1 ∪ (C2 ∪ C3)) x == (C1 ∪ C3) x - ctxcollapse2 C1 C2 C3 x apt eq with C1 x - ctxcollapse2 C1 C2 C3 x apt eq | Some x₁ = refl - ctxcollapse2 C1 C2 C3 x apt eq | None with C2 x - ctxcollapse2 C1 C2 C3 x apt eq | None | Some x₁ = eq - ctxcollapse2 C1 C2 C3 x apt eq | None | None = refl - - ctxcollapse3 : {A : Set} → (C1 C2 C3 : A ctx) (x : Nat) → - (x # C2) → - ((C1 ∪ C2) ∪ C3) x == (C1 ∪ C3) x - ctxcollapse3 C1 C2 C3 x apt with C1 x - ctxcollapse3 C1 C2 C3 x apt | Some x₁ = refl - ctxcollapse3 C1 C2 C3 x apt | None with C2 x - ctxcollapse3 C1 C2 C3 x apt | None | Some x₁ = abort (somenotnone apt) - ctxcollapse3 C1 C2 C3 x apt | None | None = refl - - ∪assoc : {A : Set} (C1 C2 C3 : A ctx) → (C2 ## C3) → (C1 ∪ C2) ∪ C3 == C1 ∪ (C2 ∪ C3) - ∪assoc C1 C2 C3 (d1 , d2) = funext guts - where - case2 : (x : Nat) → x # C3 → dom C2 x → ((C1 ∪ C2) ∪ C3) x == (C1 ∪ (C2 ∪ C3)) x - case2 x apt dom = (ctxignore2 x (C1 ∪ C2) C3 apt) · - ! (ctxcollapse1 C1 C2 C3 x apt (lem-dom-union1 (d1 , d2) dom)) - - case34 : (x : Nat) → x # C2 → ((C1 ∪ C2) ∪ C3) x == (C1 ∪ (C2 ∪ C3)) x - case34 x apt = ctxcollapse3 C1 C2 C3 x apt · - ! (ctxcollapse2 C1 C2 C3 x apt (ctxignore1 x C2 C3 apt)) - - guts : (x : Nat) → ((C1 ∪ C2) ∪ C3) x == (C1 ∪ (C2 ∪ C3)) x - guts x with ctxindirect C2 x | ctxindirect C3 x - guts x | Inl (π1 , π2) | Inl (π3 , π4) = abort (somenotnone (! π4 · d1 x (π1 , π2))) - guts x | Inl x₁ | Inr x₂ = case2 x x₂ x₁ - guts x | Inr x₁ | Inl x₂ = case34 x x₁ - guts x | Inr x₁ | Inr x₂ = case34 x x₁ - - -- if x is apart from either part of a union, the answer comes from the other one - lem-dom-union-apt1 : {A : Set} {Δ1 Δ2 : A ctx} {x : Nat} {y : A} → x # Δ1 → ((Δ1 ∪ Δ2) x == Some y) → (Δ2 x == Some y) - lem-dom-union-apt1 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x - lem-dom-union-apt1 apt xin | Some x₁ = abort (somenotnone apt) - lem-dom-union-apt1 apt xin | None = xin - - lem-dom-union-apt2 : {A : Set} {Δ1 Δ2 : A ctx} {x : Nat} {y : A} → x # Δ2 → ((Δ1 ∪ Δ2) x == Some y) → (Δ1 x == Some y) - lem-dom-union-apt2 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x - lem-dom-union-apt2 apt xin | Some x₁ = xin - lem-dom-union-apt2 apt xin | None = abort (somenotnone (! xin · apt)) diff --git a/continuity.agda b/continuity.agda deleted file mode 100644 index 5e799f5..0000000 --- a/continuity.agda +++ /dev/null @@ -1,57 +0,0 @@ -open import Nat -open import Prelude -open import core -open import contexts - -open import progress -open import preservation -open import elaborability -open import typed-elaboration - -module continuity where - -- we take the sensibilty theorem as a postulate; for a proof, refer to - -- the POPL17 mechanization. we also postulate some glue that allows us - -- to use our theorems here on the shape of results from that work. - postulate - action : Set - zexp : Set - _◆ : zexp → hexp - _⊢_=>_~_~>_=>_ : (Γ : tctx) → (e1 : zexp) → (t1 : htyp) - → (α : action) → (e2 : zexp) → (t2 : htyp) → Set - sensibility : {Γ : tctx} {e e' : zexp} {τ τ' : htyp} {α : action} → - Γ ⊢ (e ◆) => τ → - Γ ⊢ e => τ ~ α ~> e' => τ' → - Γ ⊢ (e' ◆) => τ' - binders-unique-h : hexp → Set - binders-unique-z : zexp → Set - binders-unique-cursor1 : ∀{e} → binders-unique-z e → binders-unique-h (e ◆) - binders-unique-cursor2 : ∀{e} → binders-unique-h (e ◆) → binders-unique-z e - binders-unique-sensibility : {Γ : tctx} {e e' : zexp} {τ τ' : htyp} {α : action} → - binders-unique-z e → - Γ ⊢ e => τ ~ α ~> e' => τ' → - binders-unique-z e' - expansion-unique : ∀{Γ e τ d Δ} → - binders-unique-h e → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - binders-unique d - - - continuity : ∀{ e τ α e' τ' } - → binders-unique-z e - → ∅ ⊢ (e ◆) => τ - → ∅ ⊢ e => τ ~ α ~> e' => τ' - → Σ[ Δ ∈ hctx ] Σ[ d ∈ ihexp ] - ( ∅ ⊢ (e' ◆) ⇒ τ' ~> d ⊣ Δ - × Δ , ∅ ⊢ d :: τ' - × ( (Σ[ d' ∈ ihexp ]( d ↦ d' × Δ , ∅ ⊢ d' :: τ' )) - + d boxedval - + d indet - ) - ) - continuity bu wt action with sensibility wt action - ... | sense with elaborability-synth sense - ... | d , Δ , exp with typed-elaboration-synth exp - ... | d::τ' with progress d::τ' - ... | (S (d' , stp)) = Δ , d , exp , d::τ' , Inl (d' , stp , preservation (expansion-unique (binders-unique-cursor1 (binders-unique-sensibility bu action)) exp) d::τ' stp) - ... | (I ind) = Δ , d , exp , d::τ' , Inr (Inr ind) - ... | (BV boxed) = Δ , d , exp , d::τ' , Inr (Inl boxed) diff --git a/contraction.agda b/contraction.agda deleted file mode 100644 index 580842b..0000000 --- a/contraction.agda +++ /dev/null @@ -1,45 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import lemmas-disjointness - -module contraction where - -- in the same style as the proofs of exchange, this argument along with - -- trasnport allows you to prove contraction for all the hypothetical - -- judgements uniformly. we never explicitly use contraction anywhere, so - -- we omit any of the specific instances for concision; they are entirely - -- mechanical, as are the specific instances of exchange. one is shown - -- below as an example. - contract : {A : Set} {x : Nat} {τ : A} (Γ : A ctx) → - ((Γ ,, (x , τ)) ,, (x , τ)) == (Γ ,, (x , τ)) - contract {A} {x} {τ} Γ = funext guts - where - guts : (y : Nat) → (Γ ,, (x , τ) ,, (x , τ)) y == (Γ ,, (x , τ)) y - guts y with natEQ x y - guts .x | Inl refl with Γ x - guts .x | Inl refl | Some x₁ = refl - guts .x | Inl refl | None with natEQ x x - guts .x | Inl refl | None | Inl refl = refl - guts .x | Inl refl | None | Inr x₁ = abort (x₁ refl) - guts y | Inr x₁ with Γ y - guts y | Inr x₂ | Some x₁ = refl - guts y | Inr x₁ | None with natEQ x y - guts .x | Inr x₂ | None | Inl refl = refl - guts y | Inr x₂ | None | Inr x₁ with natEQ x y - guts .x | Inr x₃ | None | Inr x₂ | Inl refl = abort (x₃ refl) - guts y | Inr x₃ | None | Inr x₂ | Inr x₁ = refl - - contract-synth : ∀{ Γ x τ e τ'} - → (Γ ,, (x , τ) ,, (x , τ)) ⊢ e => τ' - → (Γ ,, (x , τ)) ⊢ e => τ' - contract-synth {Γ = Γ} {e = e} {τ' = τ'} = - tr (λ qq → qq ⊢ e => τ') (contract Γ) - - -- as an aside, this also establishes the other direction which is rarely - -- mentioned, since equality is symmetric - elab-synth : ∀{ Γ x τ e τ'} - → (Γ ,, (x , τ)) ⊢ e => τ' - → (Γ ,, (x , τ) ,, (x , τ)) ⊢ e => τ' - elab-synth {Γ = Γ} {e = e} {τ' = τ'} = - tr (λ qq → qq ⊢ e => τ') (! (contract Γ)) diff --git a/core-exp.agda b/core-exp.agda new file mode 100644 index 0000000..a2b4a6a --- /dev/null +++ b/core-exp.agda @@ -0,0 +1,121 @@ +open import Prelude +open import Nat +open import core-type + +module core-exp where + + -- external expressions + data hexp : Set where + c : hexp + _·:_ : hexp → htyp → hexp + X : Nat → hexp + ·λ : hexp → hexp + ·λ[_]_ : htyp → hexp → hexp + ·Λ : hexp → hexp + ⦇-⦈ : hexp + ⦇⌜_⌟⦈ : hexp → hexp + _∘_ : hexp → hexp → hexp + _<_> : hexp → htyp → hexp + + -- internal expressions + data ihexp : Set where + c : ihexp + X : Nat → ihexp + ·λ[_]_ : htyp → ihexp → ihexp + ·Λ : ihexp → ihexp + ⦇-⦈ : ihexp + ⦇⌜_⌟⦈ : ihexp → ihexp + _∘_ : ihexp → ihexp → ihexp + _<_> : ihexp → htyp → ihexp + _⟨_⇒_⟩ : ihexp → htyp → htyp → ihexp + _⟨_⇒⦇-⦈⇏_⟩ : ihexp → htyp → htyp → ihexp + + -- convenient notation for chaining together two agreeable casts + _⟨_⇒_⇒_⟩ : ihexp → htyp → htyp → htyp → ihexp + d ⟨ t1 ⇒ t2 ⇒ t3 ⟩ = d ⟨ t1 ⇒ t2 ⟩ ⟨ t2 ⇒ t3 ⟩ + + -- precision for external expressions + data _⊑_ : (e1 e2 : hexp) → Set where + PConst : c ⊑ c + PVar : ∀{n} → (X n) ⊑ (X n) + PAsc : ∀{e1 e2 τ1 τ2} → e1 ⊑ e2 → τ1 ⊑t τ2 → (e1 ·: τ1) ⊑ (e2 ·: τ2) + PEHole : ∀{e} → e ⊑ ⦇-⦈ + PLam1 : ∀{e1 e2} → e1 ⊑ e2 → (·λ e1) ⊑ (·λ e2) + PLam2 : ∀{e1 e2 τ1 τ2} → e1 ⊑ e2 → τ1 ⊑t τ2 → (·λ[ τ1 ] e1) ⊑ (·λ[ τ2 ] e2) + PTLam : ∀{e1 e2} → e1 ⊑ e2 → (·Λ e1) ⊑ (·Λ e2) + PNEHole : ∀{e1 e2} → e1 ⊑ e2 → (⦇⌜ e1 ⌟⦈) ⊑ (⦇⌜ e2 ⌟⦈) + PAp : ∀{e1 e2 e3 e4} → e1 ⊑ e3 → e2 ⊑ e4 → (e1 ∘ e2) ⊑ (e3 ∘ e4) + PTAp : ∀{e1 e2 τ1 τ2} → e1 ⊑ e2 → τ1 ⊑t τ2 → (e1 < τ1 >) ⊑ (e2 < τ2 >) + + data _subsumable : (e : hexp) → Set where + Subsumable : ∀{e} → ((e' : hexp) → e ≠ ·Λ e') → e subsumable + + -- values + data _val : (d : ihexp) → Set where + VConst : c val + VLam : ∀{τ d} → (·λ[ τ ] d) val + VTLam : ∀{d} → (·Λ d) val + + -- boxed values + data _boxedval : (d : ihexp) → Set where + BVVal : ∀{d} → + d val → + d boxedval + BVArrCast : ∀{ d τ1 τ2 τ3 τ4 } → + τ1 ==> τ2 ≠ τ3 ==> τ4 → + d boxedval → + d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ boxedval + BVForallCast : ∀{ d τ1 τ2 } → + (·∀ τ1) ≠ (·∀ τ2) → + d boxedval → + d ⟨ (·∀ τ1) ⇒ (·∀ τ2) ⟩ boxedval + BVHoleCast : ∀{ τ d } → + τ ground → + d boxedval → + d ⟨ τ ⇒ ⦇-⦈ ⟩ boxedval + + mutual + -- indeterminate forms + data _indet : (d : ihexp) → Set where + IEHole : ⦇-⦈ indet + INEHole : ∀{d} → + d final → + ⦇⌜ d ⌟⦈ indet + IAp : ∀{d1 d2} → + ((τ1 τ2 τ3 τ4 : htyp) (d1' : ihexp) → + d1 ≠ (d1' ⟨(τ1 ==> τ2) ⇒ (τ3 ==> τ4)⟩)) → + d1 indet → + d2 final → + (d1 ∘ d2) indet + ITAp : ∀{d τ} → + ((τ1 τ2 : htyp) (d' : ihexp) → d ≠ (d' ⟨(·∀ τ1) ⇒ (·∀ τ2)⟩)) → + d indet → + (d < τ >) indet + ICastArr : ∀{d τ1 τ2 τ3 τ4} → + τ1 ==> τ2 ≠ τ3 ==> τ4 → + d indet → + d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ indet + ICastForall : ∀{ d τ1 τ2 } → + (·∀ τ1) ≠ (·∀ τ2) → + d indet → + d ⟨ (·∀ τ1) ⇒ (·∀ τ2) ⟩ indet + ICastGroundHole : ∀{ τ d } → + τ ground → + d indet → + d ⟨ τ ⇒ ⦇-⦈ ⟩ indet + ICastHoleGround : ∀ { d τ } → + ((d' : ihexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇-⦈ ⟩)) → + d indet → + τ ground → + d ⟨ ⦇-⦈ ⇒ τ ⟩ indet + IFailedCast : ∀{ d τ1 τ2 } → + d final → + τ1 ground → + τ2 ground → + τ1 ≠ τ2 → + d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ indet + + -- final expressions + data _final : (d : ihexp) → Set where + FBoxedVal : ∀{d} → d boxedval → d final + FIndet : ∀{d} → d indet → d final \ No newline at end of file diff --git a/core-insert.agda b/core-insert.agda new file mode 100644 index 0000000..356d1e3 --- /dev/null +++ b/core-insert.agda @@ -0,0 +1,84 @@ + +open import Prelude +open import Nat +open import core-type +open import core-exp +open import core-subst +open import core + +module core-insert where + + data ∀□_~_ : htyp → htyp → Set where + PEForall : ∀{τ τ'} → + (∀□ (TTSub Z ⦇-⦈ τ) ~ τ') → + (∀□ (·∀ τ) ~ τ') + PEHole : ∀{τ'} → + (∀□ ⦇-⦈ ~ τ') + PENotMatch : ∀{τ τ'} → + (τ ~̸ (·∀ ⦇-⦈)) → + (τ ~ τ') → + (∀□ τ ~ τ') + + -- data _<=_↬_:_ : hexp → htyp → hexp → htyp → Set where + -- ITAp : ∀{τ τ'} → + -- (τ ~ τ') → + -- (τ ~ τ') → + -- (e <= τ ↬ e : τ) + -- IMatch : ∀{τ τ'} → + -- ((e < ⦇-⦈ >) => ? ↬ e' => τ' ~ τ) → + -- (e ↬ (e < τ2 >) => τ ~ τ) + + -- bidirectional cast insertion judgements + mutual + -- synthesis + data _⊢_=>_~>_ : (Γ : ctx) (e : hexp) (τ : htyp) (e' : hexp) → Set where + ISConst : ∀{Γ} → + Γ ⊢ c => b ~> c + ISVar : ∀{Γ x τ} → + x , τ ∈ Γ → + Γ ⊢ X x => τ ~> X x + ISLam : ∀{Γ τ1 τ2 e d} → + Γ ⊢ τ1 wf → + (τ1 , Γ) ⊢ e => τ2 ~> d → + Γ ⊢ (·λ[ τ1 ] e) => (τ1 ==> τ2) ~> (·λ[ τ1 ] d) + ISTLam : ∀{Γ e τ d} → + (TVar, Γ) ⊢ e => τ ~> d → + Γ ⊢ (·Λ e) => (·∀ τ) ~> (·Λ d) + ISAp : ∀{Γ e1 d1 e2 d2 τ1 τ1' τ2} → + Γ ⊢ e1 <= (⦇-⦈ ==> ⦇-⦈) ~> d1 :: (τ1 ==> τ2) → + Γ ⊢ e2 <= τ1 ~> d2 :: τ1' → + Γ ⊢ (e1 ∘ e2) => τ2 ~> (d1 ∘ d2) + ISTAp : ∀{Γ e τ1 τ2 τ3 d} → + Γ ⊢ τ1 wf → + Γ ⊢ e <= (·∀ ⦇-⦈) ~> d :: (·∀ τ2) → + TTSub Z τ1 τ2 == τ3 → + Γ ⊢ (e < τ1 >) => τ3 ~> (d < τ1 >) + ISEHole : ∀{Γ} → + Γ ⊢ ⦇-⦈ => ⦇-⦈ ~> ⦇-⦈ + ISNEHole : ∀{Γ e τ d} → + Γ ⊢ e => τ ~> d → + Γ ⊢ ⦇⌜ e ⌟⦈ => ⦇-⦈ ~> ⦇⌜ d ⌟⦈ + ISAsc : ∀ {Γ e τ d τ'} → + Γ ⊢ τ wf → + Γ ⊢ e <= τ ~> d :: τ' → + Γ ⊢ (e ·: τ) => τ ~> (d ·: τ') + + -- analysis : tau' must be more precise that tau + data _⊢_<=_~>_::_ : (Γ : ctx) (e : hexp) (τ : htyp) (e : hexp) (τ' : htyp) → Set where + IALam : ∀{Γ τ τ1 τ2 e d τ2'} → + τ ⊓ (⦇-⦈ ==> ⦇-⦈) == τ1 ==> τ2 → + (τ1 , Γ) ⊢ e <= τ2 ~> d :: τ2' → + Γ ⊢ ·λ e <= τ ~> ·λ[ τ1 ] d :: τ1 ==> τ2' + IATLam : ∀{Γ e τ1 τ2 τ2' d} → + τ1 ⊓ ·∀ ⦇-⦈ == (·∀ τ2) → + (TVar, Γ) ⊢ e <= τ2 ~> d :: τ2' → + Γ ⊢ (·Λ e) <= τ1 ~> (·Λ d) :: (·∀ τ2') + IASubsume : ∀{e Γ τ1 τ2 τ3 d} → + e subsumable → + Γ ⊢ e => τ2 ~> d → + τ1 ⊓ τ2 == τ3 → + (Γ ⊢ e <= τ1 ~> d :: τ3) + IAInsertTAp : ∀{e Γ τ1 τ2 d} → + e subsumable → + Γ ⊢ (e < ⦇-⦈ >) <= τ1 ~> d :: τ2 → + (Γ ⊢ e <= τ1 ~> d :: τ2) \ No newline at end of file diff --git a/core-subst.agda b/core-subst.agda new file mode 100644 index 0000000..67bc6ce --- /dev/null +++ b/core-subst.agda @@ -0,0 +1,100 @@ + +open import Prelude +open import Nat +open import core-type +open import core-exp + +module core-subst where + + -- [↑Nat threshold increase index] equals + -- [increase] + [index] if [index] >= [threshold] + -- else [index] + ↑Nat : (t i n : Nat) → Nat + ↑Nat Z Z n = n + ↑Nat Z (1+ i) n = 1+ (↑Nat Z i n) + ↑Nat (1+ t) i Z = Z + ↑Nat (1+ t) i (1+ n) = 1+ (↑Nat t i n) + + ↓Nat : (t d n : Nat) → Nat + ↓Nat Z Z x = x + ↓Nat Z (1+ d) Z = Z -- this case shouldn't happen + ↓Nat Z (1+ d) (1+ n) = ↓Nat Z d n + ↓Nat (1+ t) d Z = Z + ↓Nat (1+ t) d (1+ n) = 1+ (↓Nat t d n) + + -- [↑ threshold increase tau] equals + -- [tau] with all variables that are free + -- by a margin of at least [threshold] + -- increased by [increase] + ↑ : (t i : Nat) → htyp → htyp + ↑ t i (T x) = T (↑Nat t i x ) + ↑ t i b = b + ↑ t i ⦇-⦈ = ⦇-⦈ + ↑ t i (τ1 ==> τ2) = (↑ t i τ1) ==> (↑ t i τ2) + ↑ t i (·∀ τ) = ·∀ (↑ (1+ t) i τ) + + ↓ : Nat → Nat → htyp → htyp + ↓ t d (T x) = T (↓Nat t d x) + ↓ t d b = b + ↓ t d ⦇-⦈ = ⦇-⦈ + ↓ t d (τ1 ==> τ2) = (↓ t d τ1) ==> (↓ t d τ2) + ↓ t d (·∀ τ) = ·∀ (↓ (1+ t) d τ) + + ↑ctx : (t i : Nat) → ctx → ctx + ↑ctx t i ∅ = ∅ + ↑ctx t i (τ , ctx) = (↑ t i τ , ↑ctx t i ctx) + ↑ctx t i (TVar, ctx) = (TVar, ↑ctx (1+ t) i ctx) + + ↑d : (t1 n t2 m : Nat) → ihexp → ihexp + ↑d t1 n t2 m c = c + ↑d t1 n t2 m (X x) = X (↑Nat t1 n x) + ↑d t1 n t2 m (·λ[ τ ] d) = ·λ[ ↑ t2 m τ ] (↑d (1+ t1) n t2 m d) + ↑d t1 n t2 m (·Λ d) = ·Λ (↑d t1 n (1+ t2) m d) + ↑d t1 n t2 m ⦇-⦈ = ⦇-⦈ + ↑d t1 n t2 m ⦇⌜ d ⌟⦈ = ⦇⌜ ↑d t1 n t2 m d ⌟⦈ + ↑d t1 n t2 m (d1 ∘ d2) = (↑d t1 n t2 m d1) ∘ (↑d t1 n t2 m d2) + ↑d t1 n t2 m (d < τ >) = (↑d t1 n t2 m d) < ↑ t2 m τ > + ↑d t1 n t2 m (d ⟨ τ1 ⇒ τ2 ⟩) = (↑d t1 n t2 m d) ⟨ (↑ t2 m τ1) ⇒ (↑ t2 m τ2) ⟩ + ↑d t1 n t2 m (d ⟨ τ1 ⇒⦇-⦈⇏ τ3 ⟩) = (↑d t1 n t2 m d) ⟨ (↑ t2 m τ1) ⇒⦇-⦈⇏ (↑ t2 m τ3) ⟩ + + TTSub : Nat → htyp → htyp → htyp + TTSub n τ b = b + TTSub n τ ⦇-⦈ = ⦇-⦈ + TTSub n τ (τ1 ==> τ2) = (TTSub n τ τ1) ==> (TTSub n τ τ2) + TTSub n τ1 (·∀ τ2) = ·∀ (TTSub (1+ n) τ1 τ2) + TTSub n τ (T m) with natEQ n m + ... | Inl refl = ↓ n 1 (↑ Z (1+ n) τ) + ... | Inr neq = T (↓Nat n 1 m) + + TtSub : Nat → htyp → ihexp → ihexp + TtSub n τ c = c + TtSub n τ (X x) = X x + TtSub n τ (·λ[ x ] d) = ·λ[ TTSub n τ x ] (TtSub n τ d) + TtSub n τ (·Λ d) = ·Λ (TtSub (1+ n) τ d) + TtSub n τ ⦇-⦈ = ⦇-⦈ + TtSub n τ ⦇⌜ d ⌟⦈ = ⦇⌜ TtSub n τ d ⌟⦈ + TtSub n τ (d ∘ d₁) = (TtSub n τ d) ∘ (TtSub n τ d₁) + TtSub n τ (d < x >) = (TtSub n τ d) < TTSub n τ x > + TtSub n τ (d ⟨ x ⇒ x₁ ⟩) = (TtSub n τ d) ⟨ TTSub n τ x ⇒ TTSub n τ x₁ ⟩ + TtSub n τ (d ⟨ x ⇒⦇-⦈⇏ x₁ ⟩) = (TtSub n τ d) ⟨ TTSub n τ x ⇒⦇-⦈⇏ TTSub n τ x₁ ⟩ + + ttSub : Nat → Nat → ihexp → ihexp → ihexp + ttSub n m d1 c = c + ttSub n m d1 ⦇-⦈ = ⦇-⦈ + ttSub n m d1 ⦇⌜ d2 ⌟⦈ = ⦇⌜ ttSub n m d1 d2 ⌟⦈ + ttSub n m d1 (d2 ∘ d3) = (ttSub n m d1 d2) ∘ (ttSub n m d1 d3) + ttSub n m d1 (d2 < x >) = (ttSub n m d1 d2) < x > + ttSub n m d1 (d2 ⟨ x ⇒ x₁ ⟩) = (ttSub n m d1 d2) ⟨ x ⇒ x₁ ⟩ + ttSub n m d1 (d2 ⟨ x ⇒⦇-⦈⇏ x₁ ⟩) = (ttSub n m d1 d2) ⟨ x ⇒⦇-⦈⇏ x₁ ⟩ + ttSub n m d1 (·λ[ x ] d2) = ·λ[ x ] (ttSub (1+ n) m d1 d2) + ttSub n m d1 (·Λ d2) = ·Λ (ttSub n (1+ m) d1 d2) + ttSub n m d (X x) with natEQ x n + ... | Inl refl = ↑d 0 n 0 m d + ... | Inr neq = X (↓Nat n 1 x) + + -- assumes tau is closed, otherwise need to increment fv's in tau in last case + TCtxSub : Nat → htyp → ctx → ctx + TCtxSub n τ ∅ = ∅ + TCtxSub n τ (x , Γ) = (TTSub n τ x) , (TCtxSub n τ Γ) + TCtxSub Z τ (TVar, Γ) = Γ + TCtxSub (1+ n) τ (TVar, Γ) = TVar, TCtxSub n τ Γ \ No newline at end of file diff --git a/core-type.agda b/core-type.agda new file mode 100644 index 0000000..8abc363 --- /dev/null +++ b/core-type.agda @@ -0,0 +1,107 @@ +open import Prelude +open import Nat + +module core-type where + + -- types + data htyp : Set where + b : htyp + T : Nat → htyp + ⦇-⦈ : htyp + _==>_ : htyp → htyp → htyp + ·∀ : htyp → htyp + + -- arrow type constructors bind very tightly + infixr 25 _==>_ + + data _~_ : htyp → htyp → Set where + ConsistBase : b ~ b + ConsistVar : ∀ {x} → T x ~ T x + ConsistHole1 : ∀ {τ} → τ ~ ⦇-⦈ + ConsistHole2 : ∀ {τ} → ⦇-⦈ ~ τ + ConsistArr : ∀ {τ1 τ2 τ3 τ4} → τ1 ~ τ3 → τ2 ~ τ4 → τ1 ==> τ2 ~ τ3 ==> τ4 + ConsistForall : ∀ {τ1 τ2} → τ1 ~ τ2 → ·∀ τ1 ~ ·∀ τ2 + + -- type inconsistency + _~̸_ : (t1 t2 : htyp) → Set + _~̸_ = \(t1 t2 : htyp) → ¬(t1 ~ t2) + + data _⊑t_ : htyp → htyp → Set where + PTBase : b ⊑t b + PTHole : ∀{τ} → τ ⊑t ⦇-⦈ + PTTVar : ∀{n} → (T n) ⊑t (T n) + PTArr : ∀{τ1 τ2 τ3 τ4} → τ1 ⊑t τ3 → τ2 ⊑t τ4 → (τ1 ==> τ2) ⊑t (τ3 ==> τ4) + PTForall : ∀{τ1 τ2} → τ1 ⊑t τ2 → (·∀ τ1) ⊑t (·∀ τ2) + + data _⊓_==_ : htyp → htyp → htyp → Set where + MeetHoleL : ∀ {τ} → ⦇-⦈ ⊓ τ == τ + MeetHoleR : ∀ {τ} → τ ⊓ ⦇-⦈ == τ + MeetBase : b ⊓ b == b + MeetVar : ∀ {x} → T x ⊓ T x == T x + MeetArr : ∀ {τ1 τ2 τ3 τ4 τ5 τ6} → τ1 ⊓ τ3 == τ5 → τ2 ⊓ τ4 == τ6 → τ1 ==> τ2 ⊓ τ3 ==> τ4 == τ5 ==> τ6 + MeetForall : ∀ {τ1 τ2 τ3} → τ1 ⊓ τ2 == τ3 → ·∀ τ1 ⊓ ·∀ τ2 == ·∀ τ3 + + -- ground types + data _ground : (τ : htyp) → Set where + GBase : b ground + GArr : ⦇-⦈ ==> ⦇-⦈ ground + GForall : ·∀ ⦇-⦈ ground + + -- matched ground types + data _▸gnd_ : htyp → htyp → Set where + MGArr : ∀{τ1 τ2} → + (τ1 ==> τ2) ≠ (⦇-⦈ ==> ⦇-⦈) → + (τ1 ==> τ2) ▸gnd (⦇-⦈ ==> ⦇-⦈) + MGForall : ∀{τ} → + (·∀ τ ≠ ·∀ ⦇-⦈) → + (·∀ τ) ▸gnd (·∀ ⦇-⦈) + + -- the type of term to type contexts, i.e. Γs in the judegments below + data ctx : Set where + ∅ : ctx + _,_ : htyp → ctx → ctx + TVar,_ : ctx → ctx + + infixr 18 TVar,_ + + _ctx+_ : ctx → ctx → ctx + ∅ ctx+ ctx2 = ctx2 + (x , ctx1) ctx+ ctx2 = (x , ctx1 ctx+ ctx2) + (TVar, ctx1) ctx+ ctx2 = (TVar, ctx1 ctx+ ctx2) + + ctx-extend-tvars : Nat → ctx → ctx + ctx-extend-tvars Z Γ = Γ + ctx-extend-tvars (1+ n) Γ = (TVar, ctx-extend-tvars n Γ) + + -- data _⊢_varwf : ctx → Nat → Set where + -- WFSkip : ∀{Γ τ} → Γ ⊢ Z varwf → (τ , Γ) ⊢ Z varwf + -- WFVarZ : ∀{Γ} → (TVar, Γ) ⊢ Z varwf + -- WFVarS : ∀{Γ n} → Γ ⊢ n varwf → (TVar, Γ) ⊢ (1+ n) varwf + + -- well-formedness of types + data _⊢_wf : ctx → htyp → Set where + -- WFVar : ∀{Γ n} → Γ ⊢ n varwf → Γ ⊢ T n wf + WFSkip : ∀{Γ n τ} → Γ ⊢ T n wf → (τ , Γ) ⊢ T n wf + WFVarZ : ∀{Γ} → (TVar, Γ) ⊢ T Z wf + WFVarS : ∀{Γ n} → Γ ⊢ T n wf → (TVar, Γ) ⊢ T (1+ n) wf + WFBase : ∀{Γ} → Γ ⊢ b wf + WFHole : ∀{Γ} → Γ ⊢ ⦇-⦈ wf + WFArr : ∀{Γ τ1 τ2} → Γ ⊢ τ1 wf → Γ ⊢ τ2 wf → Γ ⊢ τ1 ==> τ2 wf + WFForall : ∀{Γ τ} → (TVar, Γ) ⊢ τ wf → Γ ⊢ ·∀ τ wf + + -- well-formedness of contexts + data ⊢_ctxwf : ctx → Set where + CtxWFEmpty : ⊢ ∅ ctxwf + CtxWFVar : ∀{Γ τ} → Γ ⊢ τ wf → ⊢ Γ ctxwf → ⊢ τ , Γ ctxwf + CtxWFTVar : ∀{Γ} → ⊢ Γ ctxwf → ⊢ (TVar, Γ) ctxwf + + -- Not accurate: domains may not be equal + data _⊑c_ : ctx → ctx → Set where + PCEmpty : ∅ ⊑c ∅ + PCVar : ∀{τ Γ τ' Γ'} → (τ ⊑t τ') → (Γ ⊑c Γ') → ((τ , Γ) ⊑c (τ' , Γ')) + PCTVar : ∀{Γ Γ'} → (Γ ⊑c Γ') → ((TVar, Γ) ⊑c (TVar, Γ')) + + data context-counter : ctx → Nat → Nat → Set where + CtxCtEmpty : context-counter ∅ Z Z + CtxCtVar : ∀{Γ n m τ} → context-counter Γ n m → context-counter (τ , Γ) (1+ n) m + CtxCtTVar : ∀{Γ n m} → context-counter Γ n m → context-counter (TVar, Γ) n (1+ m) \ No newline at end of file diff --git a/core.agda b/core.agda index be735f5..1665b61 100644 --- a/core.agda +++ b/core.agda @@ -1,419 +1,207 @@ -open import Nat + open import Prelude -open import contexts +open import Nat +open import core-type +open import core-exp +open import core-subst module core where - -- types - data htyp : Set where - b : htyp - ⦇-⦈ : htyp - _==>_ : htyp → htyp → htyp - - -- arrow type constructors bind very tightly - infixr 25 _==>_ - - -- external expressions - data hexp : Set where - c : hexp - _·:_ : hexp → htyp → hexp - X : Nat → hexp - ·λ : Nat → hexp → hexp - ·λ_[_]_ : Nat → htyp → hexp → hexp - ⦇-⦈[_] : Nat → hexp - ⦇⌜_⌟⦈[_] : hexp → Nat → hexp - _∘_ : hexp → hexp → hexp - - -- the type of type contexts, i.e. Γs in the judegments below - tctx : Set - tctx = htyp ctx - - mutual - -- identity substitution, substitition environments - data env : Set where - Id : (Γ : tctx) → env - Subst : (d : ihexp) → (y : Nat) → env → env - - -- internal expressions - data ihexp : Set where - c : ihexp - X : Nat → ihexp - ·λ_[_]_ : Nat → htyp → ihexp → ihexp - ⦇-⦈⟨_⟩ : (Nat × env) → ihexp - ⦇⌜_⌟⦈⟨_⟩ : ihexp → (Nat × env) → ihexp - _∘_ : ihexp → ihexp → ihexp - _⟨_⇒_⟩ : ihexp → htyp → htyp → ihexp - _⟨_⇒⦇-⦈⇏_⟩ : ihexp → htyp → htyp → ihexp - - -- convenient notation for chaining together two agreeable casts - _⟨_⇒_⇒_⟩ : ihexp → htyp → htyp → htyp → ihexp - d ⟨ t1 ⇒ t2 ⇒ t3 ⟩ = d ⟨ t1 ⇒ t2 ⟩ ⟨ t2 ⇒ t3 ⟩ - - -- type consistency - data _~_ : (t1 t2 : htyp) → Set where - TCRefl : {τ : htyp} → τ ~ τ - TCHole1 : {τ : htyp} → τ ~ ⦇-⦈ - TCHole2 : {τ : htyp} → ⦇-⦈ ~ τ - TCArr : {τ1 τ2 τ1' τ2' : htyp} → - τ1 ~ τ1' → - τ2 ~ τ2' → - τ1 ==> τ2 ~ τ1' ==> τ2' - - -- type inconsistency - data _~̸_ : (τ1 τ2 : htyp) → Set where - ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2 - ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b - ICArr1 : {τ1 τ2 τ3 τ4 : htyp} → - τ1 ~̸ τ3 → - τ1 ==> τ2 ~̸ τ3 ==> τ4 - ICArr2 : {τ1 τ2 τ3 τ4 : htyp} → - τ2 ~̸ τ4 → - τ1 ==> τ2 ~̸ τ3 ==> τ4 - - --- matching for arrows - data _▸arr_ : htyp → htyp → Set where - MAHole : ⦇-⦈ ▸arr ⦇-⦈ ==> ⦇-⦈ - MAArr : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2 - - -- the type of hole contexts, i.e. Δs in the judgements - hctx : Set - hctx = (htyp ctx × htyp) ctx - - -- notation for a triple to match the CMTT syntax - _::_[_] : Nat → htyp → tctx → (Nat × (tctx × htyp)) - u :: τ [ Γ ] = u , (Γ , τ) - - -- the hole name u does not appear in the term e - data hole-name-new : (e : hexp) (u : Nat) → Set where - HNConst : ∀{u} → hole-name-new c u - HNAsc : ∀{e τ u} → - hole-name-new e u → - hole-name-new (e ·: τ) u - HNVar : ∀{x u} → hole-name-new (X x) u - HNLam1 : ∀{x e u} → - hole-name-new e u → - hole-name-new (·λ x e) u - HNLam2 : ∀{x e u τ} → - hole-name-new e u → - hole-name-new (·λ x [ τ ] e) u - HNHole : ∀{u u'} → - u' ≠ u → - hole-name-new (⦇-⦈[ u' ]) u - HNNEHole : ∀{u u' e} → - u' ≠ u → - hole-name-new e u → - hole-name-new (⦇⌜ e ⌟⦈[ u' ]) u - HNAp : ∀{ u e1 e2 } → - hole-name-new e1 u → - hole-name-new e2 u → - hole-name-new (e1 ∘ e2) u - - -- two terms that do not share any hole names - data holes-disjoint : (e1 : hexp) → (e2 : hexp) → Set where - HDConst : ∀{e} → holes-disjoint c e - HDAsc : ∀{e1 e2 τ} → holes-disjoint e1 e2 → holes-disjoint (e1 ·: τ) e2 - HDVar : ∀{x e} → holes-disjoint (X x) e - HDLam1 : ∀{x e1 e2} → holes-disjoint e1 e2 → holes-disjoint (·λ x e1) e2 - HDLam2 : ∀{x e1 e2 τ} → holes-disjoint e1 e2 → holes-disjoint (·λ x [ τ ] e1) e2 - HDHole : ∀{u e2} → hole-name-new e2 u → holes-disjoint (⦇-⦈[ u ]) e2 - HDNEHole : ∀{u e1 e2} → hole-name-new e2 u → holes-disjoint e1 e2 → holes-disjoint (⦇⌜ e1 ⌟⦈[ u ]) e2 - HDAp : ∀{e1 e2 e3} → holes-disjoint e1 e3 → holes-disjoint e2 e3 → holes-disjoint (e1 ∘ e2) e3 + + data _,_∈_ : Nat → htyp → ctx → Set where + InCtxSkip : ∀{Γ τ n} → (n , τ ∈ Γ) → (n , ↑ Z 1 τ ∈ (TVar, Γ)) + InCtxZ : ∀{Γ τ} → Z , τ ∈ (τ , Γ) + InCtx1+ : ∀{Γ τ τ' n} → (n , τ ∈ Γ) → (1+ n , τ ∈ (τ' , Γ)) -- bidirectional type checking judgements for hexp mutual -- synthesis - data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where - SConst : {Γ : tctx} → Γ ⊢ c => b - SAsc : {Γ : tctx} {e : hexp} {τ : htyp} → - Γ ⊢ e <= τ → - Γ ⊢ (e ·: τ) => τ - SVar : {Γ : tctx} {τ : htyp} {x : Nat} → - (x , τ) ∈ Γ → - Γ ⊢ X x => τ - SAp : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} → - holes-disjoint e1 e2 → - Γ ⊢ e1 => τ1 → - τ1 ▸arr τ2 ==> τ → - Γ ⊢ e2 <= τ2 → - Γ ⊢ (e1 ∘ e2) => τ - SEHole : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇-⦈[ u ] => ⦇-⦈ - SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → - hole-name-new e u → - Γ ⊢ e => τ → - Γ ⊢ ⦇⌜ e ⌟⦈[ u ] => ⦇-⦈ - SLam : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} → - x # Γ → - (Γ ,, (x , τ1)) ⊢ e => τ2 → - Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2 + data _⊢_=>_ : (Γ : ctx) (e : hexp) (τ : htyp) → Set where + SConst : {Γ : ctx} → + Γ ⊢ c => b + SAsc : {Γ : ctx} {e : hexp} {τ : htyp} → + Γ ⊢ τ wf → + Γ ⊢ e <= τ → + Γ ⊢ (e ·: τ) => τ + SVar : {Γ : ctx} {τ : htyp} {n : Nat} → + n , τ ∈ Γ → + Γ ⊢ X n => τ + SAp : {Γ : ctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} → + Γ ⊢ e1 => τ1 → + τ1 ⊓ (⦇-⦈ ==> ⦇-⦈) == τ2 ==> τ → + Γ ⊢ e2 <= τ2 → + Γ ⊢ (e1 ∘ e2) => τ + SEHole : {Γ : ctx} → + Γ ⊢ ⦇-⦈ => ⦇-⦈ + SNEHole : {Γ : ctx} {e : hexp} {τ : htyp} → + Γ ⊢ e => τ → + Γ ⊢ ⦇⌜ e ⌟⦈ => ⦇-⦈ + SLam : {Γ : ctx} {e : hexp} {τ1 τ2 : htyp} → + Γ ⊢ τ1 wf → + (τ1 , Γ) ⊢ e => τ2 → + Γ ⊢ ·λ[ τ1 ] e => τ1 ==> τ2 + STLam : {Γ : ctx} {e : hexp} {τ : htyp} → + (TVar, Γ) ⊢ e => τ → + Γ ⊢ (·Λ e) => (·∀ τ) + STAp : {Γ : ctx} {e : hexp} {τ1 τ2 τ3 τ4 : htyp} → + Γ ⊢ τ1 wf → + Γ ⊢ e => τ2 → + τ2 ⊓ ·∀ ⦇-⦈ == (·∀ τ3) → + TTSub Z τ1 τ3 == τ4 → + Γ ⊢ (e < τ1 >) => τ4 -- analysis - data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where - ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} → - Γ ⊢ e => τ' → - τ ~ τ' → - Γ ⊢ e <= τ - ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} → - x # Γ → - τ ▸arr τ1 ==> τ2 → - (Γ ,, (x , τ1)) ⊢ e <= τ2 → - Γ ⊢ (·λ x e) <= τ - - -- those types without holes - data _tcomplete : htyp → Set where - TCBase : b tcomplete - TCArr : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ==> τ2) tcomplete - - -- those external expressions without holes - data _ecomplete : hexp → Set where - ECConst : c ecomplete - ECAsc : ∀{τ e} → τ tcomplete → e ecomplete → (e ·: τ) ecomplete - ECVar : ∀{x} → (X x) ecomplete - ECLam1 : ∀{x e} → e ecomplete → (·λ x e) ecomplete - ECLam2 : ∀{x e τ} → e ecomplete → τ tcomplete → (·λ x [ τ ] e) ecomplete - ECAp : ∀{e1 e2} → e1 ecomplete → e2 ecomplete → (e1 ∘ e2) ecomplete - - -- those internal expressions without holes - data _dcomplete : ihexp → Set where - DCVar : ∀{x} → (X x) dcomplete - DCConst : c dcomplete - DCLam : ∀{x τ d} → d dcomplete → τ tcomplete → (·λ x [ τ ] d) dcomplete - DCAp : ∀{d1 d2} → d1 dcomplete → d2 dcomplete → (d1 ∘ d2) dcomplete - DCCast : ∀{d τ1 τ2} → d dcomplete → τ1 tcomplete → τ2 tcomplete → (d ⟨ τ1 ⇒ τ2 ⟩) dcomplete - - -- contexts that only produce complete types - _gcomplete : tctx → Set - Γ gcomplete = (x : Nat) (τ : htyp) → (x , τ) ∈ Γ → τ tcomplete - - -- those internal expressions where every cast is the identity cast and - -- there are no failed casts - data cast-id : ihexp → Set where - CIConst : cast-id c - CIVar : ∀{x} → cast-id (X x) - CILam : ∀{x τ d} → cast-id d → cast-id (·λ x [ τ ] d) - CIHole : ∀{u} → cast-id (⦇-⦈⟨ u ⟩) - CINEHole : ∀{d u} → cast-id d → cast-id (⦇⌜ d ⌟⦈⟨ u ⟩) - CIAp : ∀{d1 d2} → cast-id d1 → cast-id d2 → cast-id (d1 ∘ d2) - CICast : ∀{d τ} → cast-id d → cast-id (d ⟨ τ ⇒ τ ⟩) - - -- expansion + data _⊢_<=_ : (Γ : ctx) (e : hexp) (τ : htyp) → Set where + ASubsume : {Γ : ctx} {e : hexp} {τ τ' : htyp} → + Γ ⊢ e => τ' → + τ ~ τ' → + Γ ⊢ e <= τ + ALam : {Γ : ctx} {e : hexp} {τ τ1 τ2 : htyp} → + τ ⊓ (⦇-⦈ ==> ⦇-⦈) == τ1 ==> τ2 → + (τ1 , Γ) ⊢ e <= τ2 → + Γ ⊢ (·λ e) <= τ + ATLam : {Γ : ctx} {e : hexp} {τ1 τ2 : htyp} → + τ1 ⊓ ·∀ ⦇-⦈ == (·∀ τ2) → + (TVar, Γ) ⊢ e <= τ2 → + Γ ⊢ (·Λ e) <= τ1 + + -- bidirectional elaboration judgements mutual -- synthesis - data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : ihexp) (Δ : hctx) → Set where - ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅ - ESVar : ∀{Γ x τ} → (x , τ) ∈ Γ → - Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅ - ESLam : ∀{Γ x τ1 τ2 e d Δ } → - (x # Γ) → - (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ → - Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ - ESAp : ∀{Γ e1 τ τ1 τ1' τ2 τ2' d1 Δ1 e2 d2 Δ2 } → - holes-disjoint e1 e2 → - Δ1 ## Δ2 → - Γ ⊢ e1 => τ1 → - τ1 ▸arr τ2 ==> τ → - Γ ⊢ e1 ⇐ (τ2 ==> τ) ~> d1 :: τ1' ⊣ Δ1 → - Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 → - Γ ⊢ e1 ∘ e2 ⇒ τ ~> (d1 ⟨ τ1' ⇒ τ2 ==> τ ⟩) ∘ (d2 ⟨ τ2' ⇒ τ2 ⟩) ⊣ (Δ1 ∪ Δ2) - ESEHole : ∀{ Γ u } → - Γ ⊢ ⦇-⦈[ u ] ⇒ ⦇-⦈ ~> ⦇-⦈⟨ u , Id Γ ⟩ ⊣ ■ (u :: ⦇-⦈ [ Γ ]) - ESNEHole : ∀{ Γ e τ d u Δ } → - Δ ## (■ (u , Γ , ⦇-⦈)) → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - Γ ⊢ ⦇⌜ e ⌟⦈[ u ] ⇒ ⦇-⦈ ~> ⦇⌜ d ⌟⦈⟨ u , Id Γ ⟩ ⊣ (Δ ,, u :: ⦇-⦈ [ Γ ]) - ESAsc : ∀ {Γ e τ d τ' Δ} → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - Γ ⊢ (e ·: τ) ⇒ τ ~> d ⟨ τ' ⇒ τ ⟩ ⊣ Δ + data _⊢_⇒_~>_ : (Γ : ctx) (e : hexp) (τ : htyp) (d : ihexp) → Set where + ESConst : ∀{Γ} → + Γ ⊢ c ⇒ b ~> c + ESVar : ∀{Γ x τ} → + x , τ ∈ Γ → + Γ ⊢ X x ⇒ τ ~> X x + ESLam : ∀{Γ τ1 τ2 e d} → + Γ ⊢ τ1 wf → + (τ1 , Γ) ⊢ e ⇒ τ2 ~> d → + Γ ⊢ (·λ[ τ1 ] e) ⇒ (τ1 ==> τ2) ~> (·λ[ τ1 ] d) + ESTLam : ∀{Γ e τ d} → + (TVar, Γ) ⊢ e ⇒ τ ~> d → + Γ ⊢ (·Λ e) ⇒ (·∀ τ) ~> (·Λ d) + ESAp : ∀{Γ e1 τ τ1 τ1' τ2 τ2' d1 e2 d2 } → + Γ ⊢ e1 => τ1 → + τ1 ⊓ (⦇-⦈ ==> ⦇-⦈) == τ2 ==> τ → + Γ ⊢ e1 ⇐ (τ2 ==> τ) ~> d1 :: τ1' → + Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' → + Γ ⊢ (e1 ∘ e2) ⇒ τ ~> ((d1 ⟨ τ1' ⇒ τ2 ==> τ ⟩) ∘ (d2 ⟨ τ2' ⇒ τ2 ⟩)) + ESTAp : ∀{Γ e τ1 τ2 τ3 τ4 τ2' d} → + Γ ⊢ τ1 wf → + Γ ⊢ e => τ2 → + τ2 ⊓ ·∀ ⦇-⦈ == (·∀ τ3) → + Γ ⊢ e ⇐ (·∀ τ3) ~> d :: τ2' → + TTSub Z τ1 τ3 == τ4 → + Γ ⊢ (e < τ1 >) ⇒ τ4 ~> ((d ⟨ τ2' ⇒ (·∀ τ3)⟩) < τ1 >) + ESEHole : ∀{Γ} → + Γ ⊢ ⦇-⦈ ⇒ ⦇-⦈ ~> ⦇-⦈ + ESNEHole : ∀{Γ e τ d} → + Γ ⊢ e ⇒ τ ~> d → + Γ ⊢ ⦇⌜ e ⌟⦈ ⇒ ⦇-⦈ ~> ⦇⌜ d ⌟⦈ + ESAsc : ∀ {Γ e τ d τ'} → + Γ ⊢ τ wf → + Γ ⊢ e ⇐ τ ~> d :: τ' → + Γ ⊢ (e ·: τ) ⇒ τ ~> (d ⟨ τ' ⇒ τ ⟩) -- analysis - data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : ihexp) (τ' : htyp) (Δ : hctx) → Set where - EALam : ∀{Γ x τ τ1 τ2 e d τ2' Δ } → - (x # Γ) → - τ ▸arr τ1 ==> τ2 → - (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ → - Γ ⊢ ·λ x e ⇐ τ ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ - EASubsume : ∀{e Γ τ' d Δ τ} → - ((u : Nat) → e ≠ ⦇-⦈[ u ]) → - ((e' : hexp) (u : Nat) → e ≠ ⦇⌜ e' ⌟⦈[ u ]) → - Γ ⊢ e ⇒ τ' ~> d ⊣ Δ → - τ ~ τ' → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ - EAEHole : ∀{ Γ u τ } → - Γ ⊢ ⦇-⦈[ u ] ⇐ τ ~> ⦇-⦈⟨ u , Id Γ ⟩ :: τ ⊣ ■ (u :: τ [ Γ ]) - EANEHole : ∀{ Γ e u τ d τ' Δ } → - Δ ## (■ (u , Γ , τ)) → - Γ ⊢ e ⇒ τ' ~> d ⊣ Δ → - Γ ⊢ ⦇⌜ e ⌟⦈[ u ] ⇐ τ ~> ⦇⌜ d ⌟⦈⟨ u , Id Γ ⟩ :: τ ⊣ (Δ ,, u :: τ [ Γ ]) - - -- ground types - data _ground : (τ : htyp) → Set where - GBase : b ground - GHole : ⦇-⦈ ==> ⦇-⦈ ground - - mutual - -- substitution typing - data _,_⊢_:s:_ : hctx → tctx → env → tctx → Set where - STAId : ∀{Γ Γ' Δ} → - ((x : Nat) (τ : htyp) → (x , τ) ∈ Γ' → (x , τ) ∈ Γ) → - Δ , Γ ⊢ Id Γ' :s: Γ' - STASubst : ∀{Γ Δ σ y Γ' d τ } → - Δ , Γ ,, (y , τ) ⊢ σ :s: Γ' → - Δ , Γ ⊢ d :: τ → - Δ , Γ ⊢ Subst d y σ :s: Γ' - - -- type assignment - data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : ihexp) (τ : htyp) → Set where - TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b - TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ - TALam : ∀{ Δ Γ x τ1 d τ2} → - x # Γ → - Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 → - Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2) - TAAp : ∀{ Δ Γ d1 d2 τ1 τ} → - Δ , Γ ⊢ d1 :: τ1 ==> τ → - Δ , Γ ⊢ d2 :: τ1 → - Δ , Γ ⊢ d1 ∘ d2 :: τ - TAEHole : ∀{ Δ Γ σ u Γ' τ} → - (u , (Γ' , τ)) ∈ Δ → - Δ , Γ ⊢ σ :s: Γ' → - Δ , Γ ⊢ ⦇-⦈⟨ u , σ ⟩ :: τ - TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } → - (u , (Γ' , τ)) ∈ Δ → - Δ , Γ ⊢ d :: τ' → - Δ , Γ ⊢ σ :s: Γ' → - Δ , Γ ⊢ ⦇⌜ d ⌟⦈⟨ u , σ ⟩ :: τ - TACast : ∀{ Δ Γ d τ1 τ2} → - Δ , Γ ⊢ d :: τ1 → - τ1 ~ τ2 → - Δ , Γ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 - TAFailedCast : ∀{Δ Γ d τ1 τ2} → - Δ , Γ ⊢ d :: τ1 → - τ1 ground → - τ2 ground → - τ1 ≠ τ2 → - Δ , Γ ⊢ d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ :: τ2 - - -- substitution - [_/_]_ : ihexp → Nat → ihexp → ihexp - [ d / y ] c = c - [ d / y ] X x - with natEQ x y - [ d / y ] X .y | Inl refl = d - [ d / y ] X x | Inr neq = X x - [ d / y ] (·λ x [ x₁ ] d') - with natEQ x y - [ d / y ] (·λ .y [ τ ] d') | Inl refl = ·λ y [ τ ] d' - [ d / y ] (·λ x [ τ ] d') | Inr x₁ = ·λ x [ τ ] ( [ d / y ] d') - [ d / y ] ⦇-⦈⟨ u , σ ⟩ = ⦇-⦈⟨ u , Subst d y σ ⟩ - [ d / y ] ⦇⌜ d' ⌟⦈⟨ u , σ ⟩ = ⦇⌜ [ d / y ] d' ⌟⦈⟨ u , Subst d y σ ⟩ - [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2) - [ d / y ] (d' ⟨ τ1 ⇒ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒ τ2 ⟩ - [ d / y ] (d' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ - - -- applying an environment to an expression - apply-env : env → ihexp → ihexp - apply-env (Id Γ) d = d - apply-env (Subst d y σ) d' = [ d / y ] ( apply-env σ d') - - -- values - data _val : (d : ihexp) → Set where - VConst : c val - VLam : ∀{x τ d} → (·λ x [ τ ] d) val - - -- boxed values - data _boxedval : (d : ihexp) → Set where - BVVal : ∀{d} → d val → d boxedval - BVArrCast : ∀{ d τ1 τ2 τ3 τ4 } → - τ1 ==> τ2 ≠ τ3 ==> τ4 → - d boxedval → - d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ boxedval - BVHoleCast : ∀{ τ d } → τ ground → d boxedval → d ⟨ τ ⇒ ⦇-⦈ ⟩ boxedval - - mutual - -- indeterminate forms - data _indet : (d : ihexp) → Set where - IEHole : ∀{u σ} → ⦇-⦈⟨ u , σ ⟩ indet - INEHole : ∀{d u σ} → d final → ⦇⌜ d ⌟⦈⟨ u , σ ⟩ indet - IAp : ∀{d1 d2} → ((τ1 τ2 τ3 τ4 : htyp) (d1' : ihexp) → - d1 ≠ (d1' ⟨(τ1 ==> τ2) ⇒ (τ3 ==> τ4)⟩)) → - d1 indet → - d2 final → - (d1 ∘ d2) indet - ICastArr : ∀{d τ1 τ2 τ3 τ4} → - τ1 ==> τ2 ≠ τ3 ==> τ4 → - d indet → - d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ indet - ICastGroundHole : ∀{ τ d } → - τ ground → - d indet → - d ⟨ τ ⇒ ⦇-⦈ ⟩ indet - ICastHoleGround : ∀ { d τ } → - ((d' : ihexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇-⦈ ⟩)) → - d indet → - τ ground → - d ⟨ ⦇-⦈ ⇒ τ ⟩ indet - IFailedCast : ∀{ d τ1 τ2 } → - d final → - τ1 ground → - τ2 ground → - τ1 ≠ τ2 → - d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ indet - - -- final expressions - data _final : (d : ihexp) → Set where - FBoxedVal : ∀{d} → d boxedval → d final - FIndet : ∀{d} → d indet → d final - - - -- contextual dynamics + data _⊢_⇐_~>_::_ : (Γ : ctx) (e : hexp) (τ : htyp) (d : ihexp) (τ' : htyp) → Set where + EALam : ∀{Γ τ τ1 τ2 e d τ2'} → + τ ⊓ (⦇-⦈ ==> ⦇-⦈) == τ1 ==> τ2 → + (τ1 , Γ) ⊢ e ⇐ τ2 ~> d :: τ2' → + Γ ⊢ ·λ e ⇐ τ ~> ·λ[ τ1 ] d :: τ1 ==> τ2' + EATLam : ∀{Γ e τ1 τ2 τ2' d} → + τ1 ⊓ ·∀ ⦇-⦈ == (·∀ τ2) → + (TVar, Γ) ⊢ e ⇐ τ2 ~> d :: τ2' → + Γ ⊢ (·Λ e) ⇐ τ1 ~> (·Λ d) :: (·∀ τ2') + EASubsume : ∀{e Γ τ1 τ2 τ3 d} → + e subsumable → + Γ ⊢ e ⇒ τ2 ~> d → + τ1 ⊓ τ2 == τ3 → + Γ ⊢ e ⇐ τ1 ~> (d ⟨ τ2 ⇒ τ3 ⟩) :: τ3 + + -- type assignment + data _⊢_::_ : (Γ : ctx) (d : ihexp) (τ : htyp) → Set where + TAConst : ∀{Γ} → + Γ ⊢ c :: b + TAVar : ∀{Γ n τ} → + n , τ ∈ Γ → + Γ ⊢ X n :: τ + TALam : ∀{ Γ τ1 d τ2} → + Γ ⊢ τ1 wf → + (τ1 , Γ) ⊢ d :: τ2 → + Γ ⊢ ·λ[ τ1 ] d :: (τ1 ==> τ2) + TATLam : ∀{ Γ d τ} → + (TVar, Γ) ⊢ d :: τ → + Γ ⊢ ·Λ d :: (·∀ τ) + TAAp : ∀{Γ d1 d2 τ1 τ} → + Γ ⊢ d1 :: τ1 ==> τ → + Γ ⊢ d2 :: τ1 → + Γ ⊢ d1 ∘ d2 :: τ + TATAp : ∀ {Γ d τ1 τ2 τ3} → + Γ ⊢ τ1 wf → + Γ ⊢ d :: (·∀ τ2) → + TTSub Z τ1 τ2 == τ3 → + Γ ⊢ (d < τ1 >) :: τ3 + TAEHole : ∀{Γ} → + Γ ⊢ ⦇-⦈ :: ⦇-⦈ + TANEHole : ∀ {Γ d τ} → + Γ ⊢ d :: τ → + Γ ⊢ ⦇⌜ d ⌟⦈ :: ⦇-⦈ + TACast : ∀{Γ d τ1 τ2} → + Γ ⊢ d :: τ1 → + Γ ⊢ τ2 wf → + τ1 ~ τ2 → + Γ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 + TAFailedCast : ∀{Γ d τ1 τ2} → + Γ ⊢ d :: τ1 → + τ1 ground → + τ2 ground → + τ1 ~̸ τ2 → + Γ ⊢ d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ :: τ2 + + -- precision for internal expressions + -- see Refined Criteria for Gradual Typing, Figure 9 + data _,_⊢_⊑i_ : (Γ : ctx) → (Γ' : ctx) → (d1 d2 : ihexp) → Set where + PIConst : ∀{Γ Γ'} → Γ , Γ' ⊢ c ⊑i c + PIVar : ∀{Γ Γ' n} → Γ , Γ' ⊢ (X n) ⊑i (X n) + PIEHole : ∀{Γ Γ' d} → Γ , Γ' ⊢ d ⊑i ⦇-⦈ + PILam : ∀{Γ Γ' d1 d2 τ1 τ2} → (τ1 , Γ) , (τ2 , Γ') ⊢ d1 ⊑i d2 → τ1 ⊑t τ2 → Γ , Γ' ⊢ (·λ[ τ1 ] d1) ⊑i (·λ[ τ2 ] d2) + PITLam : ∀{Γ Γ' d1 d2} → (TVar, Γ) , Γ' ⊢ d1 ⊑i d2 → Γ , Γ' ⊢ (·Λ d1) ⊑i (·Λ d2) + PINEHole : ∀{Γ Γ' d1 d2} → Γ , Γ' ⊢ d1 ⊑i d2 → Γ , Γ' ⊢ ⦇⌜ d1 ⌟⦈ ⊑i ⦇⌜ d2 ⌟⦈ + PIAp : ∀{Γ Γ' d1 d2 d3 d4} → Γ , Γ' ⊢ d1 ⊑i d3 → Γ , Γ' ⊢ d2 ⊑i d4 → Γ , Γ' ⊢ (d1 ∘ d2) ⊑i (d3 ∘ d4) + PITAp : ∀{Γ Γ' d1 d2 τ1 τ2} → Γ , Γ' ⊢ d1 ⊑i d2 → τ1 ⊑t τ2 → Γ , Γ' ⊢ (d1 < τ1 >) ⊑i (d2 < τ2 >) + PICast : ∀{Γ Γ' d1 d2 τ1 τ2 τ3 τ4} → Γ , Γ' ⊢ d1 ⊑i d2 → τ1 ⊑t τ3 → τ2 ⊑t τ4 → Γ , Γ' ⊢ (d1 ⟨ τ1 ⇒ τ2 ⟩) ⊑i (d2 ⟨ τ3 ⇒ τ4 ⟩) + -- PIFailedCast : ∀{Γ Γ' d1 d2 τ1 τ2 τ3 τ4} → Γ , Γ' ⊢ d1 ⊑i d2 → τ1 ⊑t τ3 → τ2 ⊑t τ4 → Γ , Γ' ⊢ (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) ⊑i (d2 ⟨ τ3 ⇒⦇-⦈⇏ τ4 ⟩) + PIFailedCast : ∀{Γ Γ' d1 d2 τ1 τ2 τ} → (Γ' ⊢ d2 :: τ) → (τ2 ⊑t τ) → (Γ , Γ' ⊢ d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ ⊑i d2) + PIRemoveCast : ∀{Γ Γ' d1 d2 τ1 τ2 τ} → (Γ , Γ' ⊢ d1 ⊑i d2) → (Γ' ⊢ d2 :: τ) → (τ1 ⊑t τ) → (τ2 ⊑t τ) → Γ , Γ' ⊢ (d1 ⟨ τ1 ⇒ τ2 ⟩) ⊑i d2 + PIAddCast : ∀{Γ Γ' d1 d2 τ1 τ2 τ} → (Γ , Γ' ⊢ d1 ⊑i d2) → (Γ ⊢ d1 :: τ) → (τ ⊑t τ1) → (τ ⊑t τ2) → Γ , Γ' ⊢ d1 ⊑i (d2 ⟨ τ1 ⇒ τ2 ⟩) -- evaluation contexts data ectx : Set where ⊙ : ectx _∘₁_ : ectx → ihexp → ectx _∘₂_ : ihexp → ectx → ectx - ⦇⌜_⌟⦈⟨_⟩ : ectx → (Nat × env ) → ectx + _<_> : ectx → htyp → ectx + ⦇⌜_⌟⦈ : ectx → ectx _⟨_⇒_⟩ : ectx → htyp → htyp → ectx _⟨_⇒⦇-⦈⇏_⟩ : ectx → htyp → htyp → ectx - -- note: this judgement is redundant: in the absence of the premises in - -- the red brackets, all syntactically well formed ectxs are valid. with - -- finality premises, that's not true, and that would propagate through - -- additions to the calculus. so we leave it here for clarity but note - -- that, as written, in any use case its either trival to prove or - -- provides no additional information - - --ε is an evaluation context - data _evalctx : (ε : ectx) → Set where - ECDot : ⊙ evalctx - ECAp1 : ∀{d ε} → - ε evalctx → - (ε ∘₁ d) evalctx - ECAp2 : ∀{d ε} → - -- d final → -- red brackets - ε evalctx → - (d ∘₂ ε) evalctx - ECNEHole : ∀{ε u σ} → - ε evalctx → - ⦇⌜ ε ⌟⦈⟨ u , σ ⟩ evalctx - ECCast : ∀{ ε τ1 τ2} → - ε evalctx → - (ε ⟨ τ1 ⇒ τ2 ⟩) evalctx - ECFailedCast : ∀{ ε τ1 τ2 } → - ε evalctx → - ε ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ evalctx - -- d is the result of filling the hole in ε with d' data _==_⟦_⟧ : (d : ihexp) (ε : ectx) (d' : ihexp) → Set where FHOuter : ∀{d} → d == ⊙ ⟦ d ⟧ FHAp1 : ∀{d1 d1' d2 ε} → - d1 == ε ⟦ d1' ⟧ → + d1 == ε ⟦ d1' ⟧ → (d1 ∘ d2) == (ε ∘₁ d2) ⟦ d1' ⟧ FHAp2 : ∀{d1 d2 d2' ε} → -- d1 final → -- red brackets d2 == ε ⟦ d2' ⟧ → (d1 ∘ d2) == (d1 ∘₂ ε) ⟦ d2' ⟧ - FHNEHole : ∀{ d d' ε u σ} → + FHTAp : ∀{d d' t ε} → + d == ε ⟦ d' ⟧ → + (d < t >) == (ε < t >) ⟦ d' ⟧ + FHNEHole : ∀{ d d' ε} → d == ε ⟦ d' ⟧ → - ⦇⌜ d ⌟⦈⟨ (u , σ ) ⟩ == ⦇⌜ ε ⌟⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧ + ⦇⌜ d ⌟⦈ == ⦇⌜ ε ⌟⦈ ⟦ d' ⟧ FHCast : ∀{ d d' ε τ1 τ2 } → d == ε ⟦ d' ⟧ → d ⟨ τ1 ⇒ τ2 ⟩ == ε ⟨ τ1 ⇒ τ2 ⟩ ⟦ d' ⟧ @@ -421,21 +209,17 @@ module core where d == ε ⟦ d' ⟧ → (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) == (ε ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) ⟦ d' ⟧ - -- matched ground types - data _▸gnd_ : htyp → htyp → Set where - MGArr : ∀{τ1 τ2} → - (τ1 ==> τ2) ≠ (⦇-⦈ ==> ⦇-⦈) → - (τ1 ==> τ2) ▸gnd (⦇-⦈ ==> ⦇-⦈) - -- instruction transition judgement data _→>_ : (d d' : ihexp) → Set where - ITLam : ∀{ x τ d1 d2 } → + ITLam : ∀{ τ d1 d2 } → -- d2 final → -- red brackets - ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) - ITCastID : ∀{d τ } → + ((·λ[ τ ] d1) ∘ d2) →> (ttSub Z Z d2 d1) + ITTLam : ∀{ d τ } → + ((·Λ d) < τ >) →> (TtSub Z τ d) + ITCastID : ∀{ d τ } → -- d final → -- red brackets (d ⟨ τ ⇒ τ ⟩) →> d - ITCastSucceed : ∀{d τ } → + ITCastSucceed : ∀{ d τ } → -- d final → -- red brackets τ ground → (d ⟨ τ ⇒ ⦇-⦈ ⇒ τ ⟩) →> d @@ -443,17 +227,21 @@ module core where -- d final → -- red brackets τ1 ground → τ2 ground → - τ1 ≠ τ2 → + τ1 ~̸ τ2 → (d ⟨ τ1 ⇒ ⦇-⦈ ⇒ τ2 ⟩) →> (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) ITApCast : ∀{d1 d2 τ1 τ2 τ1' τ2' } → -- d1 final → -- red brackets -- d2 final → -- red brackets ((d1 ⟨ (τ1 ==> τ2) ⇒ (τ1' ==> τ2')⟩) ∘ d2) →> ((d1 ∘ (d2 ⟨ τ1' ⇒ τ1 ⟩)) ⟨ τ2 ⇒ τ2' ⟩) + ITTApCast : ∀{ d τ1 τ2 τ3 } → + -- d final → -- red brackets + -- ·∀ τ ≠ ·∀ τ' → + ((d ⟨ (·∀ τ1) ⇒ (·∀ τ2)⟩) < τ3 >) →> ((d < τ3 >)⟨ TTSub Z τ3 τ1 ⇒ TTSub Z τ3 τ2 ⟩) ITGround : ∀{ d τ τ'} → -- d final → -- red brackets τ ▸gnd τ' → (d ⟨ τ ⇒ ⦇-⦈ ⟩) →> (d ⟨ τ ⇒ τ' ⇒ ⦇-⦈ ⟩) - ITExpand : ∀{d τ τ' } → + ITExpand : ∀{ d τ τ' } → -- d final → -- red brackets τ ▸gnd τ' → (d ⟨ ⦇-⦈ ⇒ τ ⟩) →> (d ⟨ ⦇-⦈ ⇒ τ' ⇒ τ ⟩) @@ -474,119 +262,59 @@ module core where d' ↦* d'' → d ↦* d'' - -- freshness - mutual - -- ... with respect to a hole context - data envfresh : Nat → env → Set where - EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ) - EFSubst : ∀{x d σ y} → fresh x d - → envfresh x σ - → x ≠ y - → envfresh x (Subst d y σ) - - -- ... for inernal expressions - data fresh : Nat → ihexp → Set where - FConst : ∀{x} → fresh x c - FVar : ∀{x y} → x ≠ y → fresh x (X y) - FLam : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d) - FHole : ∀{x u σ} → envfresh x σ → fresh x (⦇-⦈⟨ u , σ ⟩) - FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇⌜ d ⌟⦈⟨ u , σ ⟩) - FAp : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2) - FCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩) - FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) - - -- ... for external expressions - data freshh : Nat → hexp → Set where - FRHConst : ∀{x} → freshh x c - FRHAsc : ∀{x e τ} → freshh x e → freshh x (e ·: τ) - FRHVar : ∀{x y} → x ≠ y → freshh x (X y) - FRHLam1 : ∀{x y e} → x ≠ y → freshh x e → freshh x (·λ y e) - FRHLam2 : ∀{x τ e y} → x ≠ y → freshh x e → freshh x (·λ y [ τ ] e) - FRHEHole : ∀{x u} → freshh x (⦇-⦈[ u ]) - FRHNEHole : ∀{x u e} → freshh x e → freshh x (⦇⌜ e ⌟⦈[ u ]) - FRHAp : ∀{x e1 e2} → freshh x e1 → freshh x e2 → freshh x (e1 ∘ e2) - - -- x is not used in a binding site in d - mutual - data unbound-in-σ : Nat → env → Set where - UBσId : ∀{x Γ} → unbound-in-σ x (Id Γ) - UBσSubst : ∀{x d y σ} → unbound-in x d - → unbound-in-σ x σ - → x ≠ y - → unbound-in-σ x (Subst d y σ) - - data unbound-in : (x : Nat) (d : ihexp) → Set where - UBConst : ∀{x} → unbound-in x c - UBVar : ∀{x y} → unbound-in x (X y) - UBLam2 : ∀{x d y τ} → x ≠ y - → unbound-in x d - → unbound-in x (·λ_[_]_ y τ d) - UBHole : ∀{x u σ} → unbound-in-σ x σ - → unbound-in x (⦇-⦈⟨ u , σ ⟩) - UBNEHole : ∀{x u σ d } - → unbound-in-σ x σ - → unbound-in x d - → unbound-in x (⦇⌜ d ⌟⦈⟨ u , σ ⟩) - UBAp : ∀{ x d1 d2 } → - unbound-in x d1 → - unbound-in x d2 → - unbound-in x (d1 ∘ d2) - UBCast : ∀{x d τ1 τ2} → unbound-in x d → unbound-in x (d ⟨ τ1 ⇒ τ2 ⟩) - UBFailedCast : ∀{x d τ1 τ2} → unbound-in x d → unbound-in x (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) - + -- those types without holes + data _tcomplete : htyp → Set where + TCBase : b tcomplete + TCVar : ∀{n} → (T n) tcomplete + TCArr : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ==> τ2) tcomplete + TCForall : ∀{e} → e tcomplete → (·∀ e) tcomplete - mutual - data binders-disjoint-σ : env → ihexp → Set where - BDσId : ∀{Γ d} → binders-disjoint-σ (Id Γ) d - BDσSubst : ∀{d1 d2 y σ} → binders-disjoint d1 d2 - → binders-disjoint-σ σ d2 - → binders-disjoint-σ (Subst d1 y σ) d2 + -- those external expressions without holes + data _ecomplete : hexp → Set where + ECConst : c ecomplete + ECAsc : ∀{τ e} → τ tcomplete → e ecomplete → (e ·: τ) ecomplete + ECVar : ∀{x} → (X x) ecomplete + ECLam1 : ∀{e} → e ecomplete → (·λ e) ecomplete + ECLam2 : ∀{e τ} → e ecomplete → τ tcomplete → (·λ[ τ ] e) ecomplete + ECTLam : ∀{e} → e ecomplete → (·Λ e) ecomplete + ECAp : ∀{e1 e2} → e1 ecomplete → e2 ecomplete → (e1 ∘ e2) ecomplete + ECTAp : ∀{τ e} → τ tcomplete → e ecomplete → (e < τ >) ecomplete - -- two terms that do not share any binders - data binders-disjoint : (d1 : ihexp) → (d2 : ihexp) → Set where - BDConst : ∀{d} → binders-disjoint c d - BDVar : ∀{x d} → binders-disjoint (X x) d - BDLam : ∀{x τ d1 d2} → binders-disjoint d1 d2 - → unbound-in x d2 - → binders-disjoint (·λ_[_]_ x τ d1) d2 - BDHole : ∀{u σ d2} → binders-disjoint-σ σ d2 - → binders-disjoint (⦇-⦈⟨ u , σ ⟩) d2 - BDNEHole : ∀{u σ d1 d2} → binders-disjoint-σ σ d2 - → binders-disjoint d1 d2 - → binders-disjoint (⦇⌜ d1 ⌟⦈⟨ u , σ ⟩) d2 - BDAp : ∀{d1 d2 d3} → binders-disjoint d1 d3 - → binders-disjoint d2 d3 - → binders-disjoint (d1 ∘ d2) d3 - BDCast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint (d1 ⟨ τ1 ⇒ τ2 ⟩) d2 - BDFailedCast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) d2 + -- those internal expressions without holes + data _dcomplete : ihexp → Set where + DCVar : ∀{x} → (X x) dcomplete + DCConst : c dcomplete + DCLam : ∀{τ d} → d dcomplete → τ tcomplete → (·λ[ τ ] d) dcomplete + DCTLam : ∀{d} → d dcomplete → (·Λ d) dcomplete + DCAp : ∀{d1 d2} → d1 dcomplete → d2 dcomplete → (d1 ∘ d2) dcomplete + DCTAp : ∀{τ d} → τ tcomplete → d dcomplete → (d < τ >) dcomplete + DCCast : ∀{d τ1 τ2} → d dcomplete → τ1 tcomplete → τ2 tcomplete → (d ⟨ τ1 ⇒ τ2 ⟩) dcomplete - mutual - -- each term has to be binders unique, and they have to be pairwise - -- disjoint with the collection of bound vars - data binders-unique-σ : env → Set where - BUσId : ∀{Γ} → binders-unique-σ (Id Γ) - BUσSubst : ∀{d y σ} → binders-unique d - → binders-unique-σ σ - → binders-disjoint-σ σ d - → binders-unique-σ (Subst d y σ) + data _dcompleteid : ihexp → Set where + DCVar : ∀{x} → (X x) dcompleteid + DCConst : c dcompleteid + DCLam : ∀{τ d} → d dcompleteid → τ tcomplete → (·λ[ τ ] d) dcompleteid + DCTLam : ∀{d} → d dcompleteid → (·Λ d) dcompleteid + DCAp : ∀{d1 d2} → d1 dcompleteid → d2 dcompleteid → (d1 ∘ d2) dcompleteid + DCTAp : ∀{τ d} → τ tcomplete → d dcompleteid → (d < τ >) dcompleteid + DCCast : ∀{d τ} → d dcompleteid → τ tcomplete → (d ⟨ τ ⇒ τ ⟩) dcompleteid - -- all the variable names in the term are unique - data binders-unique : ihexp → Set where - BUHole : binders-unique c - BUVar : ∀{x} → binders-unique (X x) - BULam : {x : Nat} {τ : htyp} {d : ihexp} → binders-unique d - → unbound-in x d - → binders-unique (·λ_[_]_ x τ d) - BUEHole : ∀{u σ} → binders-unique-σ σ - → binders-unique (⦇-⦈⟨ u , σ ⟩) - BUNEHole : ∀{u σ d} → binders-unique d - → binders-unique-σ σ - → binders-unique (⦇⌜ d ⌟⦈⟨ u , σ ⟩) - BUAp : ∀{d1 d2} → binders-unique d1 - → binders-unique d2 - → binders-disjoint d1 d2 - → binders-unique (d1 ∘ d2) - BUCast : ∀{d τ1 τ2} → binders-unique d - → binders-unique (d ⟨ τ1 ⇒ τ2 ⟩) - BUFailedCast : ∀{d τ1 τ2} → binders-unique d - → binders-unique (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + -- contexts that only produce complete types + data _gcomplete : ctx → Set where + GCEmpty : ∅ gcomplete + GCVar : ∀{Γ τ} → Γ gcomplete → τ tcomplete → (τ , Γ) gcomplete + GCTVar : ∀{Γ} → Γ gcomplete → (TVar, Γ) gcomplete + + -- -- those internal expressions where every cast is the identity cast and + -- -- there are no failed casts + -- data cast-id : ihexp → Set where + -- CIConst : cast-id c + -- CIVar : ∀{x} → cast-id (X x) + -- CILam : ∀{x τ d} → cast-id d → cast-id (·λ x [ τ ] d) + -- CITLam : ∀{t d} → cast-id d → cast-id (·Λ t d) + -- CIHole : ∀{τ} → cast-id (⦇-⦈⟨ τ ⟩) + -- CINEHole : ∀{d τ} → cast-id d → cast-id (⦇⌜ d ⌟⦈⟨ τ ⟩) + -- CIAp : ∀{d1 d2} → cast-id d1 → cast-id d2 → cast-id (d1 ∘ d2) + -- CITap : ∀{τ d} → cast-id d → cast-id (d < τ >) + -- CICast : ∀{d τ} → cast-id d → cast-id (d ⟨ τ ⇒ τ ⟩) + \ No newline at end of file diff --git a/disjointness.agda b/disjointness.agda deleted file mode 100644 index b83f276..0000000 --- a/disjointness.agda +++ /dev/null @@ -1,174 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import lemmas-disjointness -open import dom-eq - -module disjointness where - -- if a hole name is new in a term, then the resultant context is - -- disjoint from any singleton context with that hole name - mutual - elab-new-disjoint-synth : ∀ { e u τ d Δ Γ Γ' τ'} → - hole-name-new e u → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - Δ ## (■ (u , Γ' , τ')) - elab-new-disjoint-synth HNConst ESConst = empty-disj (■ (_ , _ , _)) - elab-new-disjoint-synth (HNAsc hn) (ESAsc x) = elab-new-disjoint-ana hn x - elab-new-disjoint-synth HNVar (ESVar x₁) = empty-disj (■ (_ , _ , _)) - elab-new-disjoint-synth (HNLam1 hn) () - elab-new-disjoint-synth (HNLam2 hn) (ESLam x₁ exp) = elab-new-disjoint-synth hn exp - elab-new-disjoint-synth (HNHole x) ESEHole = disjoint-singles x - elab-new-disjoint-synth (HNNEHole x hn) (ESNEHole x₁ exp) = disjoint-parts (elab-new-disjoint-synth hn exp) (disjoint-singles x) - elab-new-disjoint-synth (HNAp hn hn₁) (ESAp x x₁ x₂ x₃ x₄ x₅) = - disjoint-parts (elab-new-disjoint-ana hn x₄) - (elab-new-disjoint-ana hn₁ x₅) - - elab-new-disjoint-ana : ∀ { e u τ d Δ Γ Γ' τ' τ2} → - hole-name-new e u → - Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ → - Δ ## (■ (u , Γ' , τ')) - elab-new-disjoint-ana hn (EASubsume x x₁ x₂ x₃) = elab-new-disjoint-synth hn x₂ - elab-new-disjoint-ana (HNLam1 hn) (EALam x₁ x₂ ex) = elab-new-disjoint-ana hn ex - elab-new-disjoint-ana (HNHole x) EAEHole = disjoint-singles x - elab-new-disjoint-ana (HNNEHole x hn) (EANEHole x₁ x₂) = disjoint-parts (elab-new-disjoint-synth hn x₂) (disjoint-singles x) - - -- dual of the above: if elaborating a term produces a context that's - -- disjoint with a singleton context, it must be that the index is a new - -- hole name in the original term - mutual - elab-disjoint-new-synth : ∀{ e τ d Δ u Γ Γ' τ'} → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - Δ ## (■ (u , Γ' , τ')) → - hole-name-new e u - elab-disjoint-new-synth ESConst disj = HNConst - elab-disjoint-new-synth (ESVar x₁) disj = HNVar - elab-disjoint-new-synth (ESLam x₁ ex) disj = HNLam2 (elab-disjoint-new-synth ex disj) - elab-disjoint-new-synth (ESAp {Δ1 = Δ1} x x₁ x₂ x₃ x₄ x₅) disj - with elab-disjoint-new-ana x₄ (disjoint-union1 disj) | elab-disjoint-new-ana x₅ (disjoint-union2 {Γ1 = Δ1} disj) - ... | ih1 | ih2 = HNAp ih1 ih2 - elab-disjoint-new-synth {Γ = Γ} ESEHole disj = HNHole (singles-notequal disj) - elab-disjoint-new-synth (ESNEHole {Δ = Δ} x ex) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj)) - (elab-disjoint-new-synth ex (disjoint-union1 disj)) - elab-disjoint-new-synth (ESAsc x) disj = HNAsc (elab-disjoint-new-ana x disj) - - elab-disjoint-new-ana : ∀{ e τ d Δ u Γ Γ' τ2 τ'} → - Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ → - Δ ## (■ (u , Γ' , τ')) → - hole-name-new e u - elab-disjoint-new-ana (EALam x₁ x₂ ex) disj = HNLam1 (elab-disjoint-new-ana ex disj) - elab-disjoint-new-ana (EASubsume x x₁ x₂ x₃) disj = elab-disjoint-new-synth x₂ disj - elab-disjoint-new-ana EAEHole disj = HNHole (singles-notequal disj) - elab-disjoint-new-ana (EANEHole {Δ = Δ} x x₁) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj)) - (elab-disjoint-new-synth x₁ (disjoint-union1 disj)) - - -- collect up the hole names of a term as the indices of a trivial contex - data holes : (e : hexp) (H : ⊤ ctx) → Set where - HConst : holes c ∅ - HAsc : ∀{e τ H} → holes e H → holes (e ·: τ) H - HVar : ∀{x} → holes (X x) ∅ - HLam1 : ∀{x e H} → holes e H → holes (·λ x e) H - HLam2 : ∀{x e τ H} → holes e H → holes (·λ x [ τ ] e) H - HEHole : ∀{u} → holes (⦇-⦈[ u ]) (■ (u , <>)) - HNEHole : ∀{e u H} → holes e H → holes (⦇⌜ e ⌟⦈[ u ]) (H ,, (u , <>)) - HAp : ∀{e1 e2 H1 H2} → holes e1 H1 → holes e2 H2 → holes (e1 ∘ e2) (H1 ∪ H2) - - -- the above judgement has mode (∀,∃). this doesn't prove uniqueness; any - -- contex that extends the one computed here will be indistinguishable - -- but we'll treat this one as canonical - find-holes : (e : hexp) → Σ[ H ∈ ⊤ ctx ](holes e H) - find-holes c = ∅ , HConst - find-holes (e ·: x) with find-holes e - ... | (h , d)= h , (HAsc d) - find-holes (X x) = ∅ , HVar - find-holes (·λ x e) with find-holes e - ... | (h , d) = h , HLam1 d - find-holes (·λ x [ x₁ ] e) with find-holes e - ... | (h , d) = h , HLam2 d - find-holes ⦇-⦈[ x ] = (■ (x , <>)) , HEHole - find-holes ⦇⌜ e ⌟⦈[ x ] with find-holes e - ... | (h , d) = h ,, (x , <>) , HNEHole d - find-holes (e1 ∘ e2) with find-holes e1 | find-holes e2 - ... | (h1 , d1) | (h2 , d2) = (h1 ∪ h2 ) , (HAp d1 d2) - - -- if a hole name is new then it's apart from the collection of hole - -- names - lem-apart-new : ∀{e H u} → holes e H → hole-name-new e u → u # H - lem-apart-new HConst HNConst = refl - lem-apart-new (HAsc h) (HNAsc hn) = lem-apart-new h hn - lem-apart-new HVar HNVar = refl - lem-apart-new (HLam1 h) (HNLam1 hn) = lem-apart-new h hn - lem-apart-new (HLam2 h) (HNLam2 hn) = lem-apart-new h hn - lem-apart-new HEHole (HNHole x) = apart-singleton (flip x) - lem-apart-new (HNEHole {u = u'} {H = H} h) (HNNEHole {u = u} x hn) = apart-parts H (■ (u' , <>)) u (lem-apart-new h hn) (apart-singleton (flip x)) - lem-apart-new (HAp {H1 = H1} {H2 = H2} h h₁) (HNAp hn hn₁) = apart-parts H1 H2 _ (lem-apart-new h hn) (lem-apart-new h₁ hn₁) - - -- if the holes of two expressions are disjoint, so are their collections - -- of hole names - holes-disjoint-disjoint : ∀{ e1 e2 H1 H2} → - holes e1 H1 → - holes e2 H2 → - holes-disjoint e1 e2 → - H1 ## H2 - holes-disjoint-disjoint HConst he2 HDConst = empty-disj _ - holes-disjoint-disjoint (HAsc he1) he2 (HDAsc hd) = holes-disjoint-disjoint he1 he2 hd - holes-disjoint-disjoint HVar he2 HDVar = empty-disj _ - holes-disjoint-disjoint (HLam1 he1) he2 (HDLam1 hd) = holes-disjoint-disjoint he1 he2 hd - holes-disjoint-disjoint (HLam2 he1) he2 (HDLam2 hd) = holes-disjoint-disjoint he1 he2 hd - holes-disjoint-disjoint HEHole he2 (HDHole x) = lem-apart-sing-disj (lem-apart-new he2 x) - holes-disjoint-disjoint (HNEHole he1) he2 (HDNEHole x hd) = disjoint-parts (holes-disjoint-disjoint he1 he2 hd) (lem-apart-sing-disj (lem-apart-new he2 x)) - holes-disjoint-disjoint (HAp he1 he2) he3 (HDAp hd hd₁) = disjoint-parts (holes-disjoint-disjoint he1 he3 hd) (holes-disjoint-disjoint he2 he3 hd₁) - - -- the holes of an expression have the same domain as the context - -- produced during expansion; that is, we don't add anything we don't - -- find in the term during expansion. - mutual - holes-delta-ana : ∀{Γ H e τ d τ' Δ} → - holes e H → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - dom-eq Δ H - holes-delta-ana (HLam1 h) (EALam x₁ x₂ exp) = holes-delta-ana h exp - holes-delta-ana h (EASubsume x x₁ x₂ x₃) = holes-delta-synth h x₂ - holes-delta-ana (HEHole {u = u}) EAEHole = dom-single u - holes-delta-ana (HNEHole {u = u} h) (EANEHole x x₁) = - dom-union (##-comm (lem-apart-sing-disj (lem-apart-new h (elab-disjoint-new-synth x₁ x)))) - (holes-delta-synth h x₁) - (dom-single u) - - holes-delta-synth : ∀{Γ H e τ d Δ} → - holes e H → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - dom-eq Δ H - holes-delta-synth HConst ESConst = dom-∅ - holes-delta-synth (HAsc h) (ESAsc x) = holes-delta-ana h x - holes-delta-synth HVar (ESVar x₁) = dom-∅ - holes-delta-synth (HLam2 h) (ESLam x₁ exp) = holes-delta-synth h exp - holes-delta-synth (HEHole {u = u}) ESEHole = dom-single u - holes-delta-synth (HNEHole {u = u} h) (ESNEHole x exp) = dom-union ((##-comm (lem-apart-sing-disj (lem-apart-new h (elab-disjoint-new-synth exp x))))) - (holes-delta-synth h exp) - (dom-single u) - holes-delta-synth (HAp h h₁) (ESAp x x₁ x₂ x₃ x₄ x₅) = dom-union (holes-disjoint-disjoint h h₁ x) (holes-delta-ana h x₄) (holes-delta-ana h₁ x₅) - - -- this is the main result of this file: - -- - -- if you elaborate two hole-disjoint expressions analytically, the Δs - -- produced are disjoint. - -- - -- note that this is likely true for synthetic expansions in much the - -- same way, but we only prove half of the usual pair here because that's - -- all we need to establish expansion generality and elaborability. the - -- proof technique here is explcitly *not* structurally inductive on the - -- expansion judgement, because that approach relies on weakening of - -- expansion, which is false because of the substitution contexts. giving - -- expansion weakning would take away unicity, so we avoid the whole - -- question. - elab-ana-disjoint : ∀{ e1 e2 τ1 τ2 e1' e2' τ1' τ2' Γ Δ1 Δ2 } → - holes-disjoint e1 e2 → - Γ ⊢ e1 ⇐ τ1 ~> e1' :: τ1' ⊣ Δ1 → - Γ ⊢ e2 ⇐ τ2 ~> e2' :: τ2' ⊣ Δ2 → - Δ1 ## Δ2 - elab-ana-disjoint {e1} {e2} hd ana1 ana2 - with find-holes e1 | find-holes e2 - ... | (_ , he1) | (_ , he2) = dom-eq-disj (holes-disjoint-disjoint he1 he2 hd) - (holes-delta-ana he1 ana1) - (holes-delta-ana he2 ana2) diff --git a/dom-eq.agda b/dom-eq.agda deleted file mode 100644 index 4d345e8..0000000 --- a/dom-eq.agda +++ /dev/null @@ -1,77 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import lemmas-disjointness - - -module dom-eq where - -- main definition: two contexts are domain-equal when they produce (Some - -- x) on the same indices. note that the context need not map indices to - -- even the same type of contents; this is just a property about the - -- domains. the proofs that follow establish that this property is - -- respected in the appropriate ways by the context maniupulation - -- operators we use in the other judgements. - dom-eq : {A B : Set} → A ctx → B ctx → Set - dom-eq {A} {B} C1 C2 = ((n : Nat) → Σ[ x ∈ A ]( C1 n == Some x) → (Σ[ y ∈ B ](C2 n == Some y)))× - ((n : Nat) → Σ[ y ∈ B ]( C2 n == Some y) → (Σ[ x ∈ A ](C1 n == Some x))) - - -- the empty context has the same domain as itself - dom-∅ : {A B : Set} → dom-eq (λ _ → None {A}) (λ _ → None {B}) - dom-∅ {A} {B} = (λ n x → abort (somenotnone (! (π2 x)))) , (λ n x → abort (somenotnone (! (π2 x)))) - - -- the singleton contexts formed with any contents but the same index has - -- the same domain - dom-single : {A B : Set} (x : Nat) {a : A} {b : B} → dom-eq (■ (x , a)) (■ (x , b)) - dom-single {A} {B} x {α} {β} = (λ n x₁ → β , (ap1 (λ qq → (■ (qq , β)) n) (! (lem-dom-eq x₁)) · x∈■ _ _)) , - (λ n x₁ → α , (ap1 (λ qq → (■ (qq , α)) n) (! (lem-dom-eq x₁)) · x∈■ _ _)) - - -- if two disjoint contexts each share a domain with two others, those - -- are also disjoint. - dom-eq-disj : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} → - H1 ## H2 → - dom-eq Δ1 H1 → - dom-eq Δ2 H2 → - Δ1 ## Δ2 - dom-eq-disj {A} {B} {Δ1} {Δ2} {H1} {H2} (d1 , d2) (de1 , de2) (de3 , de4) = guts1 , guts2 - where - guts1 : (n : Nat) → dom Δ1 n → n # Δ2 - guts1 n dom1 with ctxindirect H2 n - guts1 n dom1 | Inl x = abort (somenotnone (! (π2 x) · d1 n (de1 n dom1))) - guts1 n dom1 | Inr x with ctxindirect Δ2 n - guts1 n dom1 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de3 n x)) · x₁)) - guts1 n dom1 | Inr x₁ | Inr x = x - - guts2 : (n : Nat) → dom Δ2 n → n # Δ1 - guts2 n dom2 with ctxindirect H1 n - guts2 n dom2 | Inl x = abort (somenotnone (! (π2 x) · d2 n (de3 n dom2))) - guts2 n dom2 | Inr x with ctxindirect Δ1 n - guts2 n dom2 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de1 n x)) · x₁)) - guts2 n dom2 | Inr x₁ | Inr x = x - - -- if two sets share a domain with disjoint sets, then their union shares - -- a domain with the union - dom-union : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} → - H1 ## H2 → - dom-eq Δ1 H1 → - dom-eq Δ2 H2 → - dom-eq (Δ1 ∪ Δ2) (H1 ∪ H2) - dom-union {A} {B} {Δ1} {Δ2} {H1} {H2} disj (p1 , p2) (p3 , p4) = guts1 , guts2 - where - guts1 : (n : Nat) → - Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x) → - Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y) - guts1 n (x , eq) with ctxindirect Δ1 n - guts1 n (x₁ , eq) | Inl x with p1 n x - ... | q1 , q2 = q1 , x∈∪l H1 H2 n q1 q2 - guts1 n (x₁ , eq) | Inr x with p3 n (_ , lem-dom-union-apt1 {Δ1 = Δ1} {Δ2 = Δ2} x eq) - ... | q1 , q2 = q1 , x∈∪r H1 H2 n q1 q2 (##-comm disj) - - guts2 : (n : Nat) → - Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y) → - Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x) - guts2 n (x , eq) with ctxindirect H1 n - guts2 n (x₁ , eq) | Inl x with p2 n x - ... | q1 , q2 = q1 , x∈∪l Δ1 Δ2 n q1 q2 - guts2 n (x₁ , eq) | Inr x with p4 n (_ , lem-dom-union-apt2 {Δ1 = H2} {Δ2 = H1} x (tr (λ qq → qq n == Some x₁) (∪comm H1 H2 disj) eq)) - ... | q1 , q2 = q1 , x∈∪r Δ1 Δ2 n q1 q2 (##-comm (dom-eq-disj disj (p1 , p2) (p3 , p4))) diff --git a/elaborability.agda b/elaborability.agda index f9ed5e0..d100d68 100644 --- a/elaborability.agda +++ b/elaborability.agda @@ -1,51 +1,57 @@ open import Nat open import Prelude +open import core-type +open import core-exp open import core -open import contexts -open import htype-decidable -open import lemmas-matching -open import disjointness +open import lemmas-meet +open import lemmas-prec +open import type-assignment-unicity module elaborability where + mutual - elaborability-synth : {Γ : tctx} {e : hexp} {τ : htyp} → - Γ ⊢ e => τ → - Σ[ d ∈ ihexp ] Σ[ Δ ∈ hctx ] - (Γ ⊢ e ⇒ τ ~> d ⊣ Δ) - elaborability-synth SConst = _ , _ , ESConst - elaborability-synth (SAsc {τ = τ} wt) - with elaborability-ana wt - ... | _ , _ , τ' , D = _ , _ , ESAsc D - elaborability-synth (SVar x) = _ , _ , ESVar x - elaborability-synth (SAp dis wt1 m wt2) - with elaborability-ana (ASubsume wt1 (match-consist m)) | elaborability-ana wt2 - ... | _ , _ , _ , D1 | _ , _ , _ , D2 = _ , _ , ESAp dis (elab-ana-disjoint dis D1 D2) wt1 m D1 D2 - elaborability-synth SEHole = _ , _ , ESEHole - elaborability-synth (SNEHole new wt) - with elaborability-synth wt - ... | d' , Δ' , wt' = _ , _ , ESNEHole (elab-new-disjoint-synth new wt') wt' - elaborability-synth (SLam x₁ wt) - with elaborability-synth wt - ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt' + elaborability-synth : ∀{Γ e τ} → + Γ ⊢ e => τ → + Σ[ d ∈ ihexp ] (Γ ⊢ e ⇒ τ ~> d) + elaborability-synth SConst = c , ESConst + elaborability-synth (SAsc wf ana) with elaborability-ana ana + ... | d , τ , ana' = d ⟨ τ ⇒ _ ⟩ , ESAsc wf ana' + elaborability-synth (SVar x) = X _ , ESVar x + elaborability-synth (SAp syn x ana) with elaborability-synth syn | elaborability-ana (ASubsume syn (⊑t-consist (π1 (⊓-lb x)))) | elaborability-ana ana + ... | d1 , syn' | d2 , τ1 , ana1 | d3 , τ2 , ana2 = ((d2 ⟨ τ1 ⇒ _ ⟩) ∘ (d3 ⟨ _ ⇒ _ ⟩)) , (ESAp syn x ana1 ana2) + elaborability-synth SEHole = ⦇-⦈ , ESEHole + elaborability-synth (SNEHole syn) with elaborability-synth syn + ... | d , elab = ⦇⌜ d ⌟⦈ , ESNEHole elab + elaborability-synth (SLam x syn) with elaborability-synth syn + ... | d , elab = (·λ[ _ ] d) , ESLam x elab + elaborability-synth (STLam syn) with elaborability-synth syn + ... | d , elab = ·Λ d , ESTLam elab + elaborability-synth (STAp x syn x₁ refl) with elaborability-ana (ASubsume syn (⊑t-consist (π1 (⊓-lb x₁)))) + ... | d , τ , elab = ((d ⟨ τ ⇒ ·∀ _ ⟩) < _ >) , (ESTAp x syn x₁ elab refl) + + is-tlam : (e : hexp) → ((e' : hexp) → e ≠ ·Λ e') + ( Σ[ e' ∈ hexp ] (e == ·Λ e') ) + is-tlam c = Inl (λ x ()) + is-tlam (e ·: x) = Inl (λ x ()) + is-tlam (X x) = Inl (λ x ()) + is-tlam (·λ e) = Inl (λ x ()) + is-tlam (·λ[ x ] e) = Inl (λ x ()) + is-tlam (·Λ e) = Inr (e , refl) + is-tlam ⦇-⦈ = Inl (λ x ()) + is-tlam ⦇⌜ e ⌟⦈ = Inl (λ x ()) + is-tlam (e ∘ e₁) = Inl (λ x ()) + is-tlam (e < x >) = Inl (λ x ()) - elaborability-ana : {Γ : tctx} {e : hexp} {τ : htyp} → - Γ ⊢ e <= τ → - Σ[ d ∈ ihexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ] - (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ) - elaborability-ana {e = e} (ASubsume D x₁) - with elaborability-synth D - -- these cases just pass through, but we need to pattern match so we can prove things aren't holes - elaborability-ana {e = c} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ - elaborability-ana {e = e ·: x} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ - elaborability-ana {e = X x} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ - elaborability-ana {e = ·λ x e} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ - elaborability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂ - elaborability-ana {e = e1 ∘ e2} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ - -- the two holes are special-cased - elaborability-ana {e = ⦇-⦈[ x ]} (ASubsume _ _ ) | _ , _ , _ = _ , _ , _ , EAEHole - elaborability-ana {Γ} {⦇⌜ e ⌟⦈[ x ]} (ASubsume (SNEHole new wt) x₂) | _ , _ , ESNEHole x₁ D' with elaborability-synth wt - ... | w , y , z = _ , _ , _ , EANEHole (elab-new-disjoint-synth new z) z - -- the lambda cases - elaborability-ana (ALam x₁ m wt) - with elaborability-ana wt - ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ m D' + elaborability-ana : ∀{Γ e τ} → + Γ ⊢ e <= τ → + Σ[ d ∈ ihexp ] Σ[ τ' ∈ htyp ] (Γ ⊢ e ⇐ τ ~> d :: τ') + elaborability-ana (ALam x ana) with elaborability-ana ana + ... | d , τ , elab = (·λ[ _ ] d) , _ ==> τ , EALam x elab + elaborability-ana (ATLam x ana) with elaborability-ana ana + ... | d , τ , elab = ·Λ d , ·∀ τ , EATLam x elab + elaborability-ana {e = e} (ASubsume syn meet) with is-tlam e + elaborability-ana {e = e} (ASubsume syn meet) | Inl neq with elaborability-synth syn | ⊓-ability meet + elaborability-ana {e = e} (ASubsume syn meet) | Inl neq | d , elab | τ , meet' = _ , _ , (EASubsume (Subsumable neq) elab meet') + elaborability-ana {e = .(·Λ e')} (ASubsume (STLam syn) ConsistHole2) | Inr (e' , refl) with elaborability-ana (ASubsume syn ConsistHole2) + elaborability-ana {e = .(·Λ e')} (ASubsume (STLam syn) ConsistHole2) | Inr (e' , refl) | d , τ , elab = ·Λ d , ·∀ τ , EATLam MeetHoleL elab + elaborability-ana {e = .(·Λ e')} (ASubsume (STLam syn) (ConsistForall con)) | Inr (e' , refl) with elaborability-ana (ASubsume syn con) + elaborability-ana {e = .(·Λ e')} (ASubsume (STLam syn) (ConsistForall con)) | Inr (e' , refl) | d , τ , elab = ·Λ d , ·∀ τ , EATLam (MeetForall MeetHoleR) elab \ No newline at end of file diff --git a/elaboration-generality.agda b/elaboration-generality.agda index 052a530..aa80c34 100644 --- a/elaboration-generality.agda +++ b/elaboration-generality.agda @@ -1,26 +1,30 @@ open import Nat open import Prelude +open import core-type +open import core-exp open import core -open import disjointness +open import lemmas-meet module elaboration-generality where - mutual - elaboration-generality-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - Γ ⊢ e => τ + + mutual + + elaboration-generality-synth : ∀{Γ e τ d} → + Γ ⊢ e ⇒ τ ~> d → + Γ ⊢ e => τ elaboration-generality-synth ESConst = SConst - elaboration-generality-synth (ESVar x₁) = SVar x₁ - elaboration-generality-synth (ESLam apt ex) with elaboration-generality-synth ex - ... | ih = SLam apt ih - elaboration-generality-synth (ESAp dis _ a x₁ x₂ x₃) = SAp dis a x₁ (elaboration-generality-ana x₃) + elaboration-generality-synth (ESVar x) = SVar x + elaboration-generality-synth (ESLam x syn) = SLam x (elaboration-generality-synth syn) + elaboration-generality-synth (ESTLam syn) = STLam (elaboration-generality-synth syn) + elaboration-generality-synth (ESAp x x₁ x₂ ana) = SAp x x₁ (elaboration-generality-ana ana) + elaboration-generality-synth (ESTAp x x₁ x₂ x₃ x₄) = STAp x x₁ x₂ x₄ elaboration-generality-synth ESEHole = SEHole - elaboration-generality-synth (ESNEHole dis ex) = SNEHole (elab-disjoint-new-synth ex dis) (elaboration-generality-synth ex) - elaboration-generality-synth (ESAsc x) = SAsc (elaboration-generality-ana x) + elaboration-generality-synth (ESNEHole syn) = SNEHole (elaboration-generality-synth syn) + elaboration-generality-synth (ESAsc x ana) = SAsc x (elaboration-generality-ana ana) - elaboration-generality-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - Γ ⊢ e <= τ - elaboration-generality-ana (EALam apt m ex) = ALam apt m (elaboration-generality-ana ex) - elaboration-generality-ana (EASubsume x x₁ x₂ x₃) = ASubsume (elaboration-generality-synth x₂) x₃ - elaboration-generality-ana EAEHole = ASubsume SEHole TCHole1 - elaboration-generality-ana (EANEHole dis x) = ASubsume (SNEHole (elab-disjoint-new-synth x dis) (elaboration-generality-synth x)) TCHole1 + elaboration-generality-ana : ∀{Γ e τ τ' d} → + Γ ⊢ e ⇐ τ ~> d :: τ' → + Γ ⊢ e <= τ + elaboration-generality-ana (EALam x ana) = ALam x (elaboration-generality-ana ana) + elaboration-generality-ana (EATLam x ana) = ATLam x (elaboration-generality-ana ana) + elaboration-generality-ana (EASubsume x x₁ x₂) = ASubsume (elaboration-generality-synth x₁) (⊓-consist x₂) \ No newline at end of file diff --git a/elaboration-unicity.agda b/elaboration-unicity.agda index be64eee..3333c91 100644 --- a/elaboration-unicity.agda +++ b/elaboration-unicity.agda @@ -1,53 +1,48 @@ open import Nat open import Prelude +open import core-type +open import core-exp open import core -open import contexts -open import synth-unicity -open import lemmas-matching +open import lemmas-meet +open import type-assignment-unicity module elaboration-unicity where + mutual - elaboration-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : ihexp} {Δ1 Δ2 : hctx} → - Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 → - Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 → - τ1 == τ2 × d1 == d2 × Δ1 == Δ2 - elaboration-unicity-synth ESConst ESConst = refl , refl , refl - elaboration-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl - elaboration-unicity-synth (ESLam apt1 d1) (ESLam apt2 d2) - with elaboration-unicity-synth d1 d2 - ... | ih1 , ih2 , ih3 = ap1 _ ih1 , ap1 _ ih2 , ih3 - elaboration-unicity-synth (ESAp _ _ x x₁ x₂ x₃) (ESAp _ _ x₄ x₅ x₆ x₇) - with synthunicity x x₄ - ... | refl with match-unicity x₁ x₅ - ... | refl with elaboration-unicity-ana x₂ x₆ - ... | refl , refl , refl with elaboration-unicity-ana x₃ x₇ - ... | refl , refl , refl = refl , refl , refl - elaboration-unicity-synth ESEHole ESEHole = refl , refl , refl - elaboration-unicity-synth (ESNEHole _ d1) (ESNEHole _ d2) - with elaboration-unicity-synth d1 d2 - ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3 - elaboration-unicity-synth (ESAsc x) (ESAsc x₁) - with elaboration-unicity-ana x x₁ - ... | refl , refl , refl = refl , refl , refl - elaboration-unicity-ana : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {d1 d2 : ihexp} {Δ1 Δ2 : hctx} → - Γ ⊢ e ⇐ τ ~> d1 :: τ1 ⊣ Δ1 → - Γ ⊢ e ⇐ τ ~> d2 :: τ2 ⊣ Δ2 → - d1 == d2 × τ1 == τ2 × Δ1 == Δ2 - elaboration-unicity-ana (EALam x₁ m D1) (EALam x₂ m2 D2) - with match-unicity m m2 - ... | refl with elaboration-unicity-ana D1 D2 - ... | refl , refl , refl = refl , refl , refl - elaboration-unicity-ana (EALam x₁ m D1) (EASubsume x₂ x₃ () x₅) - elaboration-unicity-ana (EASubsume x₁ x₂ () x₄) (EALam x₅ m D2) - elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇) - with elaboration-unicity-synth x₂ x₆ - ... | refl , refl , refl = refl , refl , refl - elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = abort (x _ refl) - elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole _ x₄) = abort (x₁ _ _ refl) - elaboration-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = abort (x _ refl) - elaboration-unicity-ana EAEHole EAEHole = refl , refl , refl - elaboration-unicity-ana (EANEHole _ x) (EASubsume x₁ x₂ x₃ x₄) = abort (x₂ _ _ refl) - elaboration-unicity-ana (EANEHole _ x) (EANEHole _ x₁) - with elaboration-unicity-synth x x₁ - ... | refl , refl , refl = refl , refl , refl + elaboration-unicity-synth : ∀{Γ e τ1 τ2 d1 d2} → + Γ ⊢ e ⇒ τ1 ~> d1 → + Γ ⊢ e ⇒ τ2 ~> d2 → + τ1 == τ2 × d1 == d2 + elaboration-unicity-synth ESConst ESConst = refl , refl + elaboration-unicity-synth (ESVar x) (ESVar x₁) = context-unicity x x₁ , refl + elaboration-unicity-synth (ESLam x syn1) (ESLam x₁ syn2) with elaboration-unicity-synth syn1 syn2 + ... | refl , refl = refl , refl + elaboration-unicity-synth (ESTLam syn1) (ESTLam syn2) with elaboration-unicity-synth syn1 syn2 + ... | refl , refl = refl , refl + elaboration-unicity-synth (ESAp x x₁ x₂ x₃) (ESAp x₄ x₅ x₆ x₇) rewrite synth-unicity x x₄ with ⊓-unicity x₁ x₅ + ... | refl with elaboration-unicity-ana x₂ x₆ | elaboration-unicity-ana x₃ x₇ + ... | refl , refl | refl , refl = refl , refl + elaboration-unicity-synth (ESTAp x x₁ x₂ x₃ refl) (ESTAp x₅ x₆ x₇ x₈ refl) rewrite synth-unicity x₁ x₆ with ⊓-unicity x₂ x₇ + ... | refl with elaboration-unicity-ana x₃ x₈ + ... | refl , refl = refl , refl + elaboration-unicity-synth ESEHole ESEHole = refl , refl + elaboration-unicity-synth (ESNEHole syn1) (ESNEHole syn2) with elaboration-unicity-synth syn1 syn2 + ... | refl , refl = refl , refl + elaboration-unicity-synth (ESAsc x x₁) (ESAsc x₂ x₃) with elaboration-unicity-ana x₁ x₃ + ... | refl , refl = refl , refl + + elaboration-unicity-ana : ∀{Γ e τ τ1 τ2 d1 d2} → + Γ ⊢ e ⇐ τ ~> d1 :: τ1 → + Γ ⊢ e ⇐ τ ~> d2 :: τ2 → + d1 == d2 × τ1 == τ2 + elaboration-unicity-ana (EALam x ana1) (EALam x₁ ana2) with ⊓-unicity x x₁ + ... | refl with elaboration-unicity-ana ana1 ana2 + ... | refl , refl = refl , refl + elaboration-unicity-ana (EATLam x ana1) (EATLam x₁ ana2) with ⊓-unicity x x₁ + ... | refl with elaboration-unicity-ana ana1 ana2 + ... | refl , refl = refl , refl + elaboration-unicity-ana (EATLam x ana1) (EASubsume (Subsumable neq) _ _) = abort (neq _ refl) + elaboration-unicity-ana (EASubsume (Subsumable neq) _ _) (EATLam x ana2) = abort (neq _ refl) + elaboration-unicity-ana (EASubsume x x₁ x₂) (EASubsume x₃ x₄ x₅) with elaboration-unicity-synth x₁ x₄ + ... | refl , refl rewrite ⊓-unicity x₂ x₅ = refl , refl \ No newline at end of file diff --git a/eq-dec.agda b/eq-dec.agda new file mode 100644 index 0000000..5110032 --- /dev/null +++ b/eq-dec.agda @@ -0,0 +1,53 @@ + +open import Prelude +open import Nat +open import core-type +open import core-exp + +module eq-dec where + + htyp-eq-dec : (τ1 τ2 : htyp) → (τ1 == τ2) + (τ1 ≠ τ2) + htyp-eq-dec b b = Inl refl + htyp-eq-dec b (T x) = Inr (λ ()) + htyp-eq-dec b ⦇-⦈ = Inr (λ ()) + htyp-eq-dec b (τ2 ==> τ3) = Inr (λ ()) + htyp-eq-dec b (·∀ τ2) = Inr (λ ()) + htyp-eq-dec (T x) b = Inr (λ ()) + htyp-eq-dec (T x) (T y) with natEQ x y + ... | Inl refl = Inl refl + ... | Inr neq = Inr λ x₁ → neq (h1 x₁) + where + h1 : T x == T y → x == y + h1 refl = refl + htyp-eq-dec (T x) ⦇-⦈ = Inr (λ ()) + htyp-eq-dec (T x) (τ2 ==> τ3) = Inr (λ ()) + htyp-eq-dec (T x) (·∀ τ2) = Inr (λ ()) + htyp-eq-dec ⦇-⦈ b = Inr (λ ()) + htyp-eq-dec ⦇-⦈ (T x) = Inr (λ ()) + htyp-eq-dec ⦇-⦈ ⦇-⦈ = Inl refl + htyp-eq-dec ⦇-⦈ (τ2 ==> τ3) = Inr (λ ()) + htyp-eq-dec ⦇-⦈ (·∀ τ2) = Inr (λ ()) + htyp-eq-dec (τ1 ==> τ2) b = Inr (λ ()) + htyp-eq-dec (τ1 ==> τ2) (T x) = Inr (λ ()) + htyp-eq-dec (τ1 ==> τ2) ⦇-⦈ = Inr (λ ()) + htyp-eq-dec (τ1 ==> τ2) (τ3 ==> τ4) with htyp-eq-dec τ1 τ3 | htyp-eq-dec τ2 τ4 + ... | Inl refl | Inl refl = Inl refl + ... | _ | Inr x = Inr λ x₁ → x (h1 x₁) + where + h1 : (τ1 ==> τ2) == (τ3 ==> τ4) → τ2 == τ4 + h1 refl = refl + ... | Inr x | _ = Inr λ x₁ → x (h1 x₁) + where + h1 : (τ1 ==> τ2) == (τ3 ==> τ4) → τ1 == τ3 + h1 refl = refl + htyp-eq-dec (τ1 ==> τ2) (·∀ τ3) = Inr (λ ()) + htyp-eq-dec (·∀ τ1) b = Inr (λ ()) + htyp-eq-dec (·∀ τ1) (T x) = Inr (λ ()) + htyp-eq-dec (·∀ τ1) ⦇-⦈ = Inr (λ ()) + htyp-eq-dec (·∀ τ1) (τ2 ==> τ3) = Inr (λ ()) + htyp-eq-dec (·∀ τ1) (·∀ τ2) with htyp-eq-dec τ1 τ2 + ... | Inl refl = Inl refl + ... | Inr neq = Inr λ x → neq (h1 x) + where + h1 : ·∀ τ1 == ·∀ τ2 → τ1 == τ2 + h1 refl = refl \ No newline at end of file diff --git a/exchange.agda b/exchange.agda deleted file mode 100644 index ab55949..0000000 --- a/exchange.agda +++ /dev/null @@ -1,72 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import lemmas-disjointness - -module exchange where - -- exchanging just two disequal elements produces the same context - swap-little : {A : Set} {x y : Nat} {τ1 τ2 : A} → (x ≠ y) → - ((■ (x , τ1)) ,, (y , τ2)) == ((■ (y , τ2)) ,, (x , τ1)) - swap-little {A} {x} {y} {τ1} {τ2} neq = ∪comm (■ (x , τ1)) - (■ (y , τ2)) - (disjoint-singles neq) - - -- really the core of all the exchange arguments: contexts with two - -- disequal elements exchanged are the same. we reassociate the unions, - -- swap as above, and then associate them back. - -- - -- note that this is generic in the contents of the context. the proofs - -- below show the exchange properties that we actually need in the - -- various other proofs; the remaning exchange properties for both Δ and - -- Γ positions for all the other hypothetical judgements are exactly in - -- this pattern. - swap : {A : Set} {x y : Nat} {τ1 τ2 : A} (Γ : A ctx) (x≠y : x == y → ⊥) → - ((Γ ,, (x , τ1)) ,, (y , τ2)) == ((Γ ,, (y , τ2)) ,, (x , τ1)) - swap {A} {x} {y} {τ1} {τ2} Γ neq = - (∪assoc Γ (■ (x , τ1)) (■ (y , τ2)) (disjoint-singles neq) ) · - (ap1 (λ qq → Γ ∪ qq) (swap-little neq) · - ! (∪assoc Γ (■ (y , τ2)) (■ (x , τ1)) (disjoint-singles (flip neq)))) - - -- the above exchange principle used via transport in the judgements we needed - exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} → - x ≠ y → - Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' → - Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ' - exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y = - tr (λ qq → Δ , qq ⊢ σ :s: Γ') (swap Γ x≠y) - - exchange-synth : ∀{Γ x y τ τ1 τ2 e} - → x ≠ y - → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e => τ - → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e => τ - exchange-synth {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq = - tr (λ qq → qq ⊢ e => τ) (swap Γ neq) - - exchange-ana : ∀{Γ x y τ τ1 τ2 e} - → x ≠ y - → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e <= τ - → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e <= τ - exchange-ana {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq = - tr (λ qq → qq ⊢ e <= τ) (swap Γ neq) - - exchange-elab-synth : ∀{Γ x y τ1 τ2 e τ d Δ} → - x ≠ y → - (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e ⇒ τ ~> d ⊣ Δ → - (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e ⇒ τ ~> d ⊣ Δ - exchange-elab-synth {Γ = Γ} {e = e} {τ = τ} {d = d } {Δ = Δ} neq = - tr (λ qq → qq ⊢ e ⇒ τ ~> d ⊣ Δ) (swap Γ neq) - - exchange-elab-ana : ∀ {Γ x y τ1 τ2 τ τ' d e Δ} → - x ≠ y → - (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ - exchange-elab-ana {Γ = Γ} {τ = τ} {τ' = τ'} {d = d} {e = e} {Δ = Δ} neq = - tr (λ qq → qq ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ) (swap Γ neq) - - exchange-ta-Γ : ∀{Γ x y τ1 τ2 d τ Δ } → - x ≠ y → - Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ d :: τ → - Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ d :: τ - exchange-ta-Γ {Γ = Γ} {d = d} {τ = τ} {Δ = Δ} neq = - tr (λ qq → Δ , qq ⊢ d :: τ) (swap Γ neq) diff --git a/finality.agda b/finality.agda index efe0411..5f221a4 100644 --- a/finality.agda +++ b/finality.agda @@ -1,5 +1,6 @@ open import Prelude open import core +open import core-exp open import progress-checks diff --git a/focus-formation.agda b/focus-formation.agda deleted file mode 100644 index 97d13d9..0000000 --- a/focus-formation.agda +++ /dev/null @@ -1,12 +0,0 @@ -open import core - -module focus-formation where - -- every ε is an evaluation context -- trivially, here, since we don't - -- include any of the premises in red brackets about finality - focus-formation : ∀{d d' ε} → d == ε ⟦ d' ⟧ → ε evalctx - focus-formation FHOuter = ECDot - focus-formation (FHAp1 sub) = ECAp1 (focus-formation sub) - focus-formation (FHAp2 sub) = ECAp2 (focus-formation sub) - focus-formation (FHNEHole sub) = ECNEHole (focus-formation sub) - focus-formation (FHCast sub) = ECCast (focus-formation sub) - focus-formation (FHFailedCast x) = ECFailedCast (focus-formation x) diff --git a/graduality.agda b/graduality.agda new file mode 100644 index 0000000..a8b120b --- /dev/null +++ b/graduality.agda @@ -0,0 +1,173 @@ +open import Nat +open import Prelude +open import core-type +open import core-exp +open import core +open import lemmas-index +open import lemmas-consistency +open import lemmas-prec +open import lemmas-meet +open import lemmas-wf + +open import typed-elaboration +open import type-assignment-unicity + +module graduality where + + mutual + + graduality-ana : + ∀{τ τ' e e' Γ Γ'} → + (Γ ⊑c Γ') → + (τ ⊑t τ') → + (e ⊑ e') → + (Γ ⊢ e <= τ) → + (Γ' ⊢ e' <= τ') + + graduality-ana precc prect PEHole ana = ASubsume SEHole ConsistHole1 + graduality-ana precc prect prec (ASubsume syn consist) with graduality-syn precc prec syn + ... | τ' , syn' , prect' = ASubsume syn' (⊑t-consist-left (⊑t-consist-right consist prect') prect) + graduality-ana precc prect (PLam1 prec) (ALam meet ana) with ⊑t-⊓ prect (⊑t-refl _) meet + ... | .(_ ==> _) , meet' , PTArr prect1 prect2 = ALam meet' (graduality-ana (PCVar prect1 precc) prect2 prec ana) + graduality-ana precc prect (PTLam prec) (ATLam meet ana) with ⊑t-⊓ prect (⊑t-refl _) meet + ... | .(·∀ _) , meet' , PTForall prect' = ATLam meet' (graduality-ana (PCTVar precc) prect' prec ana) + + graduality-syn : + ∀{e e' Γ Γ' τ} → + (Γ ⊑c Γ') → + (e ⊑ e') → + (Γ ⊢ e => τ) → + Σ[ τ' ∈ htyp ] ((Γ' ⊢ e' => τ') × (τ ⊑t τ')) + graduality-syn precc PEHole syn = ⦇-⦈ , SEHole , PTHole + graduality-syn precc PConst SConst = b , SConst , PTBase + graduality-syn precc PVar (SVar inctx) with ⊑c-var inctx precc + ... | τ' , inctx' , prect = τ' , SVar inctx' , prect + graduality-syn {e' = e' ·: τ'} precc (PAsc prec prect) (SAsc wf ana) + = τ' , (SAsc (wf-⊑t wf precc prect) (graduality-ana precc prect prec ana)) , prect + graduality-syn precc (PLam2 prec prect) (SLam wf syn) with graduality-syn (PCVar prect precc) prec syn + ... | τ' , syn' , prect' = _ , SLam (wf-⊑t wf precc prect) syn' , PTArr prect prect' + graduality-syn precc (PTLam prec) (STLam syn) with graduality-syn (PCTVar precc) prec syn + ... | τ' , syn' , prect' = _ , STLam syn' , PTForall prect' + graduality-syn precc (PNEHole prec) (SNEHole syn) with graduality-syn precc prec syn + ... | τ' , syn' , prect' = _ , SNEHole syn' , PTHole + graduality-syn precc (PAp prec1 prec2) (SAp syn meet ana) with graduality-syn precc prec1 syn + ... | τ' , wt' , prect with ⊑t-⊓ prect (⊑t-refl _) meet + ... | .(_ ==> _) , meet' , PTArr prect' prect'' = _ , SAp wt' meet' (graduality-ana precc prect' prec2 ana) , prect'' + graduality-syn precc (PTAp {τ2 = τ2} prec prect) (STAp wf syn meet subst) rewrite (sym subst) with graduality-syn precc prec syn + ... | τ' , syn' , prect' with ⊑t-⊓ prect' (⊑t-refl _) meet + ... | .(·∀ _) , meet' , PTForall prect'' = _ , STAp (wf-⊑t wf precc prect) syn' meet' refl , ⊑t-TTsub prect prect'' + + graduality1 : + ∀{e e' τ} → + (e ⊑ e') → + (∅ ⊢ e => τ) → + Σ[ τ' ∈ htyp ] ((∅ ⊢ e' => τ') × (τ ⊑t τ')) + graduality1 prec wt = graduality-syn PCEmpty prec wt + + -- hole-or-not : (e : hexp) → ((e == ⦇-⦈) + ( Σ[ e' ∈ hexp ] (e == ⦇⌜ e' ⌟⦈) ) + ((e ≠ ⦇-⦈) × ((e' : hexp) → e ≠ ⦇⌜ e' ⌟⦈))) + -- hole-or-not c = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not (e ·: x) = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not (X x) = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not (·λ e) = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not (·λ[ x ] e) = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not (·Λ e) = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not ⦇-⦈ = Inl refl + -- hole-or-not ⦇⌜ e ⌟⦈ = Inr (Inl (e , refl)) + -- hole-or-not (e ∘ e₁) = Inr (Inr ((λ ()) , (λ x ()))) + -- hole-or-not (e < x >) = Inr (Inr ((λ ()) , (λ x ()))) + + -- mutual + + -- graduality-elab-ana : + -- ∀{e e' τ1 τ2 τ1' Γ Γ' d} → + -- (⊢ Γ ctxwf) → + -- (Γ ⊢ τ1 wf) → + -- (Γ ⊑c Γ') → + -- (τ1 ⊑t τ1') → + -- (e ⊑ e') → + -- (Γ ⊢ e ⇐ τ1 ~> d :: τ2) → + -- Σ[ d' ∈ ihexp ] Σ[ τ2' ∈ htyp ] ((Γ' ⊢ e' ⇐ τ1' ~> d' :: τ2') × (Γ , Γ' ⊢ d ⊑i d') × (τ2 ⊑t τ2')) + -- graduality-elab-ana {e' = e'} ctxwf wf precc prect prec (EASubsume neq1 neq2 syn meet) with hole-or-not e' | ⊓-lb meet + -- graduality-elab-ana ctxwf wf precc prect prec (EASubsume neq1 neq2 syn meet) | Inl refl | prect1 , prect2 = + -- _ , _ , ? , PIEHole (TACast (typed-elaboration-syn ctxwf syn) (wf-⊓ meet wf (wf-elab-syn ctxwf syn)) (~sym (⊑t-consist prect2))) (⊑t-trans prect1 prect) , ⊑t-trans prect1 prect + -- graduality-elab-ana ctxwf wf precc prect prec (EASubsume neq1 neq2 (ESNEHole syn) meet) | Inr (Inl (e' , refl)) | prect' , _ = abort (neq2 _ refl) + -- graduality-elab-ana ctxwf wf precc prect prec (EASubsume neq1 neq2 syn meet) | Inr (Inr (neq3 , neq4)) | prect2 , prect3 with graduality-elab-syn ctxwf precc prec syn + -- graduality-elab-ana ctxwf wf precc prect prec (EASubsume neq1 neq2 syn meet) | Inr (Inr (neq3 , neq4)) | prect2 , prect3 | τ2' , d' , syn' , prect1 , prec' with ⊑t-⊓ prect prect1 meet + -- ... | τ3' , meet' , prect4 = _ , _ , EASubsume neq3 neq4 syn' meet' , PICast prec' prect1 prect4 , prect4 + -- graduality-elab-ana ctxwf wf precc prect PEHole ana = let prect' = ⊑t-trans (⊑t-ana ana) prect in _ , _ , ? , PIEHole (typed-elaboration-ana ctxwf wf ana) prect' , prect' + -- graduality-elab-ana ctxwf wf precc prect (PLam1 prec) (EALam meet ana) with ⊑t-⊓ prect (⊑t-refl _) meet | wf-⊓ meet wf (WFArr WFHole WFHole) + -- ... | _ , prect1 , PTArr prect2 prect3 | WFArr wf1 wf2 with graduality-elab-ana (CtxWFExtend wf1 ctxwf) wf2 (PCExtend prect2 precc) prect3 prec ana + -- ... | _ , _ , ana' , prec' , prect' = _ , _ , EALam prect1 ana' , PILam prec' prect2 , PTArr prect2 prect' + -- graduality-elab-ana ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) with ⊑t-⊓ prect (⊑t-refl _) meet | wf-⊓ meet wf (WFForall WFHole) + -- graduality-elab-ana ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) | (·∀ τ') , meet' , PTForall prect1 | WFForall wf' with graduality-elab-ana (weakening-ctx ctxwf) wf' precc prect1 prec ana + -- graduality-elab-ana {e' = ·Λ e'} ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) | (·∀ τ') , meet' , PTForall prect1 | wf' | thing , thing2 , ana' , prec' , prect2 with hole-or-not e' + -- graduality-elab-ana ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) | ·∀ τ' , meet2 , PTForall prect1 | WFForall wf' | thing , thing2 , ana' , prec' , prect2 | Inl refl = + -- let prect3 = ⊑t-trans (PTForall (⊑t-ana ana)) (⊑t-⊓-fun prect (PTForall PTHole) meet meet2) in + -- _ , _ , EASubsume (λ ()) (λ e' ()) (ESTLam ESEHole) meet2 , PIAddCast (PITLam (PIEHole (typed-elaboration-ana (weakening-ctx ctxwf) wf' ana) PTHole)) (TATLam (typed-elaboration-ana (weakening-ctx ctxwf) wf' ana)) (PTForall PTHole) prect3 , prect3 + -- graduality-elab-ana ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) | _ , meet2 , PTForall _ | WFForall wf' | _ , thing2 , EASubsume _ neq _ _ , prec' , prect2 | Inr (Inl (e' , refl)) = abort (neq e' refl) + -- graduality-elab-ana ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) | ·∀ _ , meet2 , PTForall _ | WFForall wf' | _ , _ , EANEHole x , PINEHole prec' x₁ , prect2 | Inr (Inl (e' , refl)) = + -- _ , _ , (EASubsume (λ ()) (λ e' ()) (ESTLam (ESNEHole x)) meet2) , PIAddCast (PITLam (PINEHole prec' PTHole)) (TATLam (typed-elaboration-ana (weakening-ctx ctxwf) wf' ana)) (PTForall PTHole) (PTForall prect2) , PTForall prect2 + -- graduality-elab-ana ctxwf wf precc prect (PTLam prec) (EATLam neq1 neq2 meet ana) | ·∀ _ , meet2 , PTForall _ | WFForall wf' | _ , _ , EANEHole x , PIRemoveCast prec' TANEHole x₂ x₃ , prect2 | Inr (Inl (e' , refl)) = + -- _ , _ , (EASubsume (λ ()) (λ e' ()) (ESTLam (ESNEHole x)) meet2) , PIAddCast (PITLam (PIRemoveCast (h1 prec') TANEHole PTHole PTHole)) (TATLam (typed-elaboration-ana (weakening-ctx ctxwf) wf' ana)) (PTForall PTHole) (PTForall prect2) , PTForall prect2 + -- where + -- h1 : ∀{Θ Γ Γ' d1 d2 τ} → Θ , Γ , Γ' ⊢ d1 ⊑i ⦇⌜ d2 ⌟⦈⟨ τ ⟩ → Θ , Γ , Γ' ⊢ d1 ⊑i ⦇⌜ d2 ⌟⦈⟨ ⦇-⦈ ⟩ + -- h1 (PINEHole prec x) = PINEHole prec PTHole + -- h1 (PIRemoveCast prec _ _ _) = PIRemoveCast (h1 prec) TANEHole PTHole PTHole + -- h1 (PIBlame _ _) = PIBlame TANEHole PTHole + -- ... | Inr (Inr (neq3 , neq4)) = _ , _ , EATLam neq3 neq4 meet' ana' , PITLam prec' , PTForall prect2 + -- graduality-elab-ana ctxwf wf precc prect (PNEHole prec) (EANEHole syn) with graduality-elab-syn ctxwf precc prec syn + -- ... | τ' , d' , syn' , prect' , prec' = _ , _ , EANEHole syn' , PINEHole prec' prect , prect + + -- graduality-elab-syn : + -- ∀{e e' Γ Γ' Θ τ d} → + -- (⊢ Γ ctxwf) → + -- (Γ ⊑c Γ') → + -- (e ⊑ e') → + -- (Γ ⊢ e ⇒ τ ~> d) → + -- Σ[ τ' ∈ htyp ] Σ[ d' ∈ ihexp ] ((Γ' ⊢ e' ⇒ τ' ~> d') × (τ ⊑t τ') × (Γ , Γ' ⊢ d ⊑i d')) + -- graduality-elab-syn ctxwf precc PEHole elab = ⦇-⦈ , ⦇-⦈⟨ ⦇-⦈ ⟩ , ESEHole , PTHole , PIEHole (typed-elaboration-syn ctxwf elab) PTHole + -- graduality-elab-syn ctxwf precc PConst ESConst = b , c , ESConst , PTBase , PIConst + -- graduality-elab-syn ctxwf precc PVar (ESVar inctx) with ⊑c-var inctx precc + -- ... | τ' , inctx' , prect = _ , _ , ESVar inctx' , prect , PIVar + -- graduality-elab-syn ctxwf precc (PAsc prec x) (ESAsc wf ana) with graduality-elab-ana ctxwf wf precc x prec ana + -- ... | d' , τ2' , ana' , prec' , prect = _ , _ , ESAsc (wf-⊑t wf x) ana' , x , PICast prec' prect x + -- graduality-elab-syn ctxwf precc (PLam2 prec x) (ESLam wf elab) with graduality-elab-syn (CtxWFExtend wf ctxwf) (PCExtend x precc) prec elab + -- ... | τ' , d' , elab' , prect , prec' = _ , _ , ESLam (wf-⊑t wf x) elab' , PTArr x prect , PILam prec' x + -- graduality-elab-syn ctxwf precc (PTLam prec) (ESTLam elab) with graduality-elab-syn (weakening-ctx ctxwf) precc prec elab + -- ... | τ' , d' , elab' , prect , prec' = _ , _ , ESTLam elab' , PTForall prect , PITLam prec' + -- graduality-elab-syn ctxwf precc (PNEHole prec) (ESNEHole elab) with graduality-elab-syn ctxwf precc prec elab + -- ... | τ' , d' , elab' , prect , prec' = _ , _ , ESNEHole elab' , PTHole , PINEHole prec' PTHole + -- graduality-elab-syn ctxwf precc (PAp prec1 prec2) (ESAp syn meet ana1 ana2) with graduality-syn precc prec1 syn + -- ... | τ1' , syn' , prec1' with ⊑t-⊓ prec1' (⊑t-refl _) meet | wf-⊓ meet (wf-syn ctxwf syn) (WFArr WFHole WFHole) + -- ... | (_ ==> _) , meet' , PTArr prec3 prec4 | WFArr wf1 wf2 with graduality-elab-ana ctxwf (WFArr wf1 wf2) precc (PTArr prec3 prec4) prec1 ana1 + -- ... | d1' , τ1''' , ana1' , prec5 , prec6 with graduality-elab-ana ctxwf wf1 precc prec3 prec2 ana2 + -- ... | d2' , τ2''' , ana2' , prec7 , prec8 = + -- _ , _ , (ESAp syn' meet' ana1' ana2') , prec4 , PIAp (PICast prec5 prec6 (PTArr prec3 prec4)) (PICast prec7 prec8 prec3) + -- graduality-elab-syn ctxwf precc (PTAp prec prect) (ESTAp wf syn meet ana sub) with graduality-syn precc prec syn + -- ... | τ4' , syn' , prec1 with ⊑t-⊓ prec1 (⊑t-refl _) meet + -- ... | (·∀ τ4'') , meet' , PTForall prec2 with graduality-elab-ana ctxwf (wf-⊓ meet (wf-syn ctxwf syn) (WFForall WFHole)) precc (PTForall prec2) prec ana + -- ... | d' , τ2'' , ana' , prec3 , prec4 rewrite (sym sub) with ⊑t-⊓-fun prec1 (PTForall PTHole) meet meet' + -- ... | PTForall prec5 = _ , _ , ESTAp (wf-⊑t wf prect) syn' meet' ana' refl , + -- ⊑t-TTsub prect prec5 , PITAp (PICast prec3 prec4 (PTForall prec2)) prect + + -- graduality-type-assign : + -- ∀{d d' Γ Γ' τ} → + -- (⊢ Γ ctxwf) → + -- (Γ ⊑c Γ') → + -- (Γ , Γ' ⊢ d ⊑i d') → + -- (Γ ⊢ d :: τ) → + -- Σ[ τ' ∈ htyp ] ((Γ' ⊢ d' :: τ') × (τ ⊑t τ')) + -- graduality-type-assign ctxwf precc PIConst TAConst = b , TAConst , PTBase + -- graduality-type-assign ctxwf precc PIVar (TAVar inctx) with ⊑c-var inctx precc + -- ... | τ , inctx' , prec = τ , TAVar inctx' , prec + -- graduality-type-assign ctxwf precc PIEHole wt2 = ⦇-⦈ , TAEHole , PTHole + -- graduality-type-assign ctxwf precc (PILam prec x) (TALam x₁ wt) = _ , TALam {! !} {! !} , {! !} + -- graduality-type-assign ctxwf precc (PITLam prec) (TATLam wt) = {! !} + -- graduality-type-assign ctxwf precc (PINEHole prec) (TANEHole wt) = {! !} + -- graduality-type-assign ctxwf precc (PIAp prec prec₁) (TAAp wt wt₁) = {! !} + -- graduality-type-assign ctxwf precc (PITAp prec x) (TATAp x₁ wt x₂) = {! !} + -- graduality-type-assign ctxwf precc (PICast prec x x₁) (TACast wt x₂ x₃) = {! !} + -- graduality-type-assign ctxwf precc (PIFailedCast prec x ) (TAFailedCast wt x₂ x₃ x₄) = {! !} + -- graduality-type-assign ctxwf precc (PIRemoveCast prec x x₁ x₂) (TACast wt x₃ x₄) = {! !} + -- graduality-type-assign ctxwf precc (PIAddCast prec wt1 prec1 prec2) wt2 with graduality-type-assign ctxwf precc prec wt2 + -- ... | τ , wt3 , prec3 = _ , {! !} , {! !} \ No newline at end of file diff --git a/ground-dec.agda b/ground-dec.agda new file mode 100644 index 0000000..0b1cc59 --- /dev/null +++ b/ground-dec.agda @@ -0,0 +1,24 @@ +open import Prelude +open import core-type +open import core + +module ground-dec where + + ground-dec : (τ : htyp) → (τ ground) + ¬(τ ground) + ground-dec b = Inl GBase + ground-dec ⦇-⦈ = Inr (λ ()) + ground-dec (⦇-⦈ ==> ⦇-⦈) = Inl GArr + ground-dec (b ==> _) = Inr (λ ()) + ground-dec (_ ==> b) = Inr (λ ()) + ground-dec ((_ ==> _) ==> _) = Inr (λ ()) + ground-dec (_ ==> (_ ==> _)) = Inr (λ ()) + ground-dec ((·∀ _) ==> _) = Inr (λ ()) + ground-dec (_ ==> (·∀ _)) = Inr (λ ()) + ground-dec (·∀ ⦇-⦈) = Inl GForall + ground-dec (·∀ b) = Inr (λ ()) + ground-dec (·∀ (T _)) = Inr (λ ()) + ground-dec (·∀ (_ ==> _)) = Inr (λ ()) + ground-dec (·∀ (·∀ _)) = Inr (λ ()) + ground-dec (T _) = Inr (λ ()) + ground-dec ((T _) ==> _) = Inr (λ ()) + ground-dec (_ ==> (T _)) = Inr (λ ()) diff --git a/ground-decidable.agda b/ground-decidable.agda deleted file mode 100644 index 5c3d8a0..0000000 --- a/ground-decidable.agda +++ /dev/null @@ -1,24 +0,0 @@ -open import Prelude -open import core - -module ground-decidable where - ground-decidable : (τ : htyp) → (τ ground) + ((τ ground) → ⊥) - ground-decidable b = Inl GBase - ground-decidable ⦇-⦈ = Inr (λ ()) - ground-decidable (b ==> b) = Inr (λ ()) - ground-decidable (b ==> ⦇-⦈) = Inr (λ ()) - ground-decidable (b ==> τ' ==> τ'') = Inr (λ ()) - ground-decidable (⦇-⦈ ==> b) = Inr (λ ()) - ground-decidable (⦇-⦈ ==> ⦇-⦈) = Inl GHole - ground-decidable (⦇-⦈ ==> τ' ==> τ'') = Inr (λ ()) - ground-decidable ((τ ==> τ₁) ==> b) = Inr (λ ()) - ground-decidable ((τ ==> τ₁) ==> ⦇-⦈) = Inr (λ ()) - ground-decidable ((τ ==> τ₁) ==> τ' ==> τ'') = Inr (λ ()) - - ground-arr-lem : (τ : htyp) → ((τ ground) → ⊥) → (τ ≠ ⦇-⦈) → Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] ((τ == (τ1 ==> τ2)) × ((τ1 ==> τ2) ≠ (⦇-⦈ ==> ⦇-⦈))) - ground-arr-lem b ng nh = abort (ng GBase) - ground-arr-lem ⦇-⦈ ng nh = abort (nh refl) - ground-arr-lem (τ1 ==> τ2) ng nh = τ1 , τ2 , refl , (λ x → ng (lem' x)) - where - lem' : ∀{τ1 τ2} → τ1 ==> τ2 == ⦇-⦈ ==> ⦇-⦈ → (τ1 ==> τ2) ground - lem' refl = GHole diff --git a/grounding.agda b/grounding.agda deleted file mode 100644 index 67b0697..0000000 --- a/grounding.agda +++ /dev/null @@ -1,8 +0,0 @@ -open import Prelude -open import core - -module grounding where - grounding : ∀{ τ1 τ2} → - τ1 ▸gnd τ2 → - ((τ2 ground) × (τ1 ~ τ2) × (τ1 ≠ τ2)) - grounding (MGArr x) = GHole , TCArr TCHole1 TCHole1 , x diff --git a/holes-disjoint-checks.agda b/holes-disjoint-checks.agda deleted file mode 100644 index ca811d3..0000000 --- a/holes-disjoint-checks.agda +++ /dev/null @@ -1,180 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import disjointness - - --- this module contains lemmas and properties about the holes-disjoint --- judgement that double check that it acts as we would expect - -module holes-disjoint-checks where - -- these lemmas are all structurally recursive and quite - -- mechanical. morally, they establish the properties about reduction - -- that would be obvious / baked into Agda if holes-disjoint was defined - -- as a function rather than a judgement (datatype), or if we had defined - -- all the O(n^2) cases rather than relying on a little indirection to - -- only have O(n) cases. that work has to go somewhwere, and we prefer - -- that it goes here. - ds-lem-asc : ∀{e1 e2 τ} → holes-disjoint e2 e1 → holes-disjoint e2 (e1 ·: τ) - ds-lem-asc HDConst = HDConst - ds-lem-asc (HDAsc hd) = HDAsc (ds-lem-asc hd) - ds-lem-asc HDVar = HDVar - ds-lem-asc (HDLam1 hd) = HDLam1 (ds-lem-asc hd) - ds-lem-asc (HDLam2 hd) = HDLam2 (ds-lem-asc hd) - ds-lem-asc (HDHole x) = HDHole (HNAsc x) - ds-lem-asc (HDNEHole x hd) = HDNEHole (HNAsc x) (ds-lem-asc hd) - ds-lem-asc (HDAp hd hd₁) = HDAp (ds-lem-asc hd) (ds-lem-asc hd₁) - - ds-lem-lam1 : ∀{e1 e2 x} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x e1) - ds-lem-lam1 HDConst = HDConst - ds-lem-lam1 (HDAsc hd) = HDAsc (ds-lem-lam1 hd) - ds-lem-lam1 HDVar = HDVar - ds-lem-lam1 (HDLam1 hd) = HDLam1 (ds-lem-lam1 hd) - ds-lem-lam1 (HDLam2 hd) = HDLam2 (ds-lem-lam1 hd) - ds-lem-lam1 (HDHole x₁) = HDHole (HNLam1 x₁) - ds-lem-lam1 (HDNEHole x₁ hd) = HDNEHole (HNLam1 x₁) (ds-lem-lam1 hd) - ds-lem-lam1 (HDAp hd hd₁) = HDAp (ds-lem-lam1 hd) (ds-lem-lam1 hd₁) - - ds-lem-lam2 : ∀{e1 e2 x τ} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x [ τ ] e1) - ds-lem-lam2 HDConst = HDConst - ds-lem-lam2 (HDAsc hd) = HDAsc (ds-lem-lam2 hd) - ds-lem-lam2 HDVar = HDVar - ds-lem-lam2 (HDLam1 hd) = HDLam1 (ds-lem-lam2 hd) - ds-lem-lam2 (HDLam2 hd) = HDLam2 (ds-lem-lam2 hd) - ds-lem-lam2 (HDHole x₁) = HDHole (HNLam2 x₁) - ds-lem-lam2 (HDNEHole x₁ hd) = HDNEHole (HNLam2 x₁) (ds-lem-lam2 hd) - ds-lem-lam2 (HDAp hd hd₁) = HDAp (ds-lem-lam2 hd) (ds-lem-lam2 hd₁) - - ds-lem-nehole : ∀{e e1 u} → holes-disjoint e e1 → hole-name-new e u → holes-disjoint e ⦇⌜ e1 ⌟⦈[ u ] - ds-lem-nehole HDConst ν = HDConst - ds-lem-nehole (HDAsc hd) (HNAsc ν) = HDAsc (ds-lem-nehole hd ν) - ds-lem-nehole HDVar ν = HDVar - ds-lem-nehole (HDLam1 hd) (HNLam1 ν) = HDLam1 (ds-lem-nehole hd ν) - ds-lem-nehole (HDLam2 hd) (HNLam2 ν) = HDLam2 (ds-lem-nehole hd ν) - ds-lem-nehole (HDHole x) (HNHole x₁) = HDHole (HNNEHole (flip x₁) x) - ds-lem-nehole (HDNEHole x hd) (HNNEHole x₁ ν) = HDNEHole (HNNEHole (flip x₁) x) (ds-lem-nehole hd ν) - ds-lem-nehole (HDAp hd hd₁) (HNAp ν ν₁) = HDAp (ds-lem-nehole hd ν) (ds-lem-nehole hd₁ ν₁) - - ds-lem-ap : ∀{e1 e2 e3} → holes-disjoint e3 e1 → holes-disjoint e3 e2 → holes-disjoint e3 (e1 ∘ e2) - ds-lem-ap HDConst hd2 = HDConst - ds-lem-ap (HDAsc hd1) (HDAsc hd2) = HDAsc (ds-lem-ap hd1 hd2) - ds-lem-ap HDVar hd2 = HDVar - ds-lem-ap (HDLam1 hd1) (HDLam1 hd2) = HDLam1 (ds-lem-ap hd1 hd2) - ds-lem-ap (HDLam2 hd1) (HDLam2 hd2) = HDLam2 (ds-lem-ap hd1 hd2) - ds-lem-ap (HDHole x) (HDHole x₁) = HDHole (HNAp x x₁) - ds-lem-ap (HDNEHole x hd1) (HDNEHole x₁ hd2) = HDNEHole (HNAp x x₁) (ds-lem-ap hd1 hd2) - ds-lem-ap (HDAp hd1 hd2) (HDAp hd3 hd4) = HDAp (ds-lem-ap hd1 hd3) (ds-lem-ap hd2 hd4) - - -- holes-disjoint is symmetric - disjoint-sym : (e1 e2 : hexp) → holes-disjoint e1 e2 → holes-disjoint e2 e1 - disjoint-sym .c c HDConst = HDConst - disjoint-sym .c (e2 ·: x) HDConst = HDAsc (disjoint-sym _ _ HDConst) - disjoint-sym .c (X x) HDConst = HDVar - disjoint-sym .c (·λ x e2) HDConst = HDLam1 (disjoint-sym c e2 HDConst) - disjoint-sym .c (·λ x [ x₁ ] e2) HDConst = HDLam2 (disjoint-sym c e2 HDConst) - disjoint-sym .c ⦇-⦈[ x ] HDConst = HDHole HNConst - disjoint-sym .c ⦇⌜ e2 ⌟⦈[ x ] HDConst = HDNEHole HNConst (disjoint-sym c e2 HDConst) - disjoint-sym .c (e2 ∘ e3) HDConst = HDAp (disjoint-sym c e2 HDConst) (disjoint-sym c e3 HDConst) - - disjoint-sym _ c (HDAsc hd) = HDConst - disjoint-sym _ (e2 ·: x) (HDAsc hd) with disjoint-sym _ _ hd - disjoint-sym _ (e2 ·: x) (HDAsc hd) | HDAsc ih = HDAsc (ds-lem-asc ih) - disjoint-sym _ (X x) (HDAsc hd) = HDVar - disjoint-sym _ (·λ x e2) (HDAsc hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x e2) (HDAsc hd) | HDLam1 ih = HDLam1 (ds-lem-asc ih) - disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) | HDLam2 ih = HDLam2 (ds-lem-asc ih) - disjoint-sym _ ⦇-⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇-⦈[ x ] (HDAsc hd) | HDHole x₁ = HDHole (HNAsc x₁) - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDAsc hd) | HDNEHole x₁ ih = HDNEHole (HNAsc x₁) (ds-lem-asc ih) - disjoint-sym _ (e2 ∘ e3) (HDAsc hd) with disjoint-sym _ _ hd - disjoint-sym _ (e2 ∘ e3) (HDAsc hd) | HDAp ih ih₁ = HDAp (ds-lem-asc ih) (ds-lem-asc ih₁) - - disjoint-sym _ c HDVar = HDConst - disjoint-sym _ (e2 ·: x₁) HDVar = HDAsc (disjoint-sym _ e2 HDVar) - disjoint-sym _ (X x₁) HDVar = HDVar - disjoint-sym _ (·λ x₁ e2) HDVar = HDLam1 (disjoint-sym _ e2 HDVar) - disjoint-sym _ (·λ x₁ [ x₂ ] e2) HDVar = HDLam2 (disjoint-sym _ e2 HDVar) - disjoint-sym _ ⦇-⦈[ x₁ ] HDVar = HDHole HNVar - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] HDVar = HDNEHole HNVar (disjoint-sym _ e2 HDVar) - disjoint-sym _ (e2 ∘ e3) HDVar = HDAp (disjoint-sym _ e2 HDVar) (disjoint-sym _ e3 HDVar) - - disjoint-sym _ c (HDLam1 hd) = HDConst - disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) with disjoint-sym _ _ hd - disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) | HDAsc ih = HDAsc (ds-lem-lam1 ih) - disjoint-sym _ (X x₁) (HDLam1 hd) = HDVar - disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) | HDLam1 ih = HDLam1 (ds-lem-lam1 ih) - disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) | HDLam2 ih = HDLam2 (ds-lem-lam1 ih) - disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam1 hd) | HDHole x = HDHole (HNLam1 x) - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam1 hd) | HDNEHole x ih = HDNEHole (HNLam1 x) (ds-lem-lam1 ih) - disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) with disjoint-sym _ _ hd - disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam1 ih) (ds-lem-lam1 ih₁) - - disjoint-sym _ c (HDLam2 hd) = HDConst - disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) with disjoint-sym _ _ hd - disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) | HDAsc ih = HDAsc (ds-lem-lam2 ih) - disjoint-sym _ (X x₁) (HDLam2 hd) = HDVar - disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) | HDLam1 ih = HDLam1 (ds-lem-lam2 ih) - disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) | HDLam2 ih = HDLam2 (ds-lem-lam2 ih) - disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam2 hd) | HDHole x = HDHole (HNLam2 x) - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam2 hd) | HDNEHole x ih = HDNEHole (HNLam2 x) (ds-lem-lam2 ih) - disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) with disjoint-sym _ _ hd - disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam2 ih) (ds-lem-lam2 ih₁) - - disjoint-sym _ c (HDHole x) = HDConst - disjoint-sym _ (e2 ·: x) (HDHole (HNAsc x₁)) = HDAsc (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁)) - disjoint-sym _ (X x) (HDHole x₁) = HDVar - disjoint-sym _ (·λ x e2) (HDHole (HNLam1 x₁)) = HDLam1 (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁)) - disjoint-sym _ (·λ x [ x₁ ] e2) (HDHole (HNLam2 x₂)) = HDLam2 (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₂)) - disjoint-sym _ ⦇-⦈[ x ] (HDHole (HNHole x₁)) = HDHole (HNHole (flip x₁)) - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ u' ] (HDHole (HNNEHole x x₁)) = HDNEHole (HNHole (flip x)) (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁)) - disjoint-sym _ (e2 ∘ e3) (HDHole (HNAp x x₁)) = HDAp (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x)) - (disjoint-sym ⦇-⦈[ _ ] e3 (HDHole x₁)) - - disjoint-sym _ c (HDNEHole x hd) = HDConst - disjoint-sym _ (e2 ·: x) (HDNEHole x₁ hd) with disjoint-sym _ _ hd - disjoint-sym _ (e ·: x) (HDNEHole (HNAsc x₁) hd) | HDAsc ih = HDAsc (ds-lem-nehole ih x₁) - disjoint-sym _ (X x) (HDNEHole x₁ hd) = HDVar - disjoint-sym _ (·λ x e2) (HDNEHole x₁ hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x e2) (HDNEHole (HNLam1 x₁) hd) | HDLam1 ih = HDLam1 (ds-lem-nehole ih x₁) - disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole x₂ hd) with disjoint-sym _ _ hd - disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole (HNLam2 x₂) hd) | HDLam2 ih = HDLam2 (ds-lem-nehole ih x₂) - disjoint-sym _ ⦇-⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇-⦈[ x ] (HDNEHole (HNHole x₂) hd) | HDHole x₁ = HDHole (HNNEHole (flip x₂) x₁) - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd - disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDNEHole (HNNEHole x₂ x₃) hd) | HDNEHole x₁ ih = HDNEHole (HNNEHole (flip x₂) x₁) (ds-lem-nehole ih x₃) - disjoint-sym _ (e2 ∘ e3) (HDNEHole x hd) with disjoint-sym _ _ hd - disjoint-sym _ (e1 ∘ e3) (HDNEHole (HNAp x x₁) hd) | HDAp ih ih₁ = HDAp (ds-lem-nehole ih x) (ds-lem-nehole ih₁ x₁) - - disjoint-sym _ c (HDAp hd hd₁) = HDConst - disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ - disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) | HDAsc ih | HDAsc ih1 = HDAsc (ds-lem-ap ih ih1) - disjoint-sym _ (X x) (HDAp hd hd₁) = HDVar - disjoint-sym _ (·λ x e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ - disjoint-sym _ (·λ x e3) (HDAp hd hd₁) | HDLam1 ih | HDLam1 ih1 = HDLam1 (ds-lem-ap ih ih1) - disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ - disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) | HDLam2 ih | HDLam2 ih1 = HDLam2 (ds-lem-ap ih ih1) - disjoint-sym _ ⦇-⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ - disjoint-sym _ ⦇-⦈[ x ] (HDAp hd hd₁) | HDHole x₁ | HDHole x₂ = HDHole (HNAp x₁ x₂) - disjoint-sym _ ⦇⌜ e3 ⌟⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ - disjoint-sym _ ⦇⌜ e3 ⌟⦈[ x ] (HDAp hd hd₁) | HDNEHole x₁ ih | HDNEHole x₂ ih1 = HDNEHole (HNAp x₁ x₂) (ds-lem-ap ih ih1) - disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ - disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) | HDAp ih ih₁ | HDAp ih1 ih2 = HDAp (ds-lem-ap ih ih1) (ds-lem-ap ih₁ ih2) - - - -- note that this is false, so holes-disjoint isn't transitive - -- disjoint-new : ∀{e1 e2 u} → holes-disjoint e1 e2 → hole-name-new e1 u → hole-name-new e2 u - - -- it's also not reflexive, because ⦇-⦈[ u ] isn't hole-disjoint with - -- itself since refl : u == u; it's also not anti-reflexive, because the - -- expression c *is* hole-disjoint with itself (albeit vacuously) diff --git a/htype-decidable.agda b/htype-decidable.agda deleted file mode 100644 index 374ea88..0000000 --- a/htype-decidable.agda +++ /dev/null @@ -1,37 +0,0 @@ -open import Nat -open import Prelude -open import core -open import contexts - -module htype-decidable where - lemma-l : ∀{t1 t2 t4} → t1 ==> t2 == t1 ==> t4 → t2 == t4 - lemma-l refl = refl - - lemma-r : ∀{t1 t2 t3} → t1 ==> t2 == t3 ==> t2 → t1 == t3 - lemma-r refl = refl - - lemma-b : ∀{t1 t2 t3 t4} → t1 ==> t2 == t3 ==> t4 → t1 == t3 - lemma-b refl = refl - - htype-dec : (t1 t2 : htyp) → t1 == t2 + (t1 == t2 → ⊥) - htype-dec b b = Inl refl - htype-dec b ⦇-⦈ = Inr (λ ()) - htype-dec b (t2 ==> t3) = Inr (λ ()) - htype-dec ⦇-⦈ b = Inr (λ ()) - htype-dec ⦇-⦈ ⦇-⦈ = Inl refl - htype-dec ⦇-⦈ (t2 ==> t3) = Inr (λ ()) - htype-dec (t1 ==> t2) b = Inr (λ ()) - htype-dec (t1 ==> t2) ⦇-⦈ = Inr (λ ()) - htype-dec (t1 ==> t2) (t3 ==> t4) with htype-dec t1 t3 | htype-dec t2 t4 - htype-dec (t1 ==> t2) (.t1 ==> .t2) | Inl refl | Inl refl = Inl refl - htype-dec (t1 ==> t2) (.t1 ==> t4) | Inl refl | Inr x₁ = Inr (λ x → x₁ (lemma-l x)) - htype-dec (t1 ==> t2) (t3 ==> .t2) | Inr x | Inl refl = Inr (λ x₁ → x (lemma-r x₁)) - htype-dec (t1 ==> t2) (t3 ==> t4) | Inr x | Inr x₁ = Inr (λ x₂ → x (lemma-b x₂)) - - -- if an arrow is disequal, it disagrees in the first or second argument - ne-factor : ∀{τ1 τ2 τ3 τ4} → (τ1 ==> τ2) ≠ (τ3 ==> τ4) → (τ1 ≠ τ3) + (τ2 ≠ τ4) - ne-factor {τ1} {τ2} {τ3} {τ4} ne with htype-dec τ1 τ3 | htype-dec τ2 τ4 - ne-factor ne | Inl refl | Inl refl = Inl (λ x → ne refl) - ne-factor ne | Inl x | Inr x₁ = Inr x₁ - ne-factor ne | Inr x | Inl x₁ = Inl x - ne-factor ne | Inr x | Inr x₁ = Inl x diff --git a/lemmas-complete.agda b/lemmas-complete.agda index a655a13..d5da291 100644 --- a/lemmas-complete.agda +++ b/lemmas-complete.agda @@ -1,58 +1,100 @@ open import Nat open import Prelude +open import core-type +open import core-exp +open import core-subst open import core - -open import lemmas-gcomplete +open import lemmas-index module lemmas-complete where - -- no term is both complete and indeterminate - lem-ind-comp : ∀{d} → d dcomplete → d indet → ⊥ - lem-ind-comp DCVar () - lem-ind-comp DCConst () - lem-ind-comp (DCLam comp x₁) () - lem-ind-comp (DCAp comp comp₁) (IAp x ind x₁) = lem-ind-comp comp ind - lem-ind-comp (DCCast comp x x₁) (ICastArr x₂ ind) = lem-ind-comp comp ind - lem-ind-comp (DCCast comp x x₁) (ICastGroundHole x₂ ind) = lem-ind-comp comp ind - lem-ind-comp (DCCast comp x x₁) (ICastHoleGround x₂ ind x₃) = lem-ind-comp comp ind - - -- complete types that are consistent are equal + + ↑-complete : ∀{n m τ} → τ tcomplete → ↑ n m τ tcomplete + ↑-complete TCBase = TCBase + ↑-complete TCVar = TCVar + ↑-complete (TCArr tc tc₁) = TCArr (↑-complete tc) (↑-complete tc₁) + ↑-complete (TCForall tc) = TCForall (↑-complete tc) + + ↓-complete : ∀{n m τ} → τ tcomplete → ↓ n m τ tcomplete + ↓-complete TCBase = TCBase + ↓-complete TCVar = TCVar + ↓-complete (TCArr tc tc₁) = TCArr (↓-complete tc) (↓-complete tc₁) + ↓-complete (TCForall tc) = TCForall (↓-complete tc) + + ↑d-complete : ∀{t1 n t2 m d} → d dcomplete → ↑d t1 n t2 m d dcomplete + ↑d-complete DCVar = DCVar + ↑d-complete DCConst = DCConst + ↑d-complete (DCLam dc x) = DCLam (↑d-complete dc) (↑-complete x) + ↑d-complete (DCTLam dc) = DCTLam (↑d-complete dc) + ↑d-complete (DCAp dc dc₁) = DCAp (↑d-complete dc) (↑d-complete dc₁) + ↑d-complete (DCTAp x dc) = DCTAp (↑-complete x) (↑d-complete dc) + ↑d-complete (DCCast dc x x₁) = DCCast (↑d-complete dc) (↑-complete x) (↑-complete x₁) + + inctx-complete : ∀{x τ Γ} → Γ gcomplete → x , τ ∈ Γ → τ tcomplete + inctx-complete GCEmpty () + inctx-complete (GCVar gc x) InCtxZ = x + inctx-complete (GCVar gc x) (InCtx1+ inctx) = inctx-complete gc inctx + inctx-complete (GCTVar gc) (InCtxSkip inctx) = ↑-complete (inctx-complete gc inctx) + + meet-complete : ∀{τ1 τ2 τ3} → τ1 tcomplete → (τ1 ⊓ τ2 == τ3) → τ3 tcomplete + meet-complete tc MeetHoleR = tc + meet-complete tc MeetBase = tc + meet-complete tc MeetVar = tc + meet-complete (TCArr tc tc₁) (MeetArr meet1 meet2) = TCArr (meet-complete tc meet1) (meet-complete tc₁ meet2) + meet-complete (TCForall tc) (MeetForall meet) = TCForall (meet-complete tc meet) + + TTSub-complete : ∀{τ1 τ2 n} → τ1 tcomplete → τ2 tcomplete → TTSub n τ1 τ2 tcomplete + TTSub-complete tc1 TCBase = TCBase + TTSub-complete {n = n} tc1 (TCVar {n = x}) with natEQ n x + ... | Inl refl = ↓-complete (↑-complete tc1) + ... | Inr neq = TCVar + TTSub-complete tc1 (TCArr tc2 tc3) = TCArr (TTSub-complete tc1 tc2) (TTSub-complete tc1 tc3) + TTSub-complete {τ1 = τ1} {n = n} tc1 (TCForall tc2) with TTSub-complete {n = 1+ n} tc1 tc2 + ... | tc rewrite ↑compose 0 (1+ n) τ1 = TCForall tc + + TtSub-complete : ∀{n τ d} → τ tcomplete → d dcomplete → TtSub n τ d dcomplete + TtSub-complete tc DCVar = DCVar + TtSub-complete tc DCConst = DCConst + TtSub-complete tc (DCLam dc x) = DCLam (TtSub-complete tc dc) (TTSub-complete tc x) + TtSub-complete {n} {τ} tc (DCTLam dc) with TtSub-complete {1+ n} tc dc + ... | dc' rewrite sym (↑compose Z (1+ n) τ) = DCTLam dc' + TtSub-complete tc (DCAp dc dc₁) = DCAp (TtSub-complete tc dc) (TtSub-complete tc dc₁) + TtSub-complete tc (DCTAp x dc) = DCTAp (TTSub-complete tc x) (TtSub-complete tc dc) + TtSub-complete tc (DCCast dc x x₁) = DCCast (TtSub-complete tc dc) (TTSub-complete tc x) (TTSub-complete tc x₁) + + ttSub-complete : ∀{n m d1 d2} → d1 dcomplete → d2 dcomplete → ttSub n m d1 d2 dcomplete + ttSub-complete {n} dc1 (DCVar {x = x}) with natEQ x n + ... | Inl refl = ↑d-complete dc1 + ... | Inr neq = DCVar + ttSub-complete dc1 DCConst = DCConst + ttSub-complete {n} {m} {d1} dc1 (DCLam dc2 x) with ttSub-complete {1+ n} {m} dc1 dc2 + ... | dc3 = DCLam dc3 x + ttSub-complete {n} {m} {d1} dc1 (DCTLam dc2) with ttSub-complete {n} {1+ m} dc1 dc2 + ... | dc3 = DCTLam dc3 + ttSub-complete dc1 (DCAp dc2 dc3) = DCAp (ttSub-complete dc1 dc2) (ttSub-complete dc1 dc3) + ttSub-complete dc1 (DCTAp x dc2) = DCTAp x (ttSub-complete dc1 dc2) + ttSub-complete dc1 (DCCast dc2 x x₁) = DCCast (ttSub-complete dc1 dc2) x x₁ + + complete-indet : ∀{d} → d dcomplete → d indet → ⊥ + complete-indet DCVar () + complete-indet DCConst () + complete-indet (DCLam comp x₁) () + complete-indet (DCAp comp comp₁) (IAp x ind x₁) = complete-indet comp ind + complete-indet (DCCast comp x x₁) (ICastArr x₂ ind) = complete-indet comp ind + complete-indet (DCCast comp x x₁) (ICastGroundHole x₂ ind) = complete-indet comp ind + complete-indet (DCCast comp x x₁) (ICastHoleGround x₂ ind x₃) = complete-indet comp ind + complete-indet {d < x₁ >} (DCTAp x₂ x₃) (ITAp x x₄) = complete-indet x₃ x₄ + complete-indet {d ⟨ ·∀ x₁ ⇒ ·∀ τ2 ⟩} (DCCast x₂ x₃ x₄) + (ICastForall x₅ x₆) = complete-indet x₂ x₆ + complete-consistency : ∀{τ1 τ2} → τ1 ~ τ2 → τ1 tcomplete → τ2 tcomplete → τ1 == τ2 - complete-consistency TCRefl TCBase comp2 = refl - complete-consistency TCRefl (TCArr comp1 comp2) comp3 = refl - complete-consistency TCHole1 comp1 () - complete-consistency TCHole2 () comp2 - complete-consistency (TCArr consis consis₁) (TCArr comp1 comp2) (TCArr comp3 comp4) - with complete-consistency consis comp1 comp3 | complete-consistency consis₁ comp2 comp4 - ... | refl | refl = refl - - -- a well typed complete term is assigned a complete type - complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) → - (Δ , Γ ⊢ d :: τ) → - d dcomplete → - τ tcomplete - complete-ta gc TAConst comp = TCBase - complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁ - complete-ta gc (TALam a wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁ a ) wt comp) - complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) with complete-ta gc wt comp - complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) | TCArr qq qq₁ = qq₁ - complete-ta gc (TAEHole x x₁) () - complete-ta gc (TANEHole x wt x₁) () - complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂ - complete-ta gc (TAFailedCast wt x x₁ x₂) () - - -- a well typed term synthesizes a complete type - comp-synth : ∀{Γ e τ} → - Γ gcomplete → - e ecomplete → - Γ ⊢ e => τ → - τ tcomplete - comp-synth gc ec SConst = TCBase - comp-synth gc (ECAsc x ec) (SAsc x₁) = x - comp-synth gc ec (SVar x) = gc _ _ x - comp-synth gc (ECAp ec ec₁) (SAp _ wt MAHole x₁) with comp-synth gc ec wt - ... | () - comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) with comp-synth gc ec wt - comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) | TCArr qq qq₁ = qq₁ - comp-synth gc () SEHole - comp-synth gc () (SNEHole _ wt) - comp-synth gc (ECLam2 ec x₁) (SLam x₂ wt) = TCArr x₁ (comp-synth (gcomp-extend gc x₁ x₂) ec wt) + complete-consistency ConsistBase TCBase TCBase = refl + complete-consistency ConsistVar TCVar TCVar = refl + complete-consistency ConsistHole1 TCBase () + complete-consistency ConsistHole1 TCVar () + complete-consistency ConsistHole1 (TCArr tc1 tc2) () + complete-consistency ConsistHole1 (TCForall tc1) () + complete-consistency ConsistHole2 () tc2 + complete-consistency (ConsistArr con1 con2) (TCArr tc1 tc2) (TCArr tc3 tc4) + rewrite complete-consistency con1 tc1 tc3 rewrite complete-consistency con2 tc2 tc4 = refl + complete-consistency (ConsistForall con) (TCForall tc1) (TCForall tc2) + rewrite complete-consistency con tc1 tc2 = refl \ No newline at end of file diff --git a/lemmas-consistency.agda b/lemmas-consistency.agda index 84cc732..537b205 100644 --- a/lemmas-consistency.agda +++ b/lemmas-consistency.agda @@ -1,39 +1,53 @@ +open import Nat open import Prelude +open import core-type open import core +open import lemmas-index module lemmas-consistency where - -- type consistency is symmetric - ~sym : {t1 t2 : htyp} → t1 ~ t2 → t2 ~ t1 - ~sym TCRefl = TCRefl - ~sym TCHole1 = TCHole2 - ~sym TCHole2 = TCHole1 - ~sym (TCArr p1 p2) = TCArr (~sym p1) (~sym p2) - -- type consistency isn't transitive - not-trans : ((t1 t2 t3 : htyp) → t1 ~ t2 → t2 ~ t3 → t1 ~ t3) → ⊥ - not-trans t with t (b ==> b) ⦇-⦈ b TCHole1 TCHole2 - ... | () + ~refl : {τ : htyp} → τ ~ τ + ~refl {τ = b} = ConsistBase + ~refl {τ = T x} = ConsistVar + ~refl {τ = ⦇-⦈} = ConsistHole1 + ~refl {τ = τ ==> τ₁} = ConsistArr ~refl ~refl + ~refl {τ = ·∀ τ} = ConsistForall ~refl + + ~sym : {τ1 τ2 : htyp} → τ1 ~ τ2 → τ2 ~ τ1 + ~sym ConsistBase = ConsistBase + ~sym ConsistVar = ConsistVar + ~sym ConsistHole1 = ConsistHole2 + ~sym ConsistHole2 = ConsistHole1 + ~sym (ConsistArr con1 con2) = ConsistArr (~sym con1) (~sym con2) + ~sym (ConsistForall consist) = ConsistForall (~sym consist) - -- every pair of types is either consistent or not consistent - ~dec : (t1 t2 : htyp) → ((t1 ~ t2) + (t1 ~̸ t2)) - -- this takes care of all hole cases, so we don't consider them below - ~dec _ ⦇-⦈ = Inl TCHole1 - ~dec ⦇-⦈ _ = Inl TCHole2 - -- num cases - ~dec b b = Inl TCRefl - ~dec b (t2 ==> t3) = Inr ICBaseArr1 - -- arrow cases - ~dec (t1 ==> t2) b = Inr ICBaseArr2 - ~dec (t1 ==> t2) (t3 ==> t4) with ~dec t1 t3 | ~dec t2 t4 - ... | Inl x | Inl y = Inl (TCArr x y) - ... | Inl _ | Inr y = Inr (ICArr2 y) - ... | Inr x | _ = Inr (ICArr1 x) + ~dec : (τ1 τ2 : htyp) → (τ1 ~ τ2) + (τ1 ~̸ τ2) + ~dec _ ⦇-⦈ = Inl ConsistHole1 + ~dec ⦇-⦈ _ = Inl ConsistHole2 + ~dec b b = Inl ConsistBase + ~dec (T x) (T x₁) with natEQ x x₁ + ... | Inl refl = Inl ConsistVar + ... | Inr neq = Inr (λ{ConsistVar -> neq refl}) + ~dec (τ1 ==> τ2) (τ3 ==> τ4) with ~dec τ1 τ3 | ~dec τ2 τ4 + ... | Inl x | Inl y = Inl (ConsistArr x y) + ... | Inl _ | Inr y = Inr (\{(ConsistArr l r) -> y r}) + ... | Inr x | _ = Inr (\{(ConsistArr l r) -> x l}) + ~dec (·∀ τ1) (·∀ τ2) with ~dec τ1 τ2 + ... | Inl yes = Inl (ConsistForall yes) + ... | Inr no = Inr (λ {(ConsistForall x) → no x}) + ~dec b (T x) = Inr (λ ()) + ~dec b (τ2 ==> τ3) = Inr (λ ()) + ~dec b (·∀ τ2) = Inr (λ ()) + ~dec (T x) b = Inr (λ ()) + ~dec (T x) (τ2 ==> τ3) = Inr (λ ()) + ~dec (T x) (·∀ τ2) = Inr (λ ()) + ~dec (τ1 ==> τ2) b = Inr (λ ()) + ~dec (τ1 ==> τ2) (T x) = Inr (λ ()) + ~dec (τ1 ==> τ2) (·∀ τ3) = Inr (λ ()) + ~dec (·∀ τ1) b = Inr (λ ()) + ~dec (·∀ τ1) (T x) = Inr (λ ()) + ~dec (·∀ τ1) (τ2 ==> τ3) = Inr (λ ()) - -- no pair of types is both consistent and not consistent - ~apart : {t1 t2 : htyp} → (t1 ~̸ t2) → (t1 ~ t2) → ⊥ - ~apart ICBaseArr1 () - ~apart ICBaseArr2 () - ~apart (ICArr1 x) TCRefl = ~apart x TCRefl - ~apart (ICArr1 x) (TCArr y y₁) = ~apart x y - ~apart (ICArr2 x) TCRefl = ~apart x TCRefl - ~apart (ICArr2 x) (TCArr y y₁) = ~apart x y₁ + ~̸-≠ : ∀{τ1 τ2} → τ1 ~̸ τ2 → τ1 ≠ τ2 + ~̸-≠ inconsis eq rewrite ! eq = abort (inconsis ~refl) + \ No newline at end of file diff --git a/lemmas-ctx.agda b/lemmas-ctx.agda new file mode 100644 index 0000000..f4a954d --- /dev/null +++ b/lemmas-ctx.agda @@ -0,0 +1,16 @@ + +open import Nat +open import Prelude +open import core-type +open import core + +module lemmas-ctx where + + extend-tvar-comm : (n : Nat) → (Γ : ctx) → ctx-extend-tvars n (TVar, Γ) == (TVar, ctx-extend-tvars n Γ) + extend-tvar-comm Z Γ = refl + extend-tvar-comm (1+ n) Γ rewrite extend-tvar-comm n Γ = refl + + ctx+∅ : (Γ : ctx) → Γ ctx+ ∅ == Γ + ctx+∅ ∅ = refl + ctx+∅ (x , Γ) rewrite ctx+∅ Γ = refl + ctx+∅ (TVar, Γ) rewrite ctx+∅ Γ = refl \ No newline at end of file diff --git a/lemmas-disjointness.agda b/lemmas-disjointness.agda deleted file mode 100644 index 6ba2db3..0000000 --- a/lemmas-disjointness.agda +++ /dev/null @@ -1,132 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts - -module lemmas-disjointness where - -- disjointness is commutative - ##-comm : {A : Set} {Δ1 Δ2 : A ctx} → Δ1 ## Δ2 → Δ2 ## Δ1 - ##-comm (π1 , π2) = π2 , π1 - - -- the empty context is disjoint from any context - empty-disj : {A : Set} (Γ : A ctx) → ∅ ## Γ - empty-disj Γ = ed1 , ed2 - where - ed1 : {A : Set} (n : Nat) → dom {A} ∅ n → n # Γ - ed1 n (π1 , ()) - - ed2 : {A : Set} (n : Nat) → dom Γ n → _#_ {A} n ∅ - ed2 _ _ = refl - - -- two singleton contexts with different indices are disjoint - disjoint-singles : {A : Set} {x y : A} {u1 u2 : Nat} → - u1 ≠ u2 → - (■ (u1 , x)) ## (■ (u2 , y)) - disjoint-singles {_} {x} {y} {u1} {u2} neq = ds1 , ds2 - where - ds1 : (n : Nat) → dom (■ (u1 , x)) n → n # (■ (u2 , y)) - ds1 n d with lem-dom-eq d - ds1 .u1 d | refl with natEQ u2 u1 - ds1 .u1 d | refl | Inl xx = abort (neq (! xx)) - ds1 .u1 d | refl | Inr x₁ = refl - - ds2 : (n : Nat) → dom (■ (u2 , y)) n → n # (■ (u1 , x)) - ds2 n d with lem-dom-eq d - ds2 .u2 d | refl with natEQ u1 u2 - ds2 .u2 d | refl | Inl x₁ = abort (neq x₁) - ds2 .u2 d | refl | Inr x₁ = refl - - apart-noteq : {A : Set} (p r : Nat) (q : A) → p # (■ (r , q)) → p ≠ r - apart-noteq p r q apt with natEQ r p - apart-noteq p .p q apt | Inl refl = abort (somenotnone apt) - apart-noteq p r q apt | Inr x₁ = flip x₁ - - -- if singleton contexts are disjoint, their indices must be disequal - singles-notequal : {A : Set} {x y : A} {u1 u2 : Nat} → - (■ (u1 , x)) ## (■ (u2 , y)) → - u1 ≠ u2 - singles-notequal {A} {x} {y} {u1} {u2} (d1 , d2) = apart-noteq u1 u2 y (d1 u1 (lem-domsingle u1 x)) - - -- dual of lem2 above; if two indices are disequal, then either is apart - -- from the singleton formed with the other - apart-singleton : {A : Set} → ∀{x y} → {τ : A} → - x ≠ y → - x # (■ (y , τ)) - apart-singleton {A} {x} {y} {τ} neq with natEQ y x - apart-singleton neq | Inl x₁ = abort ((flip neq) x₁) - apart-singleton neq | Inr x₁ = refl - - -- if an index is apart from two contexts, it's apart from their union as - -- well. used below and in other files, so it's outside the local scope. - apart-parts : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # Γ1 → n # Γ2 → n # (Γ1 ∪ Γ2) - apart-parts Γ1 Γ2 n apt1 apt2 with Γ1 n - apart-parts _ _ n refl apt2 | .None = apt2 - - -- this is just for convenience; it shows up a lot. - apart-extend1 : {A : Set} → ∀{ x y τ} → (Γ : A ctx) → x ≠ y → x # Γ → x # (Γ ,, (y , τ)) - apart-extend1 {A} {x} {y} {τ} Γ neq apt = apart-parts Γ (■ (y , τ)) x apt (apart-singleton neq) - - -- if an index is in the domain of a union, it's in the domain of one or - -- the other unand - dom-split : {A : Set} → (Γ1 Γ2 : A ctx) (n : Nat) → dom (Γ1 ∪ Γ2) n → dom Γ1 n + dom Γ2 n - dom-split Γ4 Γ5 n (π1 , π2) with Γ4 n - dom-split Γ4 Γ5 n (π1 , π2) | Some x = Inl (x , refl) - dom-split Γ4 Γ5 n (π1 , π2) | None = Inr (π1 , π2) - - -- if both parts of a union are disjoint with a target, so is the union - disjoint-parts : {A : Set} {Γ1 Γ2 Γ3 : A ctx} → Γ1 ## Γ3 → Γ2 ## Γ3 → (Γ1 ∪ Γ2) ## Γ3 - disjoint-parts {_} {Γ1} {Γ2} {Γ3} D13 D23 = d31 , d32 - where - d31 : (n : Nat) → dom (Γ1 ∪ Γ2) n → n # Γ3 - d31 n D with dom-split Γ1 Γ2 n D - d31 n D | Inl x = π1 D13 n x - d31 n D | Inr x = π1 D23 n x - - d32 : (n : Nat) → dom Γ3 n → n # (Γ1 ∪ Γ2) - d32 n D = apart-parts Γ1 Γ2 n (π2 D13 n D) (π2 D23 n D) - - apart-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ1 - apart-union1 Γ1 Γ2 n aprt with Γ1 n - apart-union1 Γ1 Γ2 n () | Some x - apart-union1 Γ1 Γ2 n aprt | None = refl - - apart-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ2 - apart-union2 Γ1 Γ2 n aprt with Γ1 n - apart-union2 Γ3 Γ4 n () | Some x - apart-union2 Γ3 Γ4 n aprt | None = aprt - - -- if a union is disjoint with a target, so is the left unand - disjoint-union1 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ1 ## Δ - disjoint-union1 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du11 , du12 - where - dom-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ1 n → dom (Γ1 ∪ Γ2) n - dom-union1 Γ1 Γ2 n (π1 , π2) with Γ1 n - dom-union1 Γ1 Γ2 n (π1 , π2) | Some x = x , refl - dom-union1 Γ1 Γ2 n (π1 , ()) | None - - du11 : (n : Nat) → dom Γ1 n → n # Δ - du11 n dom = ud1 n (dom-union1 Γ1 Γ2 n dom) - - du12 : (n : Nat) → dom Δ n → n # Γ1 - du12 n dom = apart-union1 Γ1 Γ2 n (ud2 n dom) - - -- if a union is disjoint with a target, so is the right unand - disjoint-union2 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ2 ## Δ - disjoint-union2 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du21 , du22 - where - dom-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ2 n → dom (Γ1 ∪ Γ2) n - dom-union2 Γ1 Γ2 n (π1 , π2) with Γ1 n - dom-union2 Γ3 Γ4 n (π1 , π2) | Some x = x , refl - dom-union2 Γ3 Γ4 n (π1 , π2) | None = π1 , π2 - - du21 : (n : Nat) → dom Γ2 n → n # Δ - du21 n dom = ud1 n (dom-union2 Γ1 Γ2 n dom) - - du22 : (n : Nat) → dom Δ n → n # Γ2 - du22 n dom = apart-union2 Γ1 Γ2 n (ud2 n dom) - - -- if x isn't in a context and y is then they can't be equal - lem-dom-apt : {A : Set} {G : A ctx} {x y : Nat} → x # G → dom G y → x ≠ y - lem-dom-apt {x = x} {y = y} apt dom with natEQ x y - lem-dom-apt apt dom | Inl refl = abort (somenotnone (! (π2 dom) · apt)) - lem-dom-apt apt dom | Inr x₁ = x₁ diff --git a/lemmas-freshness.agda b/lemmas-freshness.agda deleted file mode 100644 index a237c7f..0000000 --- a/lemmas-freshness.agda +++ /dev/null @@ -1,58 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import lemmas-disjointness - -module lemmas-freshness where - -- if x is fresh in an hexp, it's fresh in its expansion - mutual - fresh-elab-synth1 : ∀{x e τ d Γ Δ} → - x # Γ → - freshh x e → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - fresh x d - fresh-elab-synth1 _ FRHConst ESConst = FConst - fresh-elab-synth1 apt (FRHAsc frsh) (ESAsc x₁) = FCast (fresh-elab-ana1 apt frsh x₁) - fresh-elab-synth1 _ (FRHVar x₂) (ESVar x₃) = FVar x₂ - fresh-elab-synth1 {Γ = Γ} apt (FRHLam2 x₂ frsh) (ESLam x₃ exp) = FLam x₂ (fresh-elab-synth1 (apart-extend1 Γ x₂ apt) frsh exp) - fresh-elab-synth1 apt FRHEHole ESEHole = FHole (EFId apt) - fresh-elab-synth1 apt (FRHNEHole frsh) (ESNEHole x₁ exp) = FNEHole (EFId apt) (fresh-elab-synth1 apt frsh exp) - fresh-elab-synth1 apt (FRHAp frsh frsh₁) (ESAp x₁ x₂ x₃ x₄ x₅ x₆) = - FAp (FCast (fresh-elab-ana1 apt frsh x₅)) - (FCast (fresh-elab-ana1 apt frsh₁ x₆)) - - fresh-elab-ana1 : ∀{ x e τ d τ' Γ Δ} → - x # Γ → - freshh x e → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - fresh x d - fresh-elab-ana1 {Γ = Γ} apt (FRHLam1 x₁ frsh) (EALam x₂ x₃ exp) = FLam x₁ (fresh-elab-ana1 (apart-extend1 Γ x₁ apt) frsh exp ) - fresh-elab-ana1 apt frsh (EASubsume x₁ x₂ x₃ x₄) = fresh-elab-synth1 apt frsh x₃ - fresh-elab-ana1 apt FRHEHole EAEHole = FHole (EFId apt) - fresh-elab-ana1 apt (FRHNEHole frsh) (EANEHole x₁ x₂) = FNEHole (EFId apt) (fresh-elab-synth1 apt frsh x₂) - - -- if x is fresh in the expansion of an hexp, it's fresh in that hexp - mutual - fresh-elab-synth2 : ∀{x e τ d Γ Δ} → - fresh x d → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - freshh x e - fresh-elab-synth2 FConst ESConst = FRHConst - fresh-elab-synth2 (FVar x₂) (ESVar x₃) = FRHVar x₂ - fresh-elab-synth2 (FLam x₂ frsh) (ESLam x₃ exp) = FRHLam2 x₂ (fresh-elab-synth2 frsh exp) - fresh-elab-synth2 (FHole x₁) ESEHole = FRHEHole - fresh-elab-synth2 (FNEHole x₁ frsh) (ESNEHole x₂ exp) = FRHNEHole (fresh-elab-synth2 frsh exp) - fresh-elab-synth2 (FAp (FCast frsh) (FCast frsh₁)) (ESAp x₁ x₂ x₃ x₄ x₅ x₆) = - FRHAp (fresh-elab-ana2 frsh x₅) - (fresh-elab-ana2 frsh₁ x₆) - fresh-elab-synth2 (FCast frsh) (ESAsc x₁) = FRHAsc (fresh-elab-ana2 frsh x₁) - - fresh-elab-ana2 : ∀{ x e τ d τ' Γ Δ} → - fresh x d → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - freshh x e - fresh-elab-ana2 (FLam x₁ frsh) (EALam x₂ x₃ exp) = FRHLam1 x₁ (fresh-elab-ana2 frsh exp) - fresh-elab-ana2 frsh (EASubsume x₁ x₂ x₃ x₄) = fresh-elab-synth2 frsh x₃ - fresh-elab-ana2 (FHole x₁) EAEHole = FRHEHole - fresh-elab-ana2 (FNEHole x₁ frsh) (EANEHole x₂ x₃) = FRHNEHole (fresh-elab-synth2 frsh x₃) diff --git a/lemmas-gcomplete.agda b/lemmas-gcomplete.agda deleted file mode 100644 index 8629285..0000000 --- a/lemmas-gcomplete.agda +++ /dev/null @@ -1,12 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts - -module lemmas-gcomplete where - -- if you add a complete type to a complete context, the result is also a - -- complete context - gcomp-extend : ∀{Γ τ x} → Γ gcomplete → τ tcomplete → x # Γ → (Γ ,, (x , τ)) gcomplete - gcomp-extend {Γ} {τ} {x} gc tc apart x_query τ_query x₁ with natEQ x x_query - gcomp-extend {Γ} {τ} {x} gc tc apart .x τ_query x₂ | Inl refl = tr (λ qq → qq tcomplete) (lem-apart-union-eq {Γ = Γ} apart x₂) tc - gcomp-extend {Γ} {τ} {x} gc tc apart x_query τ_query x₂ | Inr x₁ = gc x_query τ_query (lem-neq-union-eq {Γ = Γ} (flip x₁) x₂ ) diff --git a/lemmas-ground.agda b/lemmas-ground.agda index 7a43ab2..cc5680d 100644 --- a/lemmas-ground.agda +++ b/lemmas-ground.agda @@ -1,23 +1,90 @@ +open import Nat open import Prelude +open import core-type open import core +open import eq-dec module lemmas-ground where - -- not ground types aren't hole to hole + ground-arr-not-hole : ∀{τ} → - (τ ground → ⊥) → - (τ ≠ (⦇-⦈ ==> ⦇-⦈)) - ground-arr-not-hole notg refl = notg GHole - - -- not ground types either have to be hole or an arrow - notground : ∀{τ} → (τ ground → ⊥) → (τ == ⦇-⦈) + (Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] (τ == (τ1 ==> τ2))) - notground {b} gnd = abort (gnd GBase) - notground {⦇-⦈} gnd = Inl refl - notground {b ==> b} gnd = Inr (b , b , refl) - notground {b ==> ⦇-⦈} gnd = Inr (b , ⦇-⦈ , refl) - notground {b ==> τ2 ==> τ3} gnd = Inr (b , τ2 ==> τ3 , refl) - notground {⦇-⦈ ==> b} gnd = Inr (⦇-⦈ , b , refl) - notground {⦇-⦈ ==> ⦇-⦈} gnd = abort (gnd GHole) - notground {⦇-⦈ ==> τ2 ==> τ3} gnd = Inr (⦇-⦈ , τ2 ==> τ3 , refl) - notground {(τ1 ==> τ2) ==> b} gnd = Inr (τ1 ==> τ2 , b , refl) - notground {(τ1 ==> τ2) ==> ⦇-⦈} gnd = Inr (τ1 ==> τ2 , ⦇-⦈ , refl) - notground {(τ1 ==> τ2) ==> τ3 ==> τ4} gnd = Inr (τ1 ==> τ2 , τ3 ==> τ4 , refl) + (τ ground → ⊥) → + (τ ≠ (⦇-⦈ ==> ⦇-⦈)) + ground-arr-not-hole notg refl = notg GArr + + ground-forall-not-hole : ∀{τ} → + (τ ground → ⊥) → + (τ ≠ (·∀ ⦇-⦈)) + ground-forall-not-hole notg refl = notg GForall + + ground-neq~ : ∀{τ1 τ2} → τ1 ground → τ2 ground → τ1 ≠ τ2 → τ1 ~̸ τ2 + ground-neq~ GBase GBase neq = λ _ → neq refl + ground-neq~ GBase GArr neq = λ () + ground-neq~ GBase GForall neq = λ () + ground-neq~ GArr GBase neq = λ () + ground-neq~ GArr GArr neq = λ _ → neq refl + ground-neq~ GArr GForall neq = λ () + ground-neq~ GForall GBase neq = λ () + ground-neq~ GForall GArr neq = λ () + ground-neq~ GForall GForall neq = λ _ → neq refl + + ground-not-hole : ∀{τ} → + τ ground → τ ≠ ⦇-⦈ + ground-not-hole GBase = λ () + ground-not-hole GArr = λ () + ground-not-hole GForall = λ () + + gnd-gnd-consis-eq : ∀{τ1 τ2} → + τ1 ground → τ2 ground → τ1 ~ τ2 → + τ1 == τ2 + gnd-gnd-consis-eq GBase GBase consis = refl + gnd-gnd-consis-eq GArr GArr consis = refl + gnd-gnd-consis-eq GForall GForall consis = refl + + ground-match : ∀{τ τ'} → + τ ▸gnd τ' → + τ' ground + ground-match (MGArr x) = GArr + ground-match (MGForall x) = GForall + + ground-match-exists : ∀{τ} → + ¬(τ ground) → ∅ ⊢ τ wf → τ ≠ ⦇-⦈ → + Σ[ τ' ∈ htyp ](τ ▸gnd τ') + ground-match-exists {b} g _ _ = abort (g GBase) + ground-match-exists {T x} g () _ + ground-match-exists {⦇-⦈} g wf ne = abort (ne refl) + ground-match-exists {τ ==> τ₁} g wf ne with htyp-eq-dec (τ ==> τ₁) (⦇-⦈ ==> ⦇-⦈) + ... | Inl refl = abort (g GArr) + ... | Inr neq = ⦇-⦈ ==> ⦇-⦈ , MGArr neq + ground-match-exists {·∀ τ} g wf ne with htyp-eq-dec (·∀ τ) (·∀ ⦇-⦈) + ... | Inl refl = abort (g GForall) + ... | Inr neq = ·∀ ⦇-⦈ , MGForall neq + + consist-ground-consist : ∀{τ1 τ2 τ2'} → + τ1 ~ τ2 → τ2 ▸gnd τ2' → τ1 ~ τ2' + consist-ground-consist ConsistBase () + consist-ground-consist ConsistVar () + consist-ground-consist ConsistHole1 () + consist-ground-consist ConsistHole2 _ = ConsistHole2 + consist-ground-consist (ConsistArr consis consis₁) (MGArr x) = ConsistArr ConsistHole1 ConsistHole1 + consist-ground-consist (ConsistForall consis) (MGForall x) = ConsistForall ConsistHole1 + + ground-match-neq : ∀{τ1 τ2} → + τ1 ▸gnd τ2 → τ1 ≠ τ2 + ground-match-neq (MGArr x) = x + ground-match-neq (MGForall x) = x + + gnd-ngnd-neq : ∀{τ1 τ2} → + τ1 ground → ¬(τ2 ground) → τ1 ≠ τ2 + gnd-ngnd-neq {τ2 = b} GBase ngd = λ _ → ngd GBase + gnd-ngnd-neq {τ2 = b} GArr ngd = λ () + gnd-ngnd-neq {τ2 = b} GForall ngd = λ () + gnd-ngnd-neq {τ2 = T x} GBase ngd = λ () + gnd-ngnd-neq {τ2 = T x} GArr ngd = λ () + gnd-ngnd-neq {τ2 = T x} GForall ngd = λ () + gnd-ngnd-neq {τ2 = ⦇-⦈} GBase ngd = λ () + gnd-ngnd-neq {τ2 = ⦇-⦈} GArr ngd = λ () + gnd-ngnd-neq {τ2 = ⦇-⦈} GForall ngd = λ () + gnd-ngnd-neq {τ2 = τ2 ==> τ3} GBase ngd = λ () + gnd-ngnd-neq {τ2 = τ2 ==> τ3} GArr ngd x rewrite ! x = ngd GArr + gnd-ngnd-neq {τ2 = τ2 ==> τ3} GForall ngd = λ () + gnd-ngnd-neq {τ2 = ·∀ τ2} gnd ngd x rewrite ! x = ngd gnd diff --git a/lemmas-index.agda b/lemmas-index.agda new file mode 100644 index 0000000..136e6de --- /dev/null +++ b/lemmas-index.agda @@ -0,0 +1,93 @@ +open import Nat +open import Prelude +open import core-type +open import core-exp +open import core-subst +open import core + +module lemmas-index where + + ↑10 : (x : Nat) → (↑Nat Z 1 x) == 1+ x + ↑10 Z = refl + ↑10 (1+ x) rewrite (↑10 x) = refl + + ↑NatZ : (t x : Nat) → ↑Nat t Z x == x + ↑NatZ Z x = refl + ↑NatZ (1+ t) Z = refl + ↑NatZ (1+ t) (1+ x) rewrite ↑NatZ t x = refl + + ↑Z : (t : Nat) → (τ : htyp) → ↑ t Z τ == τ + ↑Z t b = refl + ↑Z t (T x) rewrite ↑NatZ t x = refl + ↑Z t ⦇-⦈ = refl + ↑Z t (τ ==> τ₁) rewrite ↑Z t τ rewrite ↑Z t τ₁ = refl + ↑Z t (·∀ τ) rewrite ↑Z (1+ t) τ = refl + + ↑dZ : (t1 t2 : Nat) → (d : ihexp) → ↑d t1 Z t2 Z d == d + ↑dZ t1 t2 c = refl + ↑dZ t1 t2 ⦇-⦈ = refl + ↑dZ t1 t2 ⦇⌜ d ⌟⦈ rewrite ↑dZ t1 t2 d = refl + ↑dZ t1 t2 (d ∘ d₁) rewrite ↑dZ t1 t2 d rewrite ↑dZ t1 t2 d₁ = refl + ↑dZ t1 t2 (d < x >) rewrite ↑Z t2 x rewrite ↑dZ t1 t2 d = refl + ↑dZ t1 t2 (d ⟨ x ⇒ x₁ ⟩) rewrite ↑Z t2 x rewrite ↑Z t2 x₁ rewrite ↑dZ t1 t2 d = refl + ↑dZ t1 t2 (d ⟨ x ⇒⦇-⦈⇏ x₁ ⟩) rewrite ↑Z t2 x rewrite ↑Z t2 x₁ rewrite ↑dZ t1 t2 d = refl + ↑dZ t1 t2 (·λ[ x ] d) rewrite ↑Z t2 x rewrite ↑dZ (1+ t1) t2 d = refl + ↑dZ t1 t2 (·Λ d) rewrite ↑dZ t1 (1+ t2) d = refl + ↑dZ t1 t2 (X x) rewrite ↑NatZ t1 x = refl + + ↑Nat-compose : (t i x : Nat) → ↑Nat t 1 (↑Nat t i x) == ↑Nat t (1+ i) x + ↑Nat-compose Z Z x = refl + ↑Nat-compose Z (1+ i) x = refl + ↑Nat-compose (1+ t) i Z = refl + ↑Nat-compose (1+ t) i (1+ x) rewrite ↑Nat-compose t i x = refl + + ↑compose : (t i : Nat) → (τ : htyp) → ↑ t 1 (↑ t i τ) == (↑ t (1+ i) τ) + ↑compose _ _ b = refl + ↑compose t i (T x) rewrite ↑Nat-compose t i x = refl + ↑compose _ _ ⦇-⦈ = refl + ↑compose t i (τ ==> τ₁) rewrite ↑compose t i τ rewrite ↑compose t i τ₁ = refl + ↑compose t i (·∀ τ) rewrite ↑compose (1+ t) i τ = refl + + ↑ctx-compose : (t i : Nat) → (Γ : ctx) → ↑ctx t 1 (↑ctx t i Γ) == (↑ctx t (1+ i) Γ) + ↑ctx-compose t i ∅ = refl + ↑ctx-compose t i (x , Γ) rewrite ↑compose t i x rewrite ↑ctx-compose t i Γ = refl + ↑ctx-compose t i (TVar, Γ) rewrite ↑ctx-compose (1+ t) i Γ = refl + + ↑Nat-incr : (i x : Nat) → ↑Nat Z i (1+ x) == 1+ (↑Nat Z i x) + ↑Nat-incr Z x = refl + ↑Nat-incr (1+ i) x rewrite ↑Nat-incr i x = refl + + ↑Nat-comm : (t i j x : Nat) → ↑Nat t i (↑Nat t j x) == ↑Nat t j (↑Nat t i x) + ↑Nat-comm Z Z j x = refl + ↑Nat-comm Z (1+ i) Z x = refl + ↑Nat-comm Z (1+ i) (1+ j) x + rewrite ↑Nat-incr i (↑Nat Z j x) + rewrite ↑Nat-incr j (↑Nat Z i x) + rewrite ↑Nat-comm Z i j x = refl + ↑Nat-comm (1+ t) i j Z = refl + ↑Nat-comm (1+ t) i j (1+ x) rewrite ↑Nat-comm t i j x = refl + + ↑comm : (t i j : Nat) → (τ : htyp) → ↑ t i (↑ t j τ) == ↑ t j (↑ t i τ) + ↑comm t i j b = refl + ↑comm t i j (T x) rewrite ↑Nat-comm t i j x = refl + ↑comm t i j ⦇-⦈ = refl + ↑comm t i j (τ1 ==> τ2) rewrite ↑comm t i j τ1 rewrite ↑comm t i j τ2 = refl + ↑comm t i j (·∀ τ) rewrite ↑comm (1+ t) i j τ = refl + + ↓↑Nat-invert : (n m x : Nat) → ↓Nat (n nat+ m) 1 (↑Nat m (n nat+ 1) x) == ↑Nat m n x + ↓↑Nat-invert Z Z x = refl + ↓↑Nat-invert Z (1+ m) Z = refl + ↓↑Nat-invert Z (1+ m) (1+ x) rewrite ↓↑Nat-invert Z m x = refl + ↓↑Nat-invert (1+ n) Z x rewrite nat+Z n with ↓↑Nat-invert n Z x + ... | result rewrite nat+Z n rewrite result = refl + ↓↑Nat-invert (1+ n) (1+ m) Z = refl + ↓↑Nat-invert (1+ n) (1+ m) (1+ x) with ↓↑Nat-invert (1+ n) m x + ... | result rewrite nat+1+ n m rewrite result = refl + + ↓↑-invert : ∀{n m τ} → ↓ (n nat+ m) 1 (↑ m (n nat+ 1) τ) == ↑ m n τ + ↓↑-invert {n} {m} {b} = refl + ↓↑-invert {n} {m} {T x} rewrite ↓↑Nat-invert n m x = refl + ↓↑-invert {n} {m} {⦇-⦈} = refl + ↓↑-invert {n} {m} {τ ==> τ₁} rewrite ↓↑-invert {n} {m} {τ} rewrite ↓↑-invert {n} {m} {τ₁} = refl + ↓↑-invert {n} {m} {·∀ τ} with ↓↑-invert {n} {1+ m} {τ} + ... | result rewrite nat+1+ n m rewrite result = refl diff --git a/lemmas-matching.agda b/lemmas-matching.agda deleted file mode 100644 index b07c4dc..0000000 --- a/lemmas-matching.agda +++ /dev/null @@ -1,27 +0,0 @@ -open import Prelude -open import core - -module lemmas-matching where - -- matching produces unique answers for arrows, sums, and products - ▸arr-unicity : ∀{ t t2 t3 } → - t ▸arr t2 → - t ▸arr t3 → - t2 == t3 - ▸arr-unicity MAHole MAHole = refl - ▸arr-unicity MAArr MAArr = refl - - -- if an arrow matches, then it's consistent with the least restrictive - -- function type - matchconsisthole : ∀{t t'} → - t ▸arr t' → - t ~ (⦇-⦈ ==> ⦇-⦈) - matchconsisthole MAHole = TCHole2 - matchconsisthole MAArr = TCArr TCHole1 TCHole1 - - match-consist : ∀{τ1 τ2} → τ1 ▸arr τ2 → (τ2 ~ τ1) - match-consist MAHole = TCHole1 - match-consist MAArr = TCRefl - - match-unicity : ∀{ τ τ1 τ2} → τ ▸arr τ1 → τ ▸arr τ2 → τ1 == τ2 - match-unicity MAHole MAHole = refl - match-unicity MAArr MAArr = refl diff --git a/lemmas-meet.agda b/lemmas-meet.agda new file mode 100644 index 0000000..c35d835 --- /dev/null +++ b/lemmas-meet.agda @@ -0,0 +1,105 @@ +open import Nat +open import Prelude +open import core-type +open import lemmas-prec + +module lemmas-meet where + + ⊓-ability : ∀{τ1 τ2} → τ1 ~ τ2 → Σ[ τ3 ∈ htyp ] (τ1 ⊓ τ2 == τ3) + ⊓-ability ConsistBase = b , MeetBase + ⊓-ability ConsistVar = T _ , MeetVar + ⊓-ability ConsistHole1 = _ , MeetHoleR + ⊓-ability ConsistHole2 = _ , MeetHoleL + ⊓-ability (ConsistArr con con₁) with ⊓-ability con | ⊓-ability con₁ + ... | τ1 , meet1 | τ2 , meet2 = τ1 ==> τ2 , MeetArr meet1 meet2 + ⊓-ability (ConsistForall con) with ⊓-ability con + ... | τ , meet = ·∀ τ , MeetForall meet + + ⊓-consist : ∀{τ1 τ2 τ3} → τ1 ⊓ τ2 == τ3 → τ1 ~ τ2 + ⊓-consist MeetHoleL = ConsistHole2 + ⊓-consist MeetHoleR = ConsistHole1 + ⊓-consist MeetBase = ConsistBase + ⊓-consist MeetVar = ConsistVar + ⊓-consist (MeetArr meet meet₁) = ConsistArr (⊓-consist meet) (⊓-consist meet₁) + ⊓-consist (MeetForall meet) = ConsistForall (⊓-consist meet) + + ⊓-unicity : ∀{τ1 τ2 τ3 τ3'} → τ1 ⊓ τ2 == τ3 → τ1 ⊓ τ2 == τ3' → τ3 == τ3' + ⊓-unicity MeetHoleL MeetHoleL = refl + ⊓-unicity MeetHoleL MeetHoleR = refl + ⊓-unicity MeetHoleR MeetHoleL = refl + ⊓-unicity MeetHoleR MeetHoleR = refl + ⊓-unicity MeetBase MeetBase = refl + ⊓-unicity MeetVar MeetVar = refl + ⊓-unicity (MeetArr meet1 meet2) (MeetArr meet3 meet4) rewrite ⊓-unicity meet1 meet3 rewrite ⊓-unicity meet2 meet4 = refl + ⊓-unicity (MeetForall meet1) (MeetForall meet2) rewrite ⊓-unicity meet1 meet2 = refl + + ⊓-lb : ∀{τ1 τ2 τ3} → τ1 ⊓ τ2 == τ3 → (τ3 ⊑t τ1 × τ3 ⊑t τ2) + ⊓-lb MeetHoleL = PTHole , ⊑t-refl _ + ⊓-lb MeetHoleR = ⊑t-refl _ , PTHole + ⊓-lb MeetBase = PTBase , PTBase + ⊓-lb MeetVar = PTTVar , PTTVar + ⊓-lb (MeetArr meet meet₁) = (PTArr (π1 (⊓-lb meet)) (π1 (⊓-lb meet₁))) , (PTArr (π2 (⊓-lb meet)) (π2 (⊓-lb meet₁))) + ⊓-lb (MeetForall meet) = (PTForall (π1 (⊓-lb meet))) , (PTForall (π2 (⊓-lb meet))) + + ⊑t-⊓ : ∀{τ1 τ2 τ3 τ1' τ2'} → τ1 ⊑t τ1' → τ2 ⊑t τ2' → τ1 ⊓ τ2 == τ3 → Σ[ τ3' ∈ htyp ] ((τ1' ⊓ τ2' == τ3') × (τ3 ⊑t τ3')) + ⊑t-⊓ PTHole prec2 MeetHoleL = _ , MeetHoleL , prec2 + ⊑t-⊓ prec1 PTHole MeetHoleR = _ , MeetHoleR , prec1 + ⊑t-⊓ PTHole PTHole _ = ⦇-⦈ , MeetHoleL , PTHole + ⊑t-⊓ PTBase PTBase MeetBase = _ , MeetBase , PTBase + ⊑t-⊓ PTBase PTHole MeetBase = _ , MeetHoleR , PTBase + ⊑t-⊓ PTHole PTBase MeetBase = _ , MeetHoleL , PTBase + ⊑t-⊓ PTHole PTTVar MeetVar = _ , MeetHoleL , PTTVar + ⊑t-⊓ PTTVar PTHole MeetVar = _ , MeetHoleR , PTTVar + ⊑t-⊓ PTTVar PTTVar MeetVar = _ , MeetVar , PTTVar + ⊑t-⊓ PTHole (PTArr prec2 prec3) (MeetArr meet1 meet2) = _ , MeetHoleL , PTArr (⊑t-trans (π2 (⊓-lb meet1)) prec2) ((⊑t-trans (π2 (⊓-lb meet2)) prec3)) + ⊑t-⊓ (PTArr prec1 prec2) PTHole (MeetArr meet1 meet2) = _ , MeetHoleR , PTArr (⊑t-trans (π1 (⊓-lb meet1)) prec1) (⊑t-trans (π1 (⊓-lb meet2)) prec2) + ⊑t-⊓ (PTArr prec1 prec2) (PTArr prec3 prec4) (MeetArr meet1 meet2) with ⊑t-⊓ prec1 prec3 meet1 | ⊑t-⊓ prec2 prec4 meet2 + ... | _ , meet1' , prec1' | _ , meet2' , prec2' = _ , MeetArr meet1' meet2' , PTArr prec1' prec2' + ⊑t-⊓ PTHole (PTForall prec2) (MeetForall meet) = _ , MeetHoleL , PTForall (⊑t-trans (π2 (⊓-lb meet)) prec2) + ⊑t-⊓ (PTForall prec1) PTHole (MeetForall meet) = _ , MeetHoleR , PTForall (⊑t-trans (π1 (⊓-lb meet)) prec1) + ⊑t-⊓ (PTForall prec1) (PTForall prec2) (MeetForall meet) with ⊑t-⊓ prec1 prec2 meet + ... | _ , meet' , prec' = _ , MeetForall meet' , PTForall prec' + + ⊑t-⊓-fun : ∀{τ1 τ2 τ3 τ1' τ2' τ3'} → τ1 ⊑t τ1' → τ2 ⊑t τ2' → τ1 ⊓ τ2 == τ3 → τ1' ⊓ τ2' == τ3' → τ3 ⊑t τ3' + ⊑t-⊓-fun PTHole prec2 MeetHoleL MeetHoleL = prec2 + ⊑t-⊓-fun PTHole prec2 MeetHoleL MeetHoleR = prec2 + ⊑t-⊓-fun prec1 PTHole MeetHoleR MeetHoleL = prec1 + ⊑t-⊓-fun prec1 PTHole MeetHoleR MeetHoleR = prec1 + ⊑t-⊓-fun prec1 prec2 MeetBase MeetHoleL = prec2 + ⊑t-⊓-fun prec1 prec2 MeetBase MeetHoleR = prec1 + ⊑t-⊓-fun prec1 prec2 MeetBase MeetBase = prec2 + ⊑t-⊓-fun prec1 prec2 MeetVar MeetHoleL = prec2 + ⊑t-⊓-fun prec1 prec2 MeetVar MeetHoleR = prec1 + ⊑t-⊓-fun prec1 prec2 MeetVar MeetVar = prec2 + ⊑t-⊓-fun PTHole prec2 (MeetArr meet1 meet2) MeetHoleL = ⊑t-trans (PTArr (π2 (⊓-lb meet1)) (π2 (⊓-lb meet2))) prec2 + ⊑t-⊓-fun prec1 prec2 (MeetArr meet1 meet2) MeetHoleR = ⊑t-trans (PTArr (π1 (⊓-lb meet1)) (π1 (⊓-lb meet2))) prec1 + ⊑t-⊓-fun (PTArr prec1 prec2) (PTArr prec3 prec4) (MeetArr meet1 meet2) (MeetArr meet3 meet4) = + PTArr (⊑t-⊓-fun prec1 prec3 meet1 meet3) (⊑t-⊓-fun prec2 prec4 meet2 meet4) + ⊑t-⊓-fun PTHole prec2 (MeetForall meet) MeetHoleL = ⊑t-trans (PTForall (π2 (⊓-lb meet))) prec2 + ⊑t-⊓-fun prec1 prec2 (MeetForall meet) MeetHoleR = ⊑t-trans (PTForall (π1 (⊓-lb meet))) prec1 + ⊑t-⊓-fun (PTForall prec1) (PTForall prec2) (MeetForall meet) (MeetForall meet2) = PTForall (⊑t-⊓-fun prec1 prec2 meet meet2) + + + module meet-match where + + --- direct matching for arrows + data _▸arr_ : htyp → htyp → Set where + MAHole : ⦇-⦈ ▸arr ⦇-⦈ ==> ⦇-⦈ + MAArr : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2 + + --- direct matching for foralls + data _▸forall_ : htyp → htyp → Set where + MFHole : ⦇-⦈ ▸forall (·∀ ⦇-⦈) + MFForall : ∀{τ} → (·∀ τ) ▸forall (·∀ τ) + + ⊓-▸arr : ∀{τ1 τ2 τ3} → τ1 ⊓ (⦇-⦈ ==> ⦇-⦈) == τ2 → τ1 ▸arr τ3 → τ2 == τ3 + ⊓-▸arr MeetHoleL MAHole = refl + ⊓-▸arr (MeetArr MeetHoleL MeetHoleL) MAArr = refl + ⊓-▸arr (MeetArr MeetHoleL MeetHoleR) MAArr = refl + ⊓-▸arr (MeetArr MeetHoleR MeetHoleL) MAArr = refl + ⊓-▸arr (MeetArr MeetHoleR MeetHoleR) MAArr = refl + + ⊓-▸forall : ∀{τ1 τ2 τ3} → τ1 ⊓ ·∀ ⦇-⦈ == τ2 → τ1 ▸forall τ3 → τ2 == τ3 + ⊓-▸forall MeetHoleL MFHole = refl + ⊓-▸forall (MeetForall MeetHoleL) MFForall = refl + ⊓-▸forall (MeetForall MeetHoleR) MFForall = refl \ No newline at end of file diff --git a/lemmas-prec.agda b/lemmas-prec.agda new file mode 100644 index 0000000..20ddfc2 --- /dev/null +++ b/lemmas-prec.agda @@ -0,0 +1,74 @@ +open import Nat +open import Prelude +open import core-type +open import core-subst +open import core +open import lemmas-consistency + +module lemmas-prec where + + ⊑t-refl : (τ : htyp) → τ ⊑t τ + ⊑t-refl b = PTBase + ⊑t-refl (T x) = PTTVar + ⊑t-refl ⦇-⦈ = PTHole + ⊑t-refl (τ ==> τ₁) = PTArr (⊑t-refl τ) (⊑t-refl τ₁) + ⊑t-refl (·∀ τ) = PTForall (⊑t-refl τ) + + ⊑t-trans : ∀{τ1 τ2 τ3} → τ1 ⊑t τ2 → τ2 ⊑t τ3 → τ1 ⊑t τ3 + ⊑t-trans prec1 PTBase = prec1 + ⊑t-trans prec1 PTHole = PTHole + ⊑t-trans prec1 PTTVar = prec1 + ⊑t-trans (PTArr prec1 prec2) (PTArr prec3 prec4) = PTArr (⊑t-trans prec1 prec3) (⊑t-trans prec2 prec4) + ⊑t-trans (PTForall prec1) (PTForall prec2) = PTForall (⊑t-trans prec1 prec2) + + ⊑t-consist : ∀{τ τ'} → τ ⊑t τ' → τ ~ τ' + ⊑t-consist PTBase = ConsistBase + ⊑t-consist PTHole = ConsistHole1 + ⊑t-consist PTTVar = ConsistVar + ⊑t-consist (PTArr prec prec₁) = ConsistArr (⊑t-consist prec) (⊑t-consist prec₁) + ⊑t-consist (PTForall prec) = ConsistForall (⊑t-consist prec) + + ⊑t-consist-left : ∀{τ τ' τ''} → τ ~ τ' → τ ⊑t τ'' → τ'' ~ τ' + ⊑t-consist-left ConsistHole1 prec = ConsistHole1 + ⊑t-consist-left consist PTBase = consist + ⊑t-consist-left consist PTHole = ConsistHole2 + ⊑t-consist-left consist PTTVar = consist + ⊑t-consist-left (ConsistArr con1 con2) (PTArr prec1 prec2) = ConsistArr (⊑t-consist-left con1 prec1) (⊑t-consist-left con2 prec2) + ⊑t-consist-left (ConsistForall consist) (PTForall prec) = ConsistForall (⊑t-consist-left consist prec) + + ⊑t-consist-right : ∀{τ τ' τ''} → τ ~ τ' → τ' ⊑t τ'' → τ ~ τ'' + ⊑t-consist-right consist prec = ~sym (⊑t-consist-left (~sym consist) prec) + + ⊑t-↑ : ∀{n m τ1 τ2} → + (τ1 ⊑t τ2) → + (↑ n m τ1) ⊑t (↑ n m τ2) + ⊑t-↑ PTBase = PTBase + ⊑t-↑ PTHole = PTHole + ⊑t-↑ PTTVar = PTTVar + ⊑t-↑ (PTArr prec prec₁) = PTArr (⊑t-↑ prec) (⊑t-↑ prec₁) + ⊑t-↑ (PTForall prec) = PTForall (⊑t-↑ prec) + + ⊑t-↓ : ∀{n m τ1 τ2} → + (τ1 ⊑t τ2) → + (↓ n m τ1) ⊑t (↓ n m τ2) + ⊑t-↓ PTBase = PTBase + ⊑t-↓ PTHole = PTHole + ⊑t-↓ PTTVar = PTTVar + ⊑t-↓ (PTArr prec prec₁) = PTArr (⊑t-↓ prec) (⊑t-↓ prec₁) + ⊑t-↓ (PTForall prec) = PTForall (⊑t-↓ prec) + + ⊑t-TTsub : ∀{n τ1 τ2 τ3 τ4} → (τ1 ⊑t τ3) → (τ2 ⊑t τ4) → TTSub n τ1 τ2 ⊑t TTSub n τ3 τ4 + ⊑t-TTsub prec1 PTBase = PTBase + ⊑t-TTsub prec1 PTHole = PTHole + ⊑t-TTsub {n = n} prec1 (PTTVar {n = m}) with natEQ n m + ... | Inl refl = ⊑t-↓ (⊑t-↑ prec1) + ... | Inr neq = PTTVar + ⊑t-TTsub prec1 (PTArr prec2 prec3) = PTArr (⊑t-TTsub prec1 prec2) (⊑t-TTsub prec1 prec3) + ⊑t-TTsub {τ3 = τ3} prec1 (PTForall prec2) = PTForall (⊑t-TTsub prec1 prec2) + + ⊑c-var : ∀{n τ Γ Γ'} → (n , τ ∈ Γ) → Γ ⊑c Γ' → Σ[ τ' ∈ htyp ] ((n , τ' ∈ Γ') × (τ ⊑t τ')) + ⊑c-var (InCtxSkip inctx) (PCTVar precc) with ⊑c-var inctx precc + ... | τ' , inctx' , prec' = ↑ Z 1 τ' , InCtxSkip inctx' , ⊑t-↑ prec' + ⊑c-var InCtxZ (PCVar x precc) = _ , InCtxZ , x + ⊑c-var (InCtx1+ inctx) (PCVar x precc) with ⊑c-var inctx precc + ... | τ' , inctx' , prec' = τ' , InCtx1+ inctx' , prec' \ No newline at end of file diff --git a/lemmas-progress-checks.agda b/lemmas-progress-checks.agda index ed72a4d..d296f09 100644 --- a/lemmas-progress-checks.agda +++ b/lemmas-progress-checks.agda @@ -1,35 +1,37 @@ open import Nat open import Prelude open import core +open import core-exp +open import core-type module lemmas-progress-checks where -- boxed values don't have an instruction transition boxedval-not-trans : ∀{d d'} → d boxedval → d →> d' → ⊥ boxedval-not-trans (BVVal VConst) () boxedval-not-trans (BVVal VLam) () - boxedval-not-trans (BVArrCast x bv) (ITCastID) = x refl - boxedval-not-trans (BVHoleCast () bv) (ITCastID) - boxedval-not-trans (BVHoleCast () bv) (ITCastSucceed x₁) - boxedval-not-trans (BVHoleCast GHole bv) (ITGround (MGArr x)) = x refl - boxedval-not-trans (BVHoleCast x a) (ITExpand ()) - boxedval-not-trans (BVHoleCast x x₁) (ITCastFail x₂ () x₄) + boxedval-not-trans (BVArrCast x bv) ITCastID = x refl + boxedval-not-trans (BVForallCast x bv) ITCastID = x refl + boxedval-not-trans (BVHoleCast GArr bv) (ITGround (MGArr x)) = x refl + boxedval-not-trans (BVHoleCast GForall _) (ITGround (MGForall x)) = x refl -- indets don't have an instruction transition indet-not-trans : ∀{d d'} → d indet → d →> d' → ⊥ indet-not-trans IEHole () indet-not-trans (INEHole x) () indet-not-trans (IAp x₁ () x₂) (ITLam) - indet-not-trans (IAp x (ICastArr x₁ ind) x₂) (ITApCast ) = x _ _ _ _ _ refl + indet-not-trans (IAp x (ICastArr x₁ ind) x₂) (ITApCast) = x _ _ _ _ _ refl + indet-not-trans (ITAp x (ICastForall _ _)) (ITTApCast) = x _ _ _ refl indet-not-trans (ICastArr x ind) (ITCastID) = x refl - indet-not-trans (ICastGroundHole () ind) (ITCastID) - indet-not-trans (ICastGroundHole x ind) (ITCastSucceed ()) - indet-not-trans (ICastGroundHole GHole ind) (ITGround (MGArr x)) = x refl - indet-not-trans (ICastHoleGround x ind ()) (ITCastID) - indet-not-trans (ICastHoleGround x ind x₁) (ITCastSucceed x₂) = x _ _ refl - indet-not-trans (ICastHoleGround x ind GHole) (ITExpand (MGArr x₂)) = x₂ refl - indet-not-trans (ICastGroundHole x a) (ITExpand ()) - indet-not-trans (ICastHoleGround x a x₁) (ITGround ()) - indet-not-trans (ICastGroundHole x x₁) (ITCastFail x₂ () x₄) + indet-not-trans (ICastForall x ind) (ITCastID) = x refl + -- indet-not-trans (ICastGroundHole x ind) (ITCastSucceed g1 () eq) + indet-not-trans (ICastGroundHole GArr ind) (ITGround (MGArr x)) = x refl + indet-not-trans (ICastGroundHole GForall x₁) (ITGround (MGForall x₂)) = x₂ refl + indet-not-trans (ICastHoleGround x ind x₁) (ITCastSucceed g) = x _ _ refl + indet-not-trans (ICastHoleGround x ind GArr) (ITExpand (MGArr x₂)) = x₂ refl + indet-not-trans (ICastHoleGround x x₁ GForall) (ITExpand (MGForall x₃)) = x₃ refl + -- indet-not-trans (ICastGroundHole x a) (ITExpand ()) + -- indet-not-trans (ICastHoleGround x a x₁) (ITGround ()) + -- indet-not-trans (ICastGroundHole x x₁) (ITCastFail x₂ () x₄) indet-not-trans (ICastHoleGround x x₁ x₂) (ITCastFail x₃ x₄ x₅) = x _ _ refl indet-not-trans (IFailedCast x x₁ x₂ x₃) () @@ -49,15 +51,19 @@ module lemmas-progress-checks where final-sub-final x FHOuter = x final-sub-final (FBoxedVal (BVVal ())) (FHAp1 eps) final-sub-final (FBoxedVal (BVVal ())) (FHAp2 eps) + final-sub-final (FBoxedVal (BVVal ())) (FHTAp eps) final-sub-final (FBoxedVal (BVVal ())) (FHNEHole eps) final-sub-final (FBoxedVal (BVVal ())) (FHCast eps) final-sub-final (FBoxedVal (BVVal ())) (FHFailedCast y) final-sub-final (FBoxedVal (BVArrCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps + final-sub-final (FBoxedVal (BVForallCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps final-sub-final (FBoxedVal (BVHoleCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = final-sub-final (FIndet x₂) eps final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp2 eps) = final-sub-final x₃ eps + final-sub-final (FIndet (ITAp x₁ x₂)) (FHTAp ep) = final-sub-final (FIndet x₂) ep final-sub-final (FIndet (INEHole x₁)) (FHNEHole eps) = final-sub-final x₁ eps final-sub-final (FIndet (ICastArr x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps + final-sub-final (FIndet (ICastForall x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps final-sub-final (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps final-sub-final (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = final-sub-final (FIndet x₂) eps final-sub-final (FIndet (IFailedCast x₁ x₂ x₃ x₄)) (FHFailedCast y) = final-sub-final x₁ y diff --git a/lemmas-subst-ta.agda b/lemmas-subst-ta.agda deleted file mode 100644 index c4753d7..0000000 --- a/lemmas-subst-ta.agda +++ /dev/null @@ -1,64 +0,0 @@ -open import Prelude -open import Nat -open import core -open import contexts -open import weakening -open import exchange -open import lemmas-disjointness -open import binders-disjoint-checks - -module lemmas-subst-ta where - -- this is what makes the binders-unique assumption below good enough: it - -- tells us that we can pick fresh variables - mutual - binders-envfresh : ∀{Δ Γ Γ' y σ} → Δ , Γ ⊢ σ :s: Γ' → y # Γ → unbound-in-σ y σ → binders-unique-σ σ → envfresh y σ - binders-envfresh {Γ' = Γ'} {y = y} (STAId x) apt unbound unique with ctxindirect Γ' y - binders-envfresh {Γ' = Γ'} {y = y} (STAId x₁) apt unbound unique | Inl x = abort (somenotnone (! (x₁ y (π1 x) (π2 x)) · apt)) - binders-envfresh (STAId x₁) apt unbound unique | Inr x = EFId x - binders-envfresh {Γ = Γ} {y = y} (STASubst {y = z} subst x₁) apt (UBσSubst x₂ unbound neq) (BUσSubst zz x₃ x₄) = - EFSubst (binders-fresh {y = y} x₁ zz x₂ apt) - (binders-envfresh subst (apart-extend1 Γ neq apt) unbound x₃) - neq - - binders-fresh : ∀{ Δ Γ d2 τ y} → Δ , Γ ⊢ d2 :: τ - → binders-unique d2 - → unbound-in y d2 - → Γ y == None - → fresh y d2 - binders-fresh TAConst BUHole UBConst apt = FConst - binders-fresh {y = y} (TAVar {x = x} x₁) BUVar UBVar apt with natEQ y x - binders-fresh (TAVar x₂) BUVar UBVar apt | Inl refl = abort (somenotnone (! x₂ · apt)) - binders-fresh (TAVar x₂) BUVar UBVar apt | Inr x₁ = FVar x₁ - binders-fresh {y = y} (TALam {x = x} x₁ wt) bu2 ub apt with natEQ y x - binders-fresh (TALam x₂ wt) bu2 (UBLam2 x₁ ub) apt | Inl refl = abort (x₁ refl) - binders-fresh {Γ = Γ} (TALam {x = x} x₂ wt) (BULam bu2 x₃) (UBLam2 x₄ ub) apt | Inr x₁ = FLam x₁ (binders-fresh wt bu2 ub (apart-extend1 Γ x₄ apt)) - binders-fresh (TAAp wt wt₁) (BUAp bu2 bu3 x) (UBAp ub ub₁) apt = FAp (binders-fresh wt bu2 ub apt) (binders-fresh wt₁ bu3 ub₁ apt) - binders-fresh (TAEHole x₁ x₂) (BUEHole x) (UBHole x₃) apt = FHole (binders-envfresh x₂ apt x₃ x ) - binders-fresh (TANEHole x₁ wt x₂) (BUNEHole bu2 x) (UBNEHole x₃ ub) apt = FNEHole (binders-envfresh x₂ apt x₃ x) (binders-fresh wt bu2 ub apt) - binders-fresh (TACast wt x₁) (BUCast bu2) (UBCast ub) apt = FCast (binders-fresh wt bu2 ub apt) - binders-fresh (TAFailedCast wt x x₁ x₂) (BUFailedCast bu2) (UBFailedCast ub) apt = FFailedCast (binders-fresh wt bu2 ub apt) - - -- the substition lemma for preservation - lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } → - x # Γ → - binders-disjoint d1 d2 → - binders-unique d2 → - Δ , Γ ,, (x , τ1) ⊢ d1 :: τ → - Δ , Γ ⊢ d2 :: τ1 → - Δ , Γ ⊢ [ d2 / x ] d1 :: τ - lem-subst apt bd bu2 TAConst wt2 = TAConst - lem-subst {x = x} apt bd bu2 (TAVar {x = x'} x₂) wt2 with natEQ x' x - lem-subst {Γ = Γ} apt bd bu2 (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃ - lem-subst apt bd bu2 (TAVar x₃) wt2 | Inl refl | refl = wt2 - lem-subst {Γ = Γ} apt bd bu2 (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃) - lem-subst {Δ = Δ} {Γ = Γ} {x = x} {d2 = d2} x#Γ (BDLam bd bd') bu2 (TALam {x = y} {τ1 = τ1} {d = d} {τ2 = τ2} x₂ wt1) wt2 - with lem-union-none {Γ = Γ} x₂ - ... | x≠y , y#Γ with natEQ y x - ... | Inl eq = abort (x≠y (! eq)) - ... | Inr _ = TALam y#Γ (lem-subst {Δ = Δ} {Γ = Γ ,, (y , τ1)} {x = x} {d1 = d} (apart-extend1 Γ x≠y x#Γ) bd bu2 (exchange-ta-Γ {Γ = Γ} x≠y wt1) - (weaken-ta (binders-fresh wt2 bu2 bd' y#Γ) wt2)) - lem-subst apt (BDAp bd bd₁) bu3 (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt bd bu3 wt1 wt3) (lem-subst apt bd₁ bu3 wt2 wt3) - lem-subst apt bd bu2 (TAEHole inΔ sub) wt2 = TAEHole inΔ (STASubst sub wt2) - lem-subst apt (BDNEHole x₁ bd) bu2 (TANEHole x₃ wt1 x₄) wt2 = TANEHole x₃ (lem-subst apt bd bu2 wt1 wt2) (STASubst x₄ wt2) - lem-subst apt (BDCast bd) bu2 (TACast wt1 x₁) wt2 = TACast (lem-subst apt bd bu2 wt1 wt2) x₁ - lem-subst apt (BDFailedCast bd) bu2 (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt bd bu2 wt1 wt2) x₁ x₂ x₃ diff --git a/lemmas-subst.agda b/lemmas-subst.agda new file mode 100644 index 0000000..ae69357 --- /dev/null +++ b/lemmas-subst.agda @@ -0,0 +1,81 @@ +open import Nat +open import Prelude +open import core-type +open import core-exp +open import core-subst +open import core +open import weakening +open import lemmas-index +open import lemmas-ctx +open import lemmas-consistency +open import lemmas-meet + +module lemmas-subst where + + wf-TTSub-helper2 : + ∀{t n Γ} → + (t == n → ⊥) → + (TVar, (ctx-extend-tvars t Γ)) ⊢ T n wf → + (TVar, (ctx-extend-tvars t Γ)) ⊢ T (1+ (↓Nat t 1 n)) wf + wf-TTSub-helper2 {t = Z} neq WFVarZ = abort (neq refl) + wf-TTSub-helper2 {t = 1+ t} neq WFVarZ = WFVarS WFVarZ + wf-TTSub-helper2 {t = Z} neq (WFVarS wf) = WFVarS wf + wf-TTSub-helper2 {t = 1+ t} neq (WFVarS {n = n} wf) = WFVarS (wf-TTSub-helper2 {t = t} (h1 neq) wf) + where + h1 : (1+ t == 1+ n → ⊥) → t == n → ⊥ + h1 neq eq rewrite eq = neq refl + + wf-TTSub-helper3 : + ∀{m n Γ τ} → + Γ ⊢ τ wf → + (ctx-extend-tvars n Γ) ⊢ ↓ (m nat+ n) 1 (↑ m (1+ n) τ) wf + wf-TTSub-helper3 {m = m} {n = n} {Γ = τ , Γ} (WFSkip wf) with wf-TTSub-helper3 {m = m} {n = n} wf + ... | result = weakening-wf-var-n result + wf-TTSub-helper3 {m = Z} {n = Z} {Γ = TVar, Γ} WFVarZ = WFVarZ + wf-TTSub-helper3 {m = Z} {n = 1+ n} {Γ = TVar, Γ} WFVarZ = WFVarS (wf-TTSub-helper3 {m = Z} {n = n} WFVarZ) + wf-TTSub-helper3 {m = 1+ m} {n = n} {Γ = TVar, Γ} WFVarZ rewrite extend-tvar-comm n Γ = WFVarZ + wf-TTSub-helper3 {m = Z} {n = Z} {Γ = TVar, Γ} (WFVarS wf) = WFVarS wf + wf-TTSub-helper3 {m = Z} {n = 1+ n} {Γ = TVar, Γ} (WFVarS wf) = WFVarS (wf-TTSub-helper3 {m = Z} {n = n} (WFVarS wf)) + wf-TTSub-helper3 {m = 1+ m} {n = Z} {Γ = TVar, Γ} (WFVarS wf) = WFVarS (wf-TTSub-helper3 {m = m} {n = Z} wf) + wf-TTSub-helper3 {m = 1+ m} {n = 1+ n} {Γ = TVar, Γ} (WFVarS wf) with wf-TTSub-helper3 {m = m} {n = 1+ n} wf + ... | result rewrite sym (extend-tvar-comm n Γ) = WFVarS result + wf-TTSub-helper3 {m = m} {n = n} {Γ = Γ} WFBase = WFBase + wf-TTSub-helper3 {m = m} {n = n} {Γ = Γ} WFHole = WFHole + wf-TTSub-helper3 {m = m} {n = n} {Γ = Γ} (WFArr wf wf₁) = WFArr (wf-TTSub-helper3 wf) (wf-TTSub-helper3 wf₁) + wf-TTSub-helper3 {m = m} {n = n} {Γ = Γ} (WFForall wf) with wf-TTSub-helper3 {m = 1+ m} {n = n} wf + ... | result rewrite extend-tvar-comm n Γ = WFForall result + + wf-TTSub-helper : ∀{Γ n τ1 τ2} → (Γ ⊢ τ1 wf) → (ctx-extend-tvars (1+ n) Γ) ⊢ τ2 wf → ((ctx-extend-tvars n Γ) ⊢ TTSub n τ1 τ2 wf) + wf-TTSub-helper wf1 WFBase = WFBase + wf-TTSub-helper wf1 WFHole = WFHole + wf-TTSub-helper wf1 (WFArr wf2 wf3) = WFArr (wf-TTSub-helper wf1 wf2) (wf-TTSub-helper wf1 wf3) + wf-TTSub-helper {Γ = ∅} {n = Z} {τ1 = τ1} wf1 WFVarZ rewrite ↓↑-invert {Z} {Z} {τ1} rewrite ↑Z Z τ1 = wf1 + wf-TTSub-helper {n = 1+ n} wf1 WFVarZ = WFVarZ + wf-TTSub-helper {Γ = τ , Γ} {n = Z} {τ1 = τ1} wf1 WFVarZ rewrite ↓↑-invert {Z} {Z} {τ1} rewrite ↑Z Z τ1 = wf1 + wf-TTSub-helper {Γ = TVar, Γ} {n = Z} {τ1 = τ1} wf1 WFVarZ rewrite ↓↑-invert {Z} {Z} {τ1} rewrite ↑Z Z τ1 = wf1 + wf-TTSub-helper {n = Z} wf1 (WFVarS wf2) = wf2 + wf-TTSub-helper {n = 1+ n} wf1 (WFVarS {n = m} wf2) with natEQ n m + wf-TTSub-helper {Γ = Γ} {1+ n} {τ1 = τ1} wf1 (WFVarS {n = m} wf2) | Inl refl = wf-TTSub-helper3 {m = Z} {n = 1+ n} wf1 + wf-TTSub-helper {n = 1+ n} wf1 (WFVarS {n = m} wf2) | Inr neq = wf-TTSub-helper2 neq wf2 + wf-TTSub-helper {Γ = Γ} {n = n} {τ1 = τ1} wf1 (WFForall wf2) with (↑compose Z (1+ n) τ1) + ... | eq rewrite eq = WFForall (wf-TTSub-helper wf1 wf2) + + wf-TTSub : ∀{Γ τ1 τ2} → (Γ ⊢ τ1 wf) → ((TVar, Γ) ⊢ τ2 wf) → (Γ ⊢ (TTSub Z τ1 τ2) wf) + wf-TTSub {Γ = Γ} {τ1 = τ1} wf1 WFVarZ rewrite ↓↑-invert {Z} {Z} {τ1} rewrite ↑Z Z τ1 = wf1 + wf-TTSub wf1 (WFVarS wf2) = wf2 + wf-TTSub wf1 WFBase = WFBase + wf-TTSub wf1 WFHole = WFHole + wf-TTSub wf1 (WFArr wf2 wf3) = WFArr (wf-TTSub wf1 wf2) (wf-TTSub wf1 wf3) + wf-TTSub {τ1 = τ1} wf1 (WFForall wf2) rewrite ↑compose Z 1 τ1 = WFForall (wf-TTSub-helper wf1 wf2) + + ~TTSub-helper : ∀{n Γ τ1 τ2 τ3} → (ctx-extend-tvars (1+ n) Γ) ⊢ τ2 wf → (ctx-extend-tvars (1+ n) Γ) ⊢ τ3 wf → τ2 ~ τ3 → TTSub n τ1 τ2 ~ TTSub n τ1 τ3 + ~TTSub-helper wf2 wf3 ConsistBase = ConsistBase + ~TTSub-helper wf2 wf3 ConsistVar = ~refl + ~TTSub-helper wf2 wf3 ConsistHole1 = ConsistHole1 + ~TTSub-helper wf2 wf3 ConsistHole2 = ConsistHole2 + ~TTSub-helper (WFArr wf2 wf3) (WFArr wf4 wf5) (ConsistArr con1 con2) = ConsistArr (~TTSub-helper wf2 wf4 con1) (~TTSub-helper wf3 wf5 con2) + ~TTSub-helper {n = n} {τ1 = τ1} (WFForall wf2) (WFForall wf3) (ConsistForall con) with ↑compose Z (1+ n) τ1 + ...| eq rewrite eq = ConsistForall (~TTSub-helper wf2 wf3 con) + + ~TTSub : ∀ {Γ τ1 τ2 τ3} → (TVar, Γ) ⊢ τ2 wf → (TVar, Γ) ⊢ τ3 wf → τ2 ~ τ3 → TTSub Z τ1 τ2 ~ TTSub Z τ1 τ3 + ~TTSub wf2 wf3 con = ~TTSub-helper wf2 wf3 con \ No newline at end of file diff --git a/lemmas-wf.agda b/lemmas-wf.agda new file mode 100644 index 0000000..045682d --- /dev/null +++ b/lemmas-wf.agda @@ -0,0 +1,119 @@ +open import Nat +open import Prelude +open import core-type +open import core-subst +open import core +open import weakening +open import lemmas-index +open import lemmas-meet +open import lemmas-subst + +module lemmas-wf where + + wf-inc : ∀{Γ τ m} → Γ ⊢ τ wf → (TVar, Γ) ⊢ ↑ m 1 τ wf + wf-inc {m = m} (WFSkip wf) = weakening-wf-var-n (wf-inc {m = m} wf) + wf-inc {m = Z} WFVarZ = WFVarS WFVarZ + wf-inc {m = 1+ m} WFVarZ = WFVarZ + wf-inc {m = Z} (WFVarS wf) = WFVarS (WFVarS wf) + wf-inc {m = 1+ m} (WFVarS wf) = WFVarS (wf-inc {m = m} wf) + wf-inc WFBase = WFBase + wf-inc WFHole = WFHole + wf-inc (WFArr wf wf₁) = WFArr (wf-inc wf) (wf-inc wf₁) + wf-inc (WFForall wf) = WFForall (wf-inc wf) + + -- duplicate with weakening-wf-var + -- wf-skip-helper : ∀{τ'} → (n : Nat) → (Γ : ctx) → (τ : htyp) → ctx-extend-tvars n Γ ⊢ τ' wf → ctx-extend-tvars n (τ , Γ) ⊢ τ' wf + -- wf-skip-helper Z (x , Γ) τ (WFSkip wf) = WFSkip (WFSkip wf) + -- wf-skip-helper Z (TVar, Γ) τ WFVarZ = WFSkip WFVarZ + -- wf-skip-helper Z (TVar, Γ) τ (WFVarS wf) = WFSkip (WFVarS wf) + -- wf-skip-helper (1+ n) Γ τ WFVarZ = WFVarZ + -- wf-skip-helper (1+ n) Γ τ (WFVarS wf) = WFVarS (wf-skip-helper n Γ τ wf) + -- wf-skip-helper n Γ τ WFBase = WFBase + -- wf-skip-helper n Γ τ WFHole = WFHole + -- wf-skip-helper n Γ τ (WFArr wf wf₁) = WFArr (wf-skip-helper n Γ τ wf) (wf-skip-helper n Γ τ wf₁) + -- wf-skip-helper n Γ τ (WFForall wf) = WFForall (wf-skip-helper (1+ n) Γ τ wf) + + -- wf-skip : ∀{Γ τ x} → Γ ⊢ τ wf → (x , Γ) ⊢ τ wf + -- wf-skip wf = wf-skip-helper _ _ _ wf + + wf-ctx-var : ∀{τ n Γ} → + ⊢ Γ ctxwf → + n , τ ∈ Γ → + Γ ⊢ τ wf + wf-ctx-var CtxWFEmpty () + wf-ctx-var (CtxWFVar x ctxwf) InCtxZ = weakening-wf-var x + wf-ctx-var (CtxWFVar x ctxwf) (InCtx1+ inctx) = weakening-wf-var (wf-ctx-var ctxwf inctx) + wf-ctx-var (CtxWFTVar ctxwf) (InCtxSkip inctx) = wf-inc (wf-ctx-var ctxwf inctx) + + wf-⊑t : ∀{Γ1 Γ2 τ1 τ2} → Γ1 ⊢ τ1 wf → Γ1 ⊑c Γ2 → τ1 ⊑t τ2 → Γ2 ⊢ τ2 wf + wf-⊑t wf precc PTBase = WFBase + wf-⊑t _ precc PTHole = WFHole + wf-⊑t (WFArr wf1 wf2) precc (PTArr prec1 prec2) = WFArr (wf-⊑t wf1 precc prec1) (wf-⊑t wf2 precc prec2) + wf-⊑t (WFForall wf) precc (PTForall prec) = WFForall (wf-⊑t wf (PCTVar precc) prec) + wf-⊑t (WFSkip wf) (PCVar x precc) PTTVar = WFSkip (wf-⊑t wf precc PTTVar) + wf-⊑t WFVarZ (PCTVar precc) PTTVar = WFVarZ + wf-⊑t (WFVarS wf) (PCTVar precc) PTTVar = WFVarS (wf-⊑t wf precc PTTVar) + + wf-⊓ : ∀{τ1 τ2 τ3 Γ} → τ1 ⊓ τ2 == τ3 → Γ ⊢ τ1 wf → Γ ⊢ τ2 wf → Γ ⊢ τ3 wf + wf-⊓ MeetHoleL wf1 wf2 = wf2 + wf-⊓ MeetHoleR wf1 wf2 = wf1 + wf-⊓ MeetBase wf1 wf2 = wf2 + wf-⊓ MeetVar wf1 wf2 = wf2 + wf-⊓ (MeetArr meet meet₁) (WFArr wf1 wf2) (WFArr wf3 wf4) = WFArr (wf-⊓ meet wf1 wf3) (wf-⊓ meet₁ wf2 wf4) + wf-⊓ (MeetForall meet) (WFForall wf1) (WFForall wf2) = WFForall (wf-⊓ meet wf1 wf2) + + wf-gnd : ∀{Γ τ} → τ ground → Γ ⊢ τ wf + wf-gnd GBase = WFBase + wf-gnd GArr = WFArr WFHole WFHole + wf-gnd GForall = WFForall WFHole + + wf-syn : ∀{τ e Γ} → + ⊢ Γ ctxwf → + Γ ⊢ e => τ → + Γ ⊢ τ wf + wf-syn ctxwf SConst = WFBase + wf-syn ctxwf (SAsc x x₁) = x + wf-syn ctxwf (SVar x) = wf-ctx-var ctxwf x + wf-syn ctxwf (SAp syn meet _) with wf-⊓ meet (wf-syn ctxwf syn) (WFArr WFHole WFHole) + ... | WFArr _ wf = wf + wf-syn ctxwf SEHole = WFHole + wf-syn ctxwf (SNEHole syn) = WFHole + wf-syn ctxwf (SLam x syn) = WFArr x (strengthen-wf-var (wf-syn (CtxWFVar x ctxwf) syn)) + wf-syn ctxwf (STLam syn) = WFForall (wf-syn (CtxWFTVar ctxwf) syn) + wf-syn ctxwf (STAp wf syn meet refl) with wf-⊓ meet (wf-syn ctxwf syn) (WFForall WFHole) + ... | WFForall wf' = wf-TTSub wf wf' + + wf-elab-syn : ∀{τ e d Γ} → + ⊢ Γ ctxwf → + Γ ⊢ e ⇒ τ ~> d → + Γ ⊢ τ wf + wf-elab-syn ctxwf ESConst = WFBase + wf-elab-syn ctxwf (ESVar x) = wf-ctx-var ctxwf x + wf-elab-syn ctxwf (ESLam x syn) = WFArr x (strengthen-wf-var (wf-elab-syn (CtxWFVar x ctxwf) syn)) + wf-elab-syn ctxwf (ESTLam syn) = WFForall (wf-elab-syn (CtxWFTVar ctxwf) syn) + wf-elab-syn ctxwf (ESAp syn meet _ _) with wf-⊓ meet (wf-syn ctxwf syn) (WFArr WFHole WFHole) + ... | WFArr _ wf = wf + wf-elab-syn ctxwf (ESTAp wf syn meet _ refl) with wf-⊓ meet (wf-syn ctxwf syn) (WFForall WFHole) + ... | WFForall wf' = wf-TTSub wf wf' + wf-elab-syn ctxwf ESEHole = WFHole + wf-elab-syn ctxwf (ESNEHole syn) = WFHole + wf-elab-syn ctxwf (ESAsc x x₁) = x + + wf-ta : ∀{τ d Γ} → + ⊢ Γ ctxwf → + Γ ⊢ d :: τ → + Γ ⊢ τ wf + wf-ta ctxwf TAConst = WFBase + wf-ta ctxwf (TAVar x) = wf-ctx-var ctxwf x + wf-ta ctxwf (TALam x wt) = WFArr x (strengthen-wf-var (wf-ta (CtxWFVar x ctxwf) wt)) + wf-ta ctxwf (TATLam wt) = WFForall (wf-ta (CtxWFTVar ctxwf) wt) + wf-ta ctxwf (TAAp wt wt₁) with wf-ta ctxwf wt + ... | WFArr _ wf = wf + wf-ta ctxwf (TATAp x wt refl) with wf-ta ctxwf wt + ... | WFForall wf = wf-TTSub x wf + wf-ta ctxwf TAEHole = WFHole + wf-ta ctxwf (TANEHole _) = WFHole + wf-ta ctxwf (TACast _ wf _) = wf + wf-ta ctxwf (TAFailedCast wt _ GBase _) = WFBase + wf-ta ctxwf (TAFailedCast wt _ GArr _) = WFArr WFHole WFHole + wf-ta ctxwf (TAFailedCast wt _ GForall _) = WFForall WFHole \ No newline at end of file diff --git a/parametricity.agda b/parametricity.agda new file mode 100644 index 0000000..d60176a --- /dev/null +++ b/parametricity.agda @@ -0,0 +1,396 @@ +open import Nat +open import Prelude +open import core-type +open import core-exp +open import core-subst +open import core + +open import lemmas-index +open import lemmas-consistency +open import lemmas-prec +open import lemmas-meet +open import lemmas-subst +open import lemmas-wf +open import lemmas-complete + +open import typed-elaboration +open import complete-elaboration +open import preservation +open import complete-preservation + +module parametricity where + + data _=0_ : (d1 d2 : ihexp) → Set where + Eq0Const : c =0 c + Eq0Var : ∀{x} → (X x) =0 (X x) + Eq0EHole : ⦇-⦈ =0 ⦇-⦈ + Eq0Lam : ∀{d1 d2 τ1 τ2} → d1 =0 d2 → (·λ[ τ1 ] d1) =0 (·λ[ τ2 ] d2) + Eq0TLam : ∀{d1 d2} → d1 =0 d2 → (·Λ d1) =0 (·Λ d2) + Eq0NEHole : ∀{d1 d2} → d1 =0 d2 → ⦇⌜ d1 ⌟⦈ =0 ⦇⌜ d2 ⌟⦈ + Eq0Ap : ∀{d1 d2 d3 d4} → d1 =0 d3 → d2 =0 d4 → (d1 ∘ d2) =0 (d3 ∘ d4) + Eq0TAp : ∀{d1 d2 τ1 τ2} → d1 =0 d2 → (d1 < τ1 >) =0 (d2 < τ2 >) + Eq0Cast : ∀{d1 d2 τ1 τ2 τ3 τ4} → d1 =0 d2 → (d1 ⟨ τ1 ⇒ τ2 ⟩) =0 (d2 ⟨ τ3 ⇒ τ4 ⟩) + Eq0FailedCast : ∀{d1 d2 τ1 τ2 τ3 τ4} → d1 =0 d2 → (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) =0 (d2 ⟨ τ3 ⇒⦇-⦈⇏ τ4 ⟩) + + data _=0'_ : (d1 d2 : ihexp) → Set where + Eq0Const : c =0' c + Eq0Var : ∀{x} → (X x) =0' (X x) + Eq0EHole : ⦇-⦈ =0' ⦇-⦈ + Eq0Lam : ∀{d1 d2 τ1 τ2} → d1 =0' d2 → (·λ[ τ1 ] d1) =0' (·λ[ τ2 ] d2) + Eq0TLam : ∀{d1 d2} → d1 =0' d2 → (·Λ d1) =0' (·Λ d2) + Eq0NEHole : ∀{d1 d2} → d1 =0' d2 → ⦇⌜ d1 ⌟⦈ =0' ⦇⌜ d2 ⌟⦈ + Eq0Ap : ∀{d1 d2 d3 d4} → d1 =0' d3 → d2 =0' d4 → (d1 ∘ d2) =0' (d3 ∘ d4) + Eq0TAp : ∀{d1 d2 τ1 τ2} → d1 =0' d2 → (d1 < τ1 >) =0' (d2 < τ2 >) + Eq0Cast : ∀{d1 d2 τ1 τ2} → d1 =0' d2 → (d1 ⟨ τ1 ⇒ τ1 ⟩) =0' (d2 ⟨ τ2 ⇒ τ2 ⟩) + Eq0FailedCast : ∀{d1 d2 τ1 τ2} → d1 =0' d2 → (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) =0' (d2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + + data _=0e_ : (e1 e2 : hexp) → Set where + Eq0Const : c =0e c + Eq0Var : ∀{x} → (X x) =0e (X x) + Eq0Asc : ∀{e1 e2 τ1 τ2} → e1 =0e e2 → (e1 ·: τ1) =0e (e2 ·: τ2) + Eq0EHole : ⦇-⦈ =0e ⦇-⦈ + Eq0ULam : ∀{e1 e2} → e1 =0e e2 → (·λ e1) =0e (·λ e2) + Eq0Lam : ∀{e1 e2 τ1 τ2} → e1 =0e e2 → (·λ[ τ1 ] e1) =0e (·λ[ τ2 ] e2) + Eq0TLam : ∀{e1 e2} → e1 =0e e2 → (·Λ e1) =0e (·Λ e2) + Eq0NEHole : ∀{e1 e2} → e1 =0e e2 → (⦇⌜ e1 ⌟⦈) =0e (⦇⌜ e2 ⌟⦈) + Eq0Ap : ∀{e1 e2 e3 e4} → e1 =0e e3 → e2 =0e e4 → (e1 ∘ e2) =0e (e3 ∘ e4) + Eq0TAp : ∀{e1 e2 τ1 τ2} → e1 =0e e2 → (e1 < τ1 >) =0e (e2 < τ2 >) + + data _=0ε'_ : (ε1 ε2 : ectx) → Set where + Eq0Dot : ⊙ =0ε' ⊙ + Eq0Ap1 : ∀{ε1 ε2 d1 d2} → (ε1 =0ε' ε2) → (d1 =0' d2) → (ε1 ∘₁ d1) =0ε' (ε2 ∘₁ d2) + Eq0Ap2 : ∀{ε1 ε2 d1 d2} → (ε1 =0ε' ε2) → (d1 =0' d2) → (d1 ∘₂ ε1) =0ε' (d2 ∘₂ ε2) + Eq0TAp : ∀{ε1 ε2 τ1 τ2} → (ε1 =0ε' ε2) → (ε1 < τ1 >) =0ε' (ε2 < τ2 >) + Eq0NEHole : ∀{ε1 ε2} → (ε1 =0ε' ε2) → ⦇⌜ ε1 ⌟⦈ =0ε' ⦇⌜ ε2 ⌟⦈ + Eq0Cast : ∀{ε1 ε2 τ1 τ2} → (ε1 =0ε' ε2) → (ε1 ⟨ τ1 ⇒ τ1 ⟩) =0ε' (ε2 ⟨ τ2 ⇒ τ2 ⟩) + Eq0FailedCast : ∀{ε1 ε2 τ1 τ2} → (ε1 =0ε' ε2) → (ε1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) =0ε' (ε2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + + eq0-refl : ∀{d : ihexp} → d =0 d + eq0-refl {d = c} = Eq0Const + eq0-refl {d = X x} = Eq0Var + eq0-refl {d = ·λ[ x₁ ] d} = Eq0Lam eq0-refl + eq0-refl {d = ·Λ d} = Eq0TLam eq0-refl + eq0-refl {d = ⦇-⦈} = Eq0EHole + eq0-refl {d = ⦇⌜ d ⌟⦈} = Eq0NEHole eq0-refl + eq0-refl {d = d ∘ d₁} = Eq0Ap eq0-refl eq0-refl + eq0-refl {d = d < x >} = Eq0TAp eq0-refl + eq0-refl {d = d ⟨ x ⇒ x₁ ⟩} = Eq0Cast eq0-refl + eq0-refl {d = d ⟨ x ⇒⦇-⦈⇏ x₁ ⟩} = Eq0FailedCast eq0-refl + + eq0-sym : ∀{d d' : ihexp} → d =0 d' → d' =0 d + eq0-sym Eq0Const = Eq0Const + eq0-sym Eq0Var = Eq0Var + eq0-sym Eq0EHole = Eq0EHole + eq0-sym (Eq0Lam eq0) = Eq0Lam (eq0-sym eq0) + eq0-sym (Eq0TLam eq0) = Eq0TLam (eq0-sym eq0) + eq0-sym (Eq0NEHole eq0) = Eq0NEHole (eq0-sym eq0) + eq0-sym (Eq0Ap eq0 eq1) = Eq0Ap (eq0-sym eq0) (eq0-sym eq1) + eq0-sym (Eq0TAp eq0) = Eq0TAp (eq0-sym eq0) + eq0-sym (Eq0Cast eq0) = Eq0Cast (eq0-sym eq0) + eq0-sym (Eq0FailedCast eq0) = Eq0FailedCast (eq0-sym eq0) + + eq0e-sym : ∀{e e' : hexp} → e =0e e' → e' =0e e + eq0e-sym Eq0Const = Eq0Const + eq0e-sym Eq0Var = Eq0Var + eq0e-sym (Eq0Asc eq0) = Eq0Asc (eq0e-sym eq0) + eq0e-sym Eq0EHole = Eq0EHole + eq0e-sym (Eq0ULam eq0) = Eq0ULam (eq0e-sym eq0) + eq0e-sym (Eq0Lam eq0) = Eq0Lam (eq0e-sym eq0) + eq0e-sym (Eq0TLam eq0) = Eq0TLam (eq0e-sym eq0) + eq0e-sym (Eq0NEHole eq0) = Eq0NEHole (eq0e-sym eq0) + eq0e-sym (Eq0Ap eq0 eq1) = Eq0Ap (eq0e-sym eq0) (eq0e-sym eq1) + eq0e-sym (Eq0TAp eq0) = Eq0TAp (eq0e-sym eq0) + + eq0-boxedval' : + ∀ {d1 d2} → + d1 =0' d2 → + d1 boxedval → + d2 boxedval + eq0-boxedval' {d2 = d2} Eq0Const bv = bv + eq0-boxedval' {d2 = d2} Eq0Var bv = bv + eq0-boxedval' {d2 = d2} (Eq0Lam eq) bv = BVVal VLam + eq0-boxedval' {d2 = d2} (Eq0TLam eq) bv = BVVal VTLam + eq0-boxedval' (Eq0Cast eq) (BVArrCast x bv) = abort (x refl) + eq0-boxedval' (Eq0Cast eq) (BVForallCast x bv) = abort (x refl) + eq0-boxedval' (Eq0Cast eq) (BVHoleCast () bv) + eq0-boxedval' Eq0EHole (BVVal ()) + eq0-boxedval' (Eq0NEHole eq) (BVVal ()) + eq0-boxedval' (Eq0Ap eq eq₁) (BVVal ()) + eq0-boxedval' (Eq0TAp eq) (BVVal ()) + eq0-boxedval' (Eq0FailedCast x₁) (BVVal ()) + + eq0-↑d : ∀{t1 n t2 m d d'} → d =0' d' → ↑d t1 n t2 m d =0' ↑d t1 n t2 m d' + eq0-↑d Eq0Const = Eq0Const + eq0-↑d Eq0Var = Eq0Var + eq0-↑d Eq0EHole = Eq0EHole + eq0-↑d (Eq0Lam eq) = Eq0Lam (eq0-↑d eq) + eq0-↑d (Eq0TLam eq) = Eq0TLam (eq0-↑d eq) + eq0-↑d (Eq0NEHole eq) = Eq0NEHole (eq0-↑d eq) + eq0-↑d (Eq0Ap eq eq₁) = Eq0Ap (eq0-↑d eq) (eq0-↑d eq₁) + eq0-↑d (Eq0TAp eq) = Eq0TAp (eq0-↑d eq) + eq0-↑d (Eq0Cast eq) = Eq0Cast (eq0-↑d eq) + eq0-↑d (Eq0FailedCast eq) = Eq0FailedCast (eq0-↑d eq) + + eq0-ttSub : ∀{n m d1 d2 d1' d2'} → d1 =0' d1' → d2 =0' d2' → ttSub n m d1 d2 =0' ttSub n m d1' d2' + eq0-ttSub eq1 Eq0Const = Eq0Const + eq0-ttSub eq1 Eq0EHole = Eq0EHole + eq0-ttSub eq1 (Eq0NEHole eq2) = Eq0NEHole (eq0-ttSub eq1 eq2) + eq0-ttSub eq1 (Eq0Ap eq2 eq3) = Eq0Ap (eq0-ttSub eq1 eq2) (eq0-ttSub eq1 eq3) + eq0-ttSub eq1 (Eq0TAp eq2) = Eq0TAp (eq0-ttSub eq1 eq2) + eq0-ttSub eq1 (Eq0Cast eq2) = Eq0Cast (eq0-ttSub eq1 eq2) + eq0-ttSub eq1 (Eq0FailedCast eq2) = Eq0FailedCast (eq0-ttSub eq1 eq2) + eq0-ttSub {n} {m} {d1} {d1'} {d2} {d2'} eq1 (Eq0Lam {d3} {d4} {τ1} {τ2} eq2) = Eq0Lam (eq0-ttSub eq1 eq2) + eq0-ttSub {n} {m} {d1} {d2} {d1'} {d2'} eq1 (Eq0TLam {d3} {d4} eq2) = Eq0TLam (eq0-ttSub eq1 eq2) + eq0-ttSub {n} {m} {d1} {_} {d1'} eq1 (Eq0Var {x = x}) with natEQ x n + ... | Inl refl = eq0-↑d eq1 + ... | Inr neq = Eq0Var + + eq0-TtSub : ∀{n τ1 τ2 d1 d2} → d1 dcompleteid → d1 =0' d2 → TtSub n τ1 d1 =0' TtSub n τ2 d2 + eq0-TtSub dc Eq0Const = Eq0Const + eq0-TtSub dc Eq0Var = Eq0Var + eq0-TtSub dc Eq0EHole = Eq0EHole + eq0-TtSub (DCLam dc x) (Eq0Lam eq) = Eq0Lam (eq0-TtSub dc eq) + eq0-TtSub {n} {τ1} {τ2} (DCTLam dc) (Eq0TLam {d1 = d1} {d2 = d2} eq) = Eq0TLam (eq0-TtSub dc eq) + eq0-TtSub () (Eq0NEHole eq) + eq0-TtSub (DCAp dc dc₁) (Eq0Ap eq eq₁) = Eq0Ap (eq0-TtSub dc eq) (eq0-TtSub dc₁ eq₁) + eq0-TtSub (DCTAp x dc) (Eq0TAp eq) = Eq0TAp (eq0-TtSub dc eq) + eq0-TtSub (DCCast dc x) (Eq0Cast eq) = Eq0Cast (eq0-TtSub dc eq) + eq0-TtSub () (Eq0FailedCast eq) + + eq0'-eq0 : + ∀{d1 d2} → + d1 =0' d2 → + d1 =0 d2 + eq0'-eq0 Eq0Const = Eq0Const + eq0'-eq0 Eq0Var = Eq0Var + eq0'-eq0 Eq0EHole = Eq0EHole + eq0'-eq0 (Eq0Lam eq0) = Eq0Lam (eq0'-eq0 eq0) + eq0'-eq0 (Eq0TLam eq0) = Eq0TLam (eq0'-eq0 eq0) + eq0'-eq0 (Eq0NEHole eq0) = Eq0NEHole (eq0'-eq0 eq0) + eq0'-eq0 (Eq0Ap eq0 eq1) = Eq0Ap (eq0'-eq0 eq0) (eq0'-eq0 eq1) + eq0'-eq0 (Eq0TAp eq0) = Eq0TAp (eq0'-eq0 eq0) + eq0'-eq0 (Eq0Cast eq0) = Eq0Cast (eq0'-eq0 eq0) + eq0'-eq0 (Eq0FailedCast eq0) = Eq0FailedCast (eq0'-eq0 eq0) + + eq0-eq0' : + ∀{d1 d2} → + d1 dcompleteid → + d2 dcompleteid → + d1 =0 d2 → + d1 =0' d2 + eq0-eq0' DCVar _ Eq0Var = Eq0Var + eq0-eq0' DCConst _ Eq0Const = Eq0Const + eq0-eq0' (DCLam complete x) (DCLam complete' x₁) (Eq0Lam eq0) = Eq0Lam (eq0-eq0' complete complete' eq0) + eq0-eq0' (DCTLam complete) (DCTLam complete') (Eq0TLam eq0) = Eq0TLam (eq0-eq0' complete complete' eq0) + eq0-eq0' (DCAp complete complete₁) (DCAp complete' complete'₁) (Eq0Ap eq0 eq1) = Eq0Ap (eq0-eq0' complete complete' eq0) (eq0-eq0' complete₁ complete'₁ eq1) + eq0-eq0' (DCTAp x complete) (DCTAp x' complete') (Eq0TAp eq0) = Eq0TAp (eq0-eq0' complete complete' eq0) + eq0-eq0' (DCCast complete t1compl) (DCCast complete' t1compl') (Eq0Cast eq0) = Eq0Cast (eq0-eq0' complete complete' eq0) + + mutual + eq0-elab-syn : ∀{e e' Γ Γ' d1 d2 τ τ'} → + e =0e e' → + Γ ⊢ e ⇒ τ ~> d1 → + Γ' ⊢ e' ⇒ τ' ~> d2 → + d1 =0 d2 + eq0-elab-syn Eq0Const ESConst ESConst = Eq0Const + eq0-elab-syn Eq0Var (ESVar x) (ESVar x₁) = Eq0Var + eq0-elab-syn (Eq0Asc eq0) (ESAsc x x₁) (ESAsc x₂ x₃) = Eq0Cast (eq0-elab-ana eq0 x₁ x₃) + eq0-elab-syn Eq0EHole ESEHole ESEHole = Eq0EHole + eq0-elab-syn (Eq0Lam eq0) (ESLam x elab1) (ESLam x₂ elab2) = Eq0Lam (eq0-elab-syn eq0 elab1 elab2) + eq0-elab-syn (Eq0TLam eq0) (ESTLam elab1) (ESTLam elab2) = Eq0TLam (eq0-elab-syn eq0 elab1 elab2) + eq0-elab-syn (Eq0NEHole eq0) (ESNEHole elab1) (ESNEHole elab2) = Eq0NEHole (eq0-elab-syn eq0 elab1 elab2) + eq0-elab-syn (Eq0Ap eq0 eq1) (ESAp x x₁ x₂ x₄) (ESAp x₆ x₇ x₈ x₁₀) = Eq0Ap (Eq0Cast (eq0-elab-ana eq0 x₂ x₈)) (Eq0Cast (eq0-elab-ana eq1 x₄ x₁₀)) + eq0-elab-syn (Eq0TAp eq0) (ESTAp x x₁ x₂ x₃ x₄) (ESTAp x₅ x₆ x₇ x₈ x₉) = Eq0TAp (Eq0Cast (eq0-elab-ana eq0 x₃ x₈)) + + eq0-elab-ana : ∀{e e' Γ Γ' d1 d2 τ1 τ1' τ2 τ2''} → + e =0e e' → + Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' → + Γ' ⊢ e' ⇐ τ2 ~> d2 :: τ2'' → + d1 =0 d2 + eq0-elab-ana (Eq0ULam eq0) (EALam x elab1) (EALam x₂ elab2) = Eq0Lam (eq0-elab-ana eq0 elab1 elab2) + eq0-elab-ana (Eq0TLam eq0) (EATLam x₂ elab1) (EATLam x₅ elab2) = Eq0TLam (eq0-elab-ana eq0 elab1 elab2) + eq0-elab-ana eq0 (EASubsume x x₂ x₃) (EASubsume x₅ x₆ x₇) = Eq0Cast (eq0-elab-syn eq0 x₂ x₆) + eq0-elab-ana (Eq0TLam eq0) (EASubsume (Subsumable neq) x₂ x₃) (EATLam x₇ ana) = abort (neq _ refl) + eq0-elab-ana (Eq0TLam eq0) (EATLam x₅ ana) (EASubsume (Subsumable neq) x₂ x₃) = abort (neq _ refl) + + consist-complete-eq : ∀{τ τ'} → + τ tcomplete → + τ' tcomplete → + τ ~ τ' → + τ == τ' + consist-complete-eq TCBase TCBase ConsistBase = refl + consist-complete-eq TCVar TCVar ConsistVar = refl + consist-complete-eq (TCArr tc1 tc2) (TCArr tc3 tc4) (ConsistArr con con₁) rewrite consist-complete-eq tc1 tc3 con rewrite consist-complete-eq tc2 tc4 con₁ = refl + consist-complete-eq (TCForall tc1) (TCForall tc2) (ConsistForall con) rewrite consist-complete-eq tc1 tc2 con = refl + + compl-wt-complid : ∀{d Γ τ} → + d dcomplete → + Γ ⊢ d :: τ → + d dcompleteid + compl-wt-complid DCVar (TAVar x) = DCVar + compl-wt-complid DCConst TAConst = DCConst + compl-wt-complid (DCLam compl x) (TALam x₁ wt) = DCLam (compl-wt-complid compl wt) x + compl-wt-complid (DCTLam compl) (TATLam wt) = DCTLam (compl-wt-complid compl wt) + compl-wt-complid (DCAp compl compl₁) (TAAp wt wt₁) = DCAp (compl-wt-complid compl wt) (compl-wt-complid compl₁ wt₁) + compl-wt-complid (DCTAp x compl) (TATAp x₁ wt x₂) = DCTAp x (compl-wt-complid compl wt) + compl-wt-complid (DCCast compl x x₁) (TACast wt x₂ x₃) rewrite consist-complete-eq x x₁ x₃ = DCCast (compl-wt-complid compl wt) x₁ + + complid-compl : ∀{d} → + d dcompleteid → + d dcomplete + complid-compl DCVar = DCVar + complid-compl DCConst = DCConst + complid-compl (DCLam compl x) = DCLam (complid-compl compl) x + complid-compl (DCTLam compl) = DCTLam (complid-compl compl) + complid-compl (DCAp compl compl₁) = DCAp (complid-compl compl) (complid-compl compl₁) + complid-compl (DCTAp x compl) = DCTAp x (complid-compl compl) + complid-compl (DCCast compl x) = DCCast (complid-compl compl) x x + + dcompleteid-elab : ∀{e τ d} → + e ecomplete → + ∅ ⊢ e ⇒ τ ~> d → + d dcompleteid + dcompleteid-elab ec elab with complete-elaboration-synth GCEmpty ec elab | typed-elaboration-syn CtxWFEmpty elab + ... | (dc , tc) | wt = compl-wt-complid dc wt + + eq0-ctxin' : + ∀ {d1 d2 d1' ε1} → + d1 =0' d2 → + d1 == ε1 ⟦ d1' ⟧ → + Σ[ d2' ∈ ihexp ] Σ[ ε2 ∈ ectx ] ((d2 == ε2 ⟦ d2' ⟧) × (d1' =0' d2') × (ε1 =0ε' ε2)) + eq0-ctxin' eq FHOuter = _ , ⊙ , FHOuter , eq , Eq0Dot + eq0-ctxin' (Eq0NEHole eq) (FHNEHole ctxin) with eq0-ctxin' eq ctxin + ... | d2' , ε2 , eq1 , eq2 , eq3 = _ , _ , FHNEHole eq1 , eq2 , Eq0NEHole eq3 + eq0-ctxin' (Eq0Ap eq eq₁) (FHAp1 ctxin) with eq0-ctxin' eq ctxin + ... | d2' , ε2 , eq1 , eq2 , eq3 = _ , _ , FHAp1 eq1 , eq2 , Eq0Ap1 eq3 eq₁ + eq0-ctxin' (Eq0Ap eq eq₁) (FHAp2 ctxin) with eq0-ctxin' eq₁ ctxin + ... | d2' , ε2 , eq1 , eq2 , eq3 = _ , _ , FHAp2 eq1 , eq2 , Eq0Ap2 eq3 eq + eq0-ctxin' (Eq0TAp eq) (FHTAp ctxin) with eq0-ctxin' eq ctxin + ... | d2' , ε2 , eq1 , eq2 , eq3 = _ , _ , FHTAp eq1 , eq2 , Eq0TAp eq3 + eq0-ctxin' (Eq0Cast eq) (FHCast ctxin) with eq0-ctxin' eq ctxin + ... | d2' , ε2 , eq1 , eq2 , eq3 = _ , _ , FHCast eq1 , eq2 , Eq0Cast eq3 + eq0-ctxin' (Eq0FailedCast eq) (FHFailedCast ctxin) with eq0-ctxin' eq ctxin + ... | d2' , ε2 , eq1 , eq2 , eq3 = _ , _ , FHFailedCast eq1 , eq2 , Eq0FailedCast eq3 + + eq0-ctxout' : + ∀ {d1 d1' d2' ε1 ε2} → + d1' =0' d2' → + ε1 =0ε' ε2 → + d1 == ε1 ⟦ d1' ⟧ → + Σ[ d2 ∈ ihexp ] ((d2 == ε2 ⟦ d2' ⟧) × (d1 =0' d2)) + eq0-ctxout' eq1 Eq0Dot FHOuter = _ , FHOuter , eq1 + eq0-ctxout' eq1 (Eq0Ap1 eq2 x) (FHAp1 eq3) with eq0-ctxout' eq1 eq2 eq3 + ... | _ , eq4 , eq5 = _ , FHAp1 eq4 , Eq0Ap eq5 x + eq0-ctxout' eq1 (Eq0Ap2 eq2 x) (FHAp2 eq3) with eq0-ctxout' eq1 eq2 eq3 + ... | _ , eq4 , eq5 = _ , FHAp2 eq4 , Eq0Ap x eq5 + eq0-ctxout' eq1 (Eq0TAp eq2) (FHTAp eq3) with eq0-ctxout' eq1 eq2 eq3 + ... | _ , eq4 , eq5 = _ , FHTAp eq4 , Eq0TAp eq5 + eq0-ctxout' eq1 (Eq0NEHole eq2) (FHNEHole eq3) with eq0-ctxout' eq1 eq2 eq3 + ... | _ , eq4 , eq5 = _ , FHNEHole eq4 , Eq0NEHole eq5 + eq0-ctxout' eq1 (Eq0Cast eq2) (FHCast eq3) with eq0-ctxout' eq1 eq2 eq3 + ... | _ , eq4 , eq5 = _ , FHCast eq4 , Eq0Cast eq5 + eq0-ctxout' eq1 (Eq0FailedCast eq2) (FHFailedCast eq3) with eq0-ctxout' eq1 eq2 eq3 + ... | _ , eq4 , eq5 = _ , FHFailedCast eq4 , Eq0FailedCast eq5 + + eq0-instep' : + ∀ {d1 d2 d1' τ τ'} → + d1 =0' d2 → + d1 →> d1' → + d1 dcompleteid → + ∅ ⊢ d1 :: τ → + ∅ ⊢ d2 :: τ' → + Σ[ d2' ∈ ihexp ] ((d2 →> d2') × (d1' =0' d2')) + eq0-instep' {d1 = (·λ[ τ1 ] d1) ∘ d1'} {d2 = (·λ[ τ2 ] d2) ∘ d2'} (Eq0Ap (Eq0Lam eq0) eq1) ITLam compl wt1 wt2 = _ , ITLam , eq0-ttSub eq1 eq0 + eq0-instep' {d1 = (d1' ⟨ τ1 ==> τ3 ⇒ τ1' ==> τ3' ⟩) ∘ d5} {d2 = (d2' ⟨ τ2 ==> τ ⇒ τ2' ==> τ' ⟩) ∘ d4} + (Eq0Ap (Eq0Cast eq0) eq1) ITApCast compl wt1 (TAAp (TACast wt x₁ x₂) wt₁) = + ((d2' ∘ (d4 ⟨ τ2' ⇒ τ2 ⟩)) ⟨ τ ⇒ τ' ⟩) , ITApCast , Eq0Cast (Eq0Ap eq0 (Eq0Cast eq1)) + eq0-instep' {d1 = ·Λ d1 < _ >} {d2 = ·Λ d2 < τ2 >} (Eq0TAp (Eq0TLam eq0)) ITTLam (DCTAp x (DCTLam compl)) (TATAp x₁ (TATLam wt1) x₂) (TATAp x₃ (TATLam wt2) x₄) = _ , ITTLam , eq0-TtSub compl eq0 + eq0-instep' {d1 = (d1 ⟨ ·∀ τ ⇒ ·∀ τ' ⟩) < τ1 >} {d2 = (d2 ⟨ ·∀ τ2 ⇒ ·∀ τ2' ⟩) < τ3 >} + (Eq0TAp (Eq0Cast eq0)) ITTApCast compl (TATAp x₅ (TACast wt1 x₇ x₈) x₆) (TATAp x (TACast wt x₂ x₃) x₁) = _ , ITTApCast , Eq0Cast (Eq0TAp eq0) + eq0-instep' {d2 = d2 ⟨ τ2 ⇒ τ2' ⟩} (Eq0Cast eq0) ITCastID compl wt1 wt = d2 , ITCastID , eq0 + eq0-instep' (Eq0Cast x₂) (ITCastSucceed x₅) (DCCast x ()) wt1 x₁ + eq0-instep' (Eq0Cast x₂) (ITCastFail _ _ x₅) (DCCast x ()) wt1 x₁ + eq0-instep' (Eq0Cast x₂) (ITGround x₅) (DCCast x ()) wt1 x₁ + eq0-instep' (Eq0Cast x₂) (ITExpand x₅) (DCCast x ()) wt1 x₁ + + completeid-env : ∀{d d' ε} → + d' dcompleteid → + d' == ε ⟦ d ⟧ → + d dcompleteid + completeid-env dc FHOuter = dc + completeid-env (DCAp dc dc₁) (FHAp1 env) = completeid-env dc env + completeid-env (DCAp dc dc₁) (FHAp2 env) = completeid-env dc₁ env + completeid-env (DCTAp x dc) (FHTAp env) = completeid-env dc env + completeid-env (DCCast dc x) (FHCast env) = completeid-env dc env + + wt-env : ∀{d d' ε τ} → + ∅ ⊢ d :: τ → + d == ε ⟦ d' ⟧ → + Σ[ τ' ∈ htyp ] (∅ ⊢ d' :: τ') + wt-env {τ = τ} wt FHOuter = τ , wt + wt-env {τ = τ} (TAAp {τ1 = τ1} wt wt₁) (FHAp1 env₁) = wt-env wt env₁ + wt-env {τ = τ} (TAAp wt wt₁) (FHAp2 env₁) = wt-env wt₁ env₁ + wt-env {τ = τ} (TATAp x wt x₁) (FHTAp env₁) = wt-env wt env₁ + wt-env {τ = τ} (TANEHole wt) (FHNEHole env₁) = wt-env wt env₁ + wt-env {τ = τ} (TACast wt x x₁) (FHCast env₁) = wt-env wt env₁ + wt-env {τ = τ} (TAFailedCast wt x x₁ x₂) (FHFailedCast env₁) = wt-env wt env₁ + + eq0-step' : + ∀ {d1 d2 d1' τ τ'} → + d1 dcompleteid → + ∅ ⊢ d1 :: τ → + ∅ ⊢ d2 :: τ' → + d1 =0' d2 → + d1 ↦ d1' → + Σ[ d2' ∈ ihexp ] ((d2 ↦ d2') × (d1' =0' d2')) + eq0-step' compl wt1 wt2 eq (Step ctx1 step1 ctx2) + with eq0-ctxin' eq ctx1 + ... | ( d3 , ε' , ctx3 , eq2 , eq3 ) + with wt-env wt1 ctx1 | wt-env wt2 ctx3 + ... | (_ , wt1') | (_ , wt2') + with eq0-instep' eq2 step1 (completeid-env compl ctx1) wt1' wt2' + ... | ( d4 , step2 , eq4 ) + with eq0-ctxout' eq4 eq3 ctx2 + ... | d5 , eq5 , eq6 = d5 , Step ctx3 step2 eq5 , eq6 + + compl-complid-pres : ∀{d d' τ} → + d dcompleteid → + ∅ ⊢ d :: τ → + d ↦ d' → + d' dcompleteid + compl-complid-pres compl wt step = compl-wt-complid (complete-preservation (complid-compl compl) wt step) (preservation wt step) + + parametricity11_rec : + ∀ {τ τ' d1 d2 v1 } → + d1 dcompleteid → + d2 dcompleteid → + ∅ ⊢ d1 :: τ → + ∅ ⊢ d2 :: τ' → + d1 =0' d2 → + d1 ↦* v1 → + v1 boxedval → + Σ[ v2 ∈ ihexp ] ((d2 ↦* v2) × (v2 boxedval) × (v1 =0' v2)) + parametricity11_rec c1 c2 wt1 wt2 eq0 MSRefl bv = _ , MSRefl , eq0-boxedval' eq0 bv , eq0 + parametricity11_rec c1 c2 wt1 wt2 eq0 (MSStep x step) bv + with eq0-step' c1 wt1 wt2 eq0 x + ... | ( d2' , step2 , eq2 ) + with complete-preservation (complid-compl c1) wt1 x | complete-preservation (complid-compl c2) wt2 step2 | preservation wt1 x | preservation wt2 step2 + ... | c1' | c2' | wt1' | wt2' + with parametricity11_rec (compl-wt-complid c1' wt1') (compl-wt-complid c2' wt2') wt1' wt2' eq2 step bv + ... | ( v2 , steps2 , bv2 , eq3 ) = v2 , MSStep step2 steps2 , bv2 , eq3 + + parametricity11 : + ∀ {e e' τ τ' d1 d2 v1 } → + e ecomplete → + e' ecomplete → + e =0e e' → + ∅ ⊢ e ⇒ τ ~> d1 → + ∅ ⊢ e' ⇒ τ' ~> d2 → + d1 ↦* v1 → + v1 boxedval → + Σ[ v2 ∈ ihexp ] ((d2 ↦* v2) × (v2 boxedval) × (v1 =0 v2)) + parametricity11 ec ec' eeq elab1 elab2 eval bv = + let d1c = (dcompleteid-elab ec elab1) in + let d2c = (dcompleteid-elab ec' elab2) in + let (v2 , v2eval , v2bv , eq0') = parametricity11_rec d1c d2c (typed-elaboration-syn CtxWFEmpty elab1) (typed-elaboration-syn CtxWFEmpty elab2) (eq0-eq0' d1c d2c (eq0-elab-syn eeq elab1 elab2)) eval bv in + (v2 , v2eval , v2bv , eq0'-eq0 eq0') diff --git a/parametricity2-defs.agda b/parametricity2-defs.agda new file mode 100644 index 0000000..59e46ce --- /dev/null +++ b/parametricity2-defs.agda @@ -0,0 +1,573 @@ +{-# OPTIONS --allow-unsolved-metas #-} + +open import Nat +open import Prelude +open import core +open import core-type +open import core-exp +open import core-subst + +open import preservation +open import ground-dec +open import lemmas-consistency +open import lemmas-wf +open import eq-dec +open import lemmas-ground +open import finality + +module parametricity2-defs where + + mutual + data _=0c_ : (d1 d2 : ihexp) → Set where + Eq0CastL : ∀{d1 d2 τ1 τ2} → d1 =0c d2 → (d1 ⟨ τ1 ⇒ τ2 ⟩) =0c d2 + Eq0FailedCastL : ∀{d1 d2 τ1 τ2} → d1 =0c d2 → (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) =0c d2 + Eq0NoLeft : ∀{d1 d2} → d1 =0cr d2 → d1 =0c d2 + + data _=0cr_ : (d1 d2 : ihexp) → Set where + Eq0CastR : ∀{d1 d2 τ1 τ2} → d1 =0cr d2 → d1 =0cr (d2 ⟨ τ1 ⇒ τ2 ⟩) + Eq0FailedCastR : ∀{d1 d2 τ1 τ2} → d1 =0cr d2 → d1 =0cr (d2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + Eq0NoCasts : ∀{d1 d2} → d1 =0cn d2 → d1 =0cr d2 + + data _=0cn_ : (d1 d2 : ihexp) → Set where + Eq0Const : c =0cn c + Eq0Var : ∀{x} → (X x) =0cn (X x) + Eq0EHole : ⦇-⦈ =0cn ⦇-⦈ + Eq0Lam : ∀{d1 d2 τ1 τ2} → d1 =0c d2 → (·λ[ τ1 ] d1) =0cn (·λ[ τ2 ] d2) + Eq0TLam : ∀{d1 d2} → d1 =0c d2 → (·Λ d1) =0cn (·Λ d2) + Eq0NEHole : ∀{d1 d2} → d1 =0c d2 → ⦇⌜ d1 ⌟⦈ =0cn ⦇⌜ d2 ⌟⦈ + Eq0Ap : ∀{d1 d2 d3 d4} → d1 =0c d3 → d2 =0c d4 → (d1 ∘ d2) =0cn (d3 ∘ d4) + Eq0TAp : ∀{d1 d2 τ1 τ2} → d1 =0c d2 → (d1 < τ1 >) =0cn (d2 < τ2 >) + + data _=0εc_ : (ε1 ε2 : ectx) → Set where + Eq0Dot : ⊙ =0εc ⊙ + Eq0Ap1 : ∀{ε1 ε2 d1 d2} → (ε1 =0εc ε2) → (d1 =0c d2) → (ε1 ∘₁ d1) =0εc (ε2 ∘₁ d2) + Eq0Ap2 : ∀{ε1 ε2 d1 d2} → (ε1 =0εc ε2) → (d1 =0c d2) → (d1 ∘₂ ε1) =0εc (d2 ∘₂ ε2) + Eq0TAp : ∀{ε1 ε2 τ1 τ2} → (ε1 =0εc ε2) → (ε1 < τ1 >) =0εc (ε2 < τ2 >) + Eq0NEHole : ∀{ε1 ε2} → (ε1 =0εc ε2) → ⦇⌜ ε1 ⌟⦈ =0εc ⦇⌜ ε2 ⌟⦈ + Eq0CastL : ∀{ε1 ε2 τ1 τ2} → (ε1 =0εc ε2) → (ε1 ⟨ τ1 ⇒ τ2 ⟩) =0εc ε2 + Eq0CastR : ∀{ε1 ε2 τ1 τ2} → (ε1 =0εc ε2) → ε1 =0εc (ε2 ⟨ τ1 ⇒ τ2 ⟩) + Eq0FailedCastL : ∀{ε1 ε2 τ1 τ2} → (ε1 =0εc ε2) → (ε1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) =0εc ε2 + Eq0FailedCastR : ∀{ε1 ε2 τ1 τ2} → (ε1 =0εc ε2) → ε1 =0εc (ε2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + + eq0cr-lemma : ∀{d d' τ τ'} → + d =0c d' → d =0c (d' ⟨ τ ⇒ τ' ⟩) + eq0cr-lemma (Eq0CastL eq0) = Eq0CastL (eq0cr-lemma eq0) + eq0cr-lemma (Eq0FailedCastL eq0) = Eq0FailedCastL (eq0cr-lemma eq0) + eq0cr-lemma (Eq0NoLeft x) = Eq0NoLeft (Eq0CastR x) + + eq0cr-lemma0-rev : ∀{d d' τ τ'} → + d =0c (d' ⟨ τ ⇒ τ' ⟩) → d =0c d' + eq0cr-lemma0-rev (Eq0CastL eq0) = Eq0CastL (eq0cr-lemma0-rev eq0) + eq0cr-lemma0-rev (Eq0FailedCastL eq0) = Eq0FailedCastL (eq0cr-lemma0-rev eq0) + eq0cr-lemma0-rev (Eq0NoLeft (Eq0CastR x)) = Eq0NoLeft x + + eq0cr-lemma0-rev' : ∀{d d' τ τ'} → + d =0c (d' ⟨ τ ⇒⦇-⦈⇏ τ' ⟩) → d =0c d' + eq0cr-lemma0-rev' (Eq0CastL eq0) = Eq0CastL (eq0cr-lemma0-rev' eq0) + eq0cr-lemma0-rev' (Eq0FailedCastL eq0) = Eq0FailedCastL (eq0cr-lemma0-rev' eq0) + eq0cr-lemma0-rev' (Eq0NoLeft (Eq0FailedCastR x)) = Eq0NoLeft x + + eq0cr-lemma' : ∀{d d' τ τ'} → + d =0c d' → d =0c (d' ⟨ τ ⇒⦇-⦈⇏ τ' ⟩) + eq0cr-lemma' (Eq0CastL eq0) = Eq0CastL (eq0cr-lemma' eq0) + eq0cr-lemma' (Eq0FailedCastL eq0) = Eq0FailedCastL (eq0cr-lemma' eq0) + eq0cr-lemma' (Eq0NoLeft x) = Eq0NoLeft (Eq0FailedCastR x) + + eq0c-refl : ∀{d : ihexp} → d =0c d + eq0c-refl {c} = Eq0NoLeft (Eq0NoCasts Eq0Const) + eq0c-refl {X x} = Eq0NoLeft (Eq0NoCasts Eq0Var) + eq0c-refl {·λ[ x ] d} = Eq0NoLeft (Eq0NoCasts (Eq0Lam eq0c-refl)) + eq0c-refl {·Λ d} = Eq0NoLeft (Eq0NoCasts (Eq0TLam eq0c-refl)) + eq0c-refl {⦇-⦈} = Eq0NoLeft (Eq0NoCasts Eq0EHole) + eq0c-refl {⦇⌜ d ⌟⦈} = Eq0NoLeft (Eq0NoCasts (Eq0NEHole eq0c-refl)) + eq0c-refl {d ∘ d₁} = Eq0NoLeft (Eq0NoCasts (Eq0Ap eq0c-refl eq0c-refl)) + eq0c-refl {d < x >} = Eq0NoLeft (Eq0NoCasts (Eq0TAp eq0c-refl)) + eq0c-refl {d ⟨ x ⇒ x₁ ⟩} = Eq0CastL (eq0cr-lemma eq0c-refl) + eq0c-refl {d ⟨ x ⇒⦇-⦈⇏ x₁ ⟩} = Eq0FailedCastL (eq0cr-lemma' eq0c-refl) + + eq0ccastr-meaning : ∀{d d' d₀ τ τ'} → + d =0cr d' → + d ≠ (d₀ ⟨ τ ⇒ τ' ⟩) × d ≠ (d₀ ⟨ τ ⇒⦇-⦈⇏ τ' ⟩) + eq0ccastr-meaning (Eq0CastR eq0) = eq0ccastr-meaning eq0 + eq0ccastr-meaning (Eq0FailedCastR eq0) = eq0ccastr-meaning eq0 + eq0ccastr-meaning (Eq0NoCasts Eq0Const) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts Eq0Var) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts Eq0EHole) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts (Eq0Lam x)) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts (Eq0TLam x)) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts (Eq0NEHole x)) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts (Eq0Ap x x₁)) = (λ ()) , (λ ()) + eq0ccastr-meaning (Eq0NoCasts (Eq0TAp x)) = (λ ()) , (λ ()) + + mutual + eq0cn-sym : ∀{d d'} → + d =0cn d' → + d' =0cn d + eq0cn-sym Eq0Const = Eq0Const + eq0cn-sym Eq0Var = Eq0Var + eq0cn-sym Eq0EHole = Eq0EHole + eq0cn-sym (Eq0Lam x) = Eq0Lam (eq0c-sym x) + eq0cn-sym (Eq0TLam x) = Eq0TLam (eq0c-sym x) + eq0cn-sym (Eq0NEHole x) = Eq0NEHole (eq0c-sym x) + eq0cn-sym (Eq0Ap x x₁) = Eq0Ap (eq0c-sym x) (eq0c-sym x₁) + eq0cn-sym (Eq0TAp x) = Eq0TAp (eq0c-sym x) + + eq0cr-sym : ∀{d d'} → + d =0cr d' → + d' =0c d + eq0cr-sym (Eq0NoCasts x) = Eq0NoLeft (Eq0NoCasts (eq0cn-sym x)) + eq0cr-sym (Eq0CastR eq0) = Eq0CastL (eq0cr-sym eq0) + eq0cr-sym (Eq0FailedCastR eq0) = Eq0FailedCastL (eq0cr-sym eq0) + + eq0c-sym : ∀{d d'} → + d =0c d' → + d' =0c d + eq0c-sym (Eq0CastL eq0) = eq0cr-lemma (eq0c-sym eq0) + eq0c-sym (Eq0FailedCastL eq0) = eq0cr-lemma' (eq0c-sym eq0) + eq0c-sym (Eq0NoLeft x) = eq0cr-sym x + + mutual + eq0cn-trans : ∀{d d' d''} → + d =0cn d' → + d' =0cn d'' → + d =0cn d'' + eq0cn-trans Eq0Const Eq0Const = Eq0Const + eq0cn-trans Eq0Var Eq0Var = Eq0Var + eq0cn-trans Eq0EHole Eq0EHole = Eq0EHole + eq0cn-trans (Eq0Lam x) (Eq0Lam x₁) = Eq0Lam (eq0c-trans x x₁) + eq0cn-trans (Eq0TLam x) (Eq0TLam x₁) = Eq0TLam (eq0c-trans x x₁) + eq0cn-trans (Eq0NEHole x) (Eq0NEHole x₁) = Eq0NEHole (eq0c-trans x x₁) + eq0cn-trans (Eq0Ap x x₁) (Eq0Ap x₂ x₃) = Eq0Ap (eq0c-trans x x₂) (eq0c-trans x₁ x₃) + eq0cn-trans (Eq0TAp x) (Eq0TAp x₁) = Eq0TAp (eq0c-trans x x₁) + + eq0cr-trans : ∀{d d' d''} → + d =0cr d' → + d' =0c d'' → + d =0c d'' + eq0cr-trans (Eq0CastR eq0) (Eq0CastL eq0') = eq0cr-trans eq0 eq0' + eq0cr-trans (Eq0CastR eq0) (Eq0NoLeft x) = abort (π1 (eq0ccastr-meaning x) refl) + eq0cr-trans (Eq0FailedCastR eq0) (Eq0FailedCastL eq0') = eq0cr-trans eq0 eq0' + eq0cr-trans (Eq0FailedCastR eq0) (Eq0NoLeft x) = abort (π2 (eq0ccastr-meaning x) refl) + eq0cr-trans (Eq0NoCasts x) (Eq0NoLeft (Eq0CastR x₁)) = eq0cr-lemma (Eq0NoLeft (eq0cnrr-trans x x₁)) + eq0cr-trans (Eq0NoCasts x) (Eq0NoLeft (Eq0FailedCastR x₁)) = eq0cr-lemma' (Eq0NoLeft (eq0cnrr-trans x x₁)) + eq0cr-trans (Eq0NoCasts x) (Eq0NoLeft (Eq0NoCasts x₁)) = Eq0NoLeft (Eq0NoCasts (eq0cn-trans x x₁)) + + eq0c-trans : ∀{d d' d''} → + d =0c d' → + d' =0c d'' → + d =0c d'' + eq0c-trans (Eq0CastL eq0) eq0' = Eq0CastL (eq0c-trans eq0 eq0') + eq0c-trans (Eq0FailedCastL eq0) eq0' = Eq0FailedCastL (eq0c-trans eq0 eq0') + eq0c-trans (Eq0NoLeft x) eq0' = eq0cr-trans x eq0' + + eq0cnr-trans : ∀{d d' d''} → + d =0cn d' → + d' =0c d'' → + d =0cr d'' + eq0cnr-trans eqn (Eq0NoLeft x) = eq0cnrr-trans eqn x + + eq0cnrr-trans : ∀{d d' d''} → + d =0cn d' → + d' =0cr d'' → + d =0cr d'' + eq0cnrr-trans eqn (Eq0CastR eqr) = Eq0CastR (eq0cnrr-trans eqn eqr) + eq0cnrr-trans eqn (Eq0FailedCastR eqr) = Eq0FailedCastR (eq0cnrr-trans eqn eqr) + eq0cnrr-trans eqn (Eq0NoCasts x) = Eq0NoCasts (eq0cn-trans eqn x) + + eq0ε''-sym : ∀{e e' : ectx} → e =0εc e' → e' =0εc e + eq0ε''-sym Eq0Dot = Eq0Dot + eq0ε''-sym (Eq0Ap1 eqe x) = Eq0Ap1 (eq0ε''-sym eqe) (eq0c-sym x) + eq0ε''-sym (Eq0Ap2 eqe x) = Eq0Ap2 (eq0ε''-sym eqe) (eq0c-sym x) + eq0ε''-sym (Eq0TAp eqe) = Eq0TAp (eq0ε''-sym eqe) + eq0ε''-sym (Eq0NEHole eqe) = Eq0NEHole (eq0ε''-sym eqe) + eq0ε''-sym (Eq0CastL eqe) = Eq0CastR (eq0ε''-sym eqe) + eq0ε''-sym (Eq0CastR eqe) = Eq0CastL (eq0ε''-sym eqe) + eq0ε''-sym (Eq0FailedCastL eqe) = Eq0FailedCastR (eq0ε''-sym eqe) + eq0ε''-sym (Eq0FailedCastR eqe) = Eq0FailedCastL (eq0ε''-sym eqe) + + eq0-ctxinc : + ∀ {d1 d2 d1' ε1} → + d1 =0c d2 → + d1 == ε1 ⟦ d1' ⟧ → + Σ[ d2' ∈ ihexp ] Σ[ ε2 ∈ ectx ] ((d2 == ε2 ⟦ d2' ⟧) × (d1' =0c d2') × (ε1 =0εc ε2) × ((d2'' : ihexp) → (τ1 τ2 : htyp) → d2' ≠ (d2'' ⟨ τ1 ⇒ τ2 ⟩) × d2' ≠ (d2'' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩))) + eq0-ctxinc {d2 = c} eq0 FHOuter = c , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc {d2 = X x} eq0 FHOuter = X x , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc {d2 = ·λ[ x ] d2} eq0 FHOuter = ·λ[ x ] d2 , ⊙ , FHOuter , eq0 , Eq0Dot , (λ x x₁ x₂ → (λ ()) , (λ ())) + eq0-ctxinc {d2 = ·Λ d2} eq0 FHOuter = _ , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc {d2 = ⦇-⦈} eq0 FHOuter = _ , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc {d2 = ⦇⌜ d2 ⌟⦈} eq0 FHOuter = _ , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc {d2 = d2 ∘ d3} eq0 FHOuter = _ , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc {d2 = d2 < x >} eq0 FHOuter = _ , ⊙ , FHOuter , eq0 , Eq0Dot , λ d2'' τ1 τ2 → (λ ()) , (λ ()) + eq0-ctxinc (Eq0NoLeft (Eq0NoCasts (Eq0Ap x x₁))) (FHAp1 eqe) with eq0-ctxinc x eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , (ε2 ∘₁ _) , FHAp1 eqe' , eq0' , Eq0Ap1 eqec x₁ , form + eq0-ctxinc (Eq0NoLeft (Eq0NoCasts (Eq0Ap x x₁))) (FHAp2 eqe) with eq0-ctxinc x₁ eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , (_ ∘₂ ε2) , FHAp2 eqe' , eq0' , Eq0Ap2 eqec x , form + eq0-ctxinc (Eq0NoLeft (Eq0NoCasts (Eq0TAp x))) (FHTAp eqe) with eq0-ctxinc x eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = _ , _ , FHTAp eqe' , eq0' , Eq0TAp eqec , form + eq0-ctxinc (Eq0NoLeft (Eq0NoCasts (Eq0NEHole x))) (FHNEHole eqe) with eq0-ctxinc x eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = _ , _ , FHNEHole eqe' , eq0' , Eq0NEHole eqec , form + eq0-ctxinc (Eq0NoLeft (Eq0NoCasts ())) (FHCast eqe) + eq0-ctxinc (Eq0NoLeft (Eq0NoCasts ())) (FHFailedCast eqe) + eq0-ctxinc {d2 = d2 ⟨ x ⇒ x₁ ⟩} eq0 FHOuter with eq0-ctxinc {d2 = d2} (eq0cr-lemma0-rev eq0) FHOuter + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , (ε2 ⟨ x ⇒ x₁ ⟩) , FHCast eqe' , eq0' , Eq0CastR eqec , form + eq0-ctxinc {d2 = d2 ⟨ x ⇒⦇-⦈⇏ x₁ ⟩} eq0 FHOuter with eq0-ctxinc {d2 = d2} (eq0cr-lemma0-rev' eq0) FHOuter + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , (ε2 ⟨ x ⇒⦇-⦈⇏ x₁ ⟩) , FHFailedCast eqe' , eq0' , Eq0FailedCastR eqec , form + eq0-ctxinc (Eq0CastL eq0) (FHCast eqe) with eq0-ctxinc eq0 eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , ε2 , eqe' , eq0' , Eq0CastL eqec , form + eq0-ctxinc (Eq0FailedCastL eq0) (FHFailedCast eqe) with eq0-ctxinc eq0 eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , ε2 , eqe' , eq0' , Eq0FailedCastL eqec , form + eq0-ctxinc {d2 = d2 ⟨ τ ⇒ τ' ⟩} (Eq0NoLeft (Eq0CastR x)) eqe with eq0-ctxinc (Eq0NoLeft x) eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , (ε2 ⟨ τ ⇒ τ' ⟩) , FHCast eqe' , eq0' , Eq0CastR eqec , form + eq0-ctxinc {d2 = d2 ⟨ τ ⇒⦇-⦈⇏ τ' ⟩} (Eq0NoLeft (Eq0FailedCastR x)) eqe with eq0-ctxinc (Eq0NoLeft x) eqe + ... | d2' , ε2 , eqe' , eq0' , eqec , form = d2' , (ε2 ⟨ τ ⇒⦇-⦈⇏ τ' ⟩) , FHFailedCast eqe' , eq0' , Eq0FailedCastR eqec , form + + eq0c-ctxout : + ∀ {d1 d1' d2' ε1 ε2} → + d1' =0c d2' → + ε1 =0εc ε2 → + d1 == ε1 ⟦ d1' ⟧ → + Σ[ d2 ∈ ihexp ] ((d2 == ε2 ⟦ d2' ⟧) × (d1 =0c d2)) + eq0c-ctxout eq0 Eq0Dot FHOuter = _ , FHOuter , eq0 + eq0c-ctxout eq0 (Eq0Ap1 eqec x) (FHAp1 eqe) with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = _ , FHAp1 eqe' , Eq0NoLeft (Eq0NoCasts (Eq0Ap eq0' x)) + eq0c-ctxout eq0 (Eq0Ap2 eqec x) (FHAp2 eqe) with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = _ , FHAp2 eqe' , Eq0NoLeft (Eq0NoCasts (Eq0Ap x eq0')) + eq0c-ctxout eq0 (Eq0TAp eqec) (FHTAp eqe) with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = _ , FHTAp eqe' , Eq0NoLeft (Eq0NoCasts (Eq0TAp eq0')) + eq0c-ctxout eq0 (Eq0NEHole eqec) (FHNEHole eqe) with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = _ , FHNEHole eqe' , Eq0NoLeft (Eq0NoCasts (Eq0NEHole eq0')) + eq0c-ctxout eq0 (Eq0CastL eqec) (FHCast eqe) with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = d2 , eqe' , Eq0CastL eq0' + eq0c-ctxout eq0 (Eq0FailedCastL eqec) (FHFailedCast eqe) with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = d2 , eqe' , Eq0FailedCastL eq0' + eq0c-ctxout eq0 (Eq0CastR eqec) eqe with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = _ , FHCast eqe' , eq0cr-lemma eq0' + eq0c-ctxout eq0 (Eq0FailedCastR eqec) eqe with eq0c-ctxout eq0 eqec eqe + ... | d2 , eqe' , eq0' = _ , FHFailedCast eqe' , eq0cr-lemma' eq0' + + mutual + eq0cn-ctx : ∀{d0 d0' d1 d1' d2 d2' ε1 ε2} → + d1 == ε1 ⟦ d0 ⟧ → + d1' == ε1 ⟦ d0' ⟧ → + d0 =0c d0' → + d1 =0cn d2 → + d1' =0c d2 + eq0cn-ctx FHOuter FHOuter eqin eq0 = eq0c-trans (eq0c-sym eqin) (Eq0NoLeft (Eq0NoCasts eq0)) + eq0cn-ctx (FHAp1 ctx1) (FHAp1 ctx1') eqin (Eq0Ap x x₁) = + Eq0NoLeft (Eq0NoCasts (Eq0Ap + (eq0c-ctx ctx1 ctx1' eqin x) x₁)) + eq0cn-ctx (FHAp2 ctx1) (FHAp2 ctx1') eqin (Eq0Ap x x₁) = Eq0NoLeft (Eq0NoCasts (Eq0Ap x (eq0c-ctx ctx1 ctx1' eqin x₁))) + eq0cn-ctx (FHTAp ctx1) (FHTAp ctx1') eqin (Eq0TAp x) = Eq0NoLeft (Eq0NoCasts (Eq0TAp (eq0c-ctx ctx1 ctx1' eqin x))) + eq0cn-ctx (FHNEHole ctx1) (FHNEHole ctx1') eqin (Eq0NEHole x) = Eq0NoLeft (Eq0NoCasts (Eq0NEHole (eq0c-ctx ctx1 ctx1' eqin x))) + +{- + eq0cr-ctx : ∀{d0 d0' d1 d1' d2 d2' ε1 ε2} → + d1 == ε1 ⟦ d0 ⟧ → + d1' == ε1 ⟦ d0' ⟧ → + d2 == ε2 ⟦ d2' ⟧ → + ε1 =0εc ε2 → + d0 =0c d0' → + d1 =0cr d2 → + d1' =0c d2 + eq0cr-ctx ctx1 ctx1' ctx2 eqe eqin eq0 = {! !} +-} + + eq0c-ctx : ∀{d0 d0' d1 d1' d2 ε1} → + d1 == ε1 ⟦ d0 ⟧ → + d1' == ε1 ⟦ d0' ⟧ → + d0 =0c d0' → + d1 =0c d2 → + d1' =0c d2 + eq0c-ctx FHOuter FHOuter eq0 eq0' = eq0c-trans (eq0c-sym eq0) eq0' + eq0c-ctx ctx1 ctx1' eq0 (Eq0NoLeft (Eq0CastR x)) = eq0cr-lemma (eq0c-ctx ctx1 ctx1' eq0 (Eq0NoLeft x)) + eq0c-ctx ctx1 ctx1' eq0 (Eq0NoLeft (Eq0FailedCastR x)) = eq0cr-lemma' (eq0c-ctx ctx1 ctx1' eq0 (Eq0NoLeft x)) + eq0c-ctx (FHAp1 ctx1) (FHAp1 ctx1') eq0 (Eq0NoLeft (Eq0NoCasts (Eq0Ap x x₁))) = Eq0NoLeft (Eq0NoCasts (Eq0Ap (eq0c-ctx ctx1 ctx1' eq0 x) x₁)) + eq0c-ctx (FHAp2 ctx1) (FHAp2 ctx1') eq0 (Eq0NoLeft (Eq0NoCasts (Eq0Ap x x₁))) = Eq0NoLeft (Eq0NoCasts (Eq0Ap x (eq0c-ctx ctx1 ctx1' eq0 x₁))) + eq0c-ctx (FHTAp ctx1) (FHTAp ctx1') eq0 (Eq0NoLeft (Eq0NoCasts (Eq0TAp x))) = Eq0NoLeft (Eq0NoCasts (Eq0TAp (eq0c-ctx ctx1 ctx1' eq0 x))) + eq0c-ctx (FHNEHole ctx1) (FHNEHole ctx1') eq0 (Eq0NoLeft (Eq0NoCasts (Eq0NEHole x))) = Eq0NoLeft (Eq0NoCasts (Eq0NEHole (eq0c-ctx ctx1 ctx1' eq0 x))) + eq0c-ctx (FHCast ctx1) (FHCast ctx1') eq0 (Eq0CastL eq0') = Eq0CastL (eq0c-ctx ctx1 ctx1' eq0 eq0') + eq0c-ctx (FHCast ctx1) (FHCast ctx1') eq0 (Eq0NoLeft x) = abort (π1 (eq0ccastr-meaning x) refl) + eq0c-ctx (FHFailedCast ctx1) (FHFailedCast ctx1') eq0 (Eq0FailedCastL eq0') = Eq0FailedCastL (eq0c-ctx ctx1 ctx1' eq0 eq0') + eq0c-ctx (FHFailedCast ctx1) (FHFailedCast ctx1') eq0 (Eq0NoLeft x) = abort (π2 (eq0ccastr-meaning x) refl) + + cast-steps-preserve-=0c : ∀{d1 d1' d2 τ1 τ2} → + (d1 ⟨ τ1 ⇒ τ2 ⟩) →> d1' → + d1 =0c d2 → + d1' =0c d2 + cast-steps-preserve-=0c ITCastID eq0 = eq0 + cast-steps-preserve-=0c (ITCastSucceed x) (Eq0CastL eq0) = eq0 + cast-steps-preserve-=0c (ITCastSucceed x) (Eq0NoLeft x₃) = abort (π1 (eq0ccastr-meaning x₃) refl) + cast-steps-preserve-=0c (ITCastFail x x₁ x₂) (Eq0CastL eq0) = Eq0FailedCastL eq0 + cast-steps-preserve-=0c (ITCastFail x x₁ x₂) (Eq0NoLeft x₃) = abort (π1 (eq0ccastr-meaning x₃) refl) + cast-steps-preserve-=0c (ITGround x) eq0 = Eq0CastL (Eq0CastL eq0) + cast-steps-preserve-=0c (ITExpand x) eq0 = Eq0CastL (Eq0CastL eq0) + + add-cast-r : (d1 d2 : ihexp) → (τ1 τ2 : htyp) → d1 =0c d2 → d1 =0c (d2 ⟨ τ1 ⇒ τ2 ⟩) + add-cast-r .(_ ⟨ _ ⇒ _ ⟩) d2 τ1 τ2 (Eq0CastL eq0) = Eq0CastL (add-cast-r _ d2 τ1 τ2 eq0) + add-cast-r .(_ ⟨ _ ⇒⦇-⦈⇏ _ ⟩) d2 τ1 τ2 (Eq0FailedCastL eq0) = Eq0FailedCastL (add-cast-r _ d2 τ1 τ2 eq0) + add-cast-r d1 d2 τ1 τ2 (Eq0NoLeft x) = Eq0NoLeft (Eq0CastR x) + + add-failed-cast-r : (d1 d2 : ihexp) → (τ1 τ2 : htyp) → d1 =0c d2 → d1 =0c (d2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + add-failed-cast-r .(_ ⟨ _ ⇒ _ ⟩) d2 τ1 τ2 (Eq0CastL eq0) = Eq0CastL (add-failed-cast-r _ d2 τ1 τ2 eq0) + add-failed-cast-r .(_ ⟨ _ ⇒⦇-⦈⇏ _ ⟩) d2 τ1 τ2 (Eq0FailedCastL eq0) = Eq0FailedCastL (add-failed-cast-r _ d2 τ1 τ2 eq0) + add-failed-cast-r d1 d2 τ1 τ2 (Eq0NoLeft x) = Eq0NoLeft (Eq0FailedCastR x) + + data _=0c'_ : (d1 d2 : ihexp) → Set where + Eq0CastL : ∀{d1 d2 τ1 τ2} → d1 =0c' d2 → (d1 ⟨ τ1 ⇒ τ2 ⟩) =0c' d2 + Eq0FailedCastL : ∀{d1 d2 τ1 τ2} → d1 =0c' d2 → (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) =0c' d2 + Eq0CastR : ∀{d1 d2 τ1 τ2} → d1 =0c' d2 → d1 =0c' (d2 ⟨ τ1 ⇒ τ2 ⟩) + Eq0FailedCastR : ∀{d1 d2 τ1 τ2} → d1 =0c' d2 → d1 =0c' (d2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) + Eq0Const : c =0c' c + Eq0Var : ∀{x} → (X x) =0c' (X x) + Eq0EHole : ⦇-⦈ =0c' ⦇-⦈ + Eq0Lam : ∀{d1 d2 τ1 τ2} → d1 =0c' d2 → (·λ[ τ1 ] d1) =0c' (·λ[ τ2 ] d2) + Eq0TLam : ∀{d1 d2} → d1 =0c' d2 → (·Λ d1) =0c' (·Λ d2) + Eq0NEHole : ∀{d1 d2} → d1 =0c' d2 → ⦇⌜ d1 ⌟⦈ =0c' ⦇⌜ d2 ⌟⦈ + Eq0Ap : ∀{d1 d2 d3 d4} → d1 =0c' d3 → d2 =0c' d4 → (d1 ∘ d2) =0c' (d3 ∘ d4) + Eq0TAp : ∀{d1 d2 τ1 τ2} → d1 =0c' d2 → (d1 < τ1 >) =0c' (d2 < τ2 >) + + =0c-equiv : {d1 d2 : ihexp} → d1 =0c d2 → d1 =0c' d2 + =0c-equiv (Eq0CastL eq0) = Eq0CastL (=0c-equiv eq0) + =0c-equiv (Eq0FailedCastL eq0) = Eq0FailedCastL (=0c-equiv eq0) + =0c-equiv (Eq0NoLeft (Eq0CastR x)) = Eq0CastR (=0c-equiv (Eq0NoLeft x)) + =0c-equiv (Eq0NoLeft (Eq0FailedCastR x)) = Eq0FailedCastR (=0c-equiv (Eq0NoLeft x)) + =0c-equiv (Eq0NoLeft (Eq0NoCasts Eq0Const)) = Eq0Const + =0c-equiv (Eq0NoLeft (Eq0NoCasts Eq0Var)) = Eq0Var + =0c-equiv (Eq0NoLeft (Eq0NoCasts Eq0EHole)) = Eq0EHole + =0c-equiv (Eq0NoLeft (Eq0NoCasts (Eq0Lam x))) = Eq0Lam (=0c-equiv x) + =0c-equiv (Eq0NoLeft (Eq0NoCasts (Eq0TLam x))) = Eq0TLam (=0c-equiv x) + =0c-equiv (Eq0NoLeft (Eq0NoCasts (Eq0NEHole x))) = Eq0NEHole (=0c-equiv x) + =0c-equiv (Eq0NoLeft (Eq0NoCasts (Eq0Ap x x₁))) = Eq0Ap (=0c-equiv x) (=0c-equiv x₁) + =0c-equiv (Eq0NoLeft (Eq0NoCasts (Eq0TAp x))) = Eq0TAp (=0c-equiv x) + + =0c'-equiv : {d1 d2 : ihexp} → d1 =0c' d2 → d1 =0c d2 + =0c'-equiv (Eq0CastL eq0) = Eq0CastL (=0c'-equiv eq0) + =0c'-equiv (Eq0FailedCastL eq0) = Eq0FailedCastL (=0c'-equiv eq0) + =0c'-equiv (Eq0CastR eq0) = add-cast-r _ _ _ _ (=0c'-equiv eq0) + =0c'-equiv (Eq0FailedCastR eq0) = add-failed-cast-r _ _ _ _ (=0c'-equiv eq0) + =0c'-equiv Eq0Const = Eq0NoLeft (Eq0NoCasts Eq0Const) + =0c'-equiv Eq0Var = Eq0NoLeft (Eq0NoCasts Eq0Var) + =0c'-equiv Eq0EHole = Eq0NoLeft (Eq0NoCasts Eq0EHole) + =0c'-equiv (Eq0Lam eq0) = Eq0NoLeft (Eq0NoCasts (Eq0Lam (=0c'-equiv eq0))) + =0c'-equiv (Eq0TLam eq0) = Eq0NoLeft (Eq0NoCasts (Eq0TLam (=0c'-equiv eq0))) + =0c'-equiv (Eq0NEHole eq0) = Eq0NoLeft (Eq0NoCasts (Eq0NEHole (=0c'-equiv eq0))) + =0c'-equiv (Eq0Ap eq0 eq1) = Eq0NoLeft (Eq0NoCasts (Eq0Ap (=0c'-equiv eq0) (=0c'-equiv eq1))) + =0c'-equiv (Eq0TAp eq0) = Eq0NoLeft (Eq0NoCasts (Eq0TAp (=0c'-equiv eq0))) + + eq0c'-shift : + ∀ {d1 d2 a n b m} → + d1 =0c' d2 → + ↑d a n b m d1 =0c' ↑d a n b m d2 + eq0c'-shift (Eq0CastL eq0) = Eq0CastL (eq0c'-shift eq0) + eq0c'-shift (Eq0FailedCastL eq0) = Eq0FailedCastL (eq0c'-shift eq0) + eq0c'-shift (Eq0CastR eq0) = Eq0CastR (eq0c'-shift eq0) + eq0c'-shift (Eq0FailedCastR eq0) = Eq0FailedCastR (eq0c'-shift eq0) + eq0c'-shift Eq0Const = Eq0Const + eq0c'-shift Eq0Var = Eq0Var + eq0c'-shift Eq0EHole = Eq0EHole + eq0c'-shift (Eq0Lam eq0) = Eq0Lam (eq0c'-shift eq0) + eq0c'-shift (Eq0TLam eq0) = Eq0TLam (eq0c'-shift eq0) + eq0c'-shift (Eq0NEHole eq0) = Eq0NEHole (eq0c'-shift eq0) + eq0c'-shift (Eq0Ap eq0 eq1) = Eq0Ap (eq0c'-shift eq0) (eq0c'-shift eq1) + eq0c'-shift (Eq0TAp eq0) = Eq0TAp (eq0c'-shift eq0) + + eq0c'-ttSub : + ∀ {d1 d2 d3 d4 n m} → + d1 =0c' d2 → + d3 =0c' d4 → + (ttSub n m d1 d3) =0c' (ttSub n m d2 d4) + eq0c'-ttSub eq0 (Eq0CastL eq0') = Eq0CastL (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 (Eq0FailedCastL eq0') = Eq0FailedCastL (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 (Eq0CastR eq0') = Eq0CastR (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 (Eq0FailedCastR eq0') = Eq0FailedCastR (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 Eq0Const = Eq0Const + eq0c'-ttSub eq0 Eq0EHole = Eq0EHole + eq0c'-ttSub eq0 (Eq0Lam eq0') = Eq0Lam (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 (Eq0TLam eq0') = Eq0TLam (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 (Eq0NEHole eq0') = Eq0NEHole (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub eq0 (Eq0Ap eq0' eq0'') = Eq0Ap (eq0c'-ttSub eq0 eq0') (eq0c'-ttSub eq0 eq0'') + eq0c'-ttSub eq0 (Eq0TAp eq0') = Eq0TAp (eq0c'-ttSub eq0 eq0') + eq0c'-ttSub {d3 = (X x)} {d4 = (.X x)} {n = n} eq0 Eq0Var with natEQ x n + ... | Inl refl = eq0c'-shift eq0 + ... | Inr neq = Eq0Var + + eq0c'-TtSub : + ∀{τ1 τ2 d1 d2 n} → + d1 =0c' d2 → + TtSub n τ1 d1 =0c' TtSub n τ2 d2 + eq0c'-TtSub (Eq0CastL eq0) = Eq0CastL (eq0c'-TtSub eq0) + eq0c'-TtSub (Eq0FailedCastL eq0) = Eq0FailedCastL (eq0c'-TtSub eq0) + eq0c'-TtSub (Eq0CastR eq0) = Eq0CastR (eq0c'-TtSub eq0) + eq0c'-TtSub (Eq0FailedCastR eq0) = Eq0FailedCastR (eq0c'-TtSub eq0) + eq0c'-TtSub Eq0Const = Eq0Const + eq0c'-TtSub Eq0Var = Eq0Var + eq0c'-TtSub Eq0EHole = Eq0EHole + eq0c'-TtSub (Eq0Lam eq0) = Eq0Lam (eq0c'-TtSub eq0) + eq0c'-TtSub (Eq0TLam eq0) = Eq0TLam (eq0c'-TtSub eq0) + eq0c'-TtSub (Eq0NEHole eq0) = Eq0NEHole (eq0c'-TtSub eq0) + eq0c'-TtSub (Eq0Ap eq0 eq1) = Eq0Ap (eq0c'-TtSub eq0) (eq0c'-TtSub eq1) + eq0c'-TtSub (Eq0TAp eq0) = Eq0TAp (eq0c'-TtSub eq0) + + eq0c-ttSub : + ∀ {d1 d2 d3 d4 n m} → + d1 =0c d2 → + d3 =0c d4 → + (ttSub n m d1 d3) =0c (ttSub n m d2 d4) + eq0c-ttSub eq0 eq0' = =0c'-equiv (eq0c'-ttSub (=0c-equiv eq0) (=0c-equiv eq0')) + + eq0-TtSub : + ∀{τ1 τ2 d1 d2 n} → + d1 =0c d2 → + TtSub n τ1 d1 =0c TtSub n τ2 d2 + eq0-TtSub eq0 = =0c'-equiv (eq0c'-TtSub (=0c-equiv eq0)) + + eq-ctx-eq : ∀{ε d d1 d2} → + d1 == ε ⟦ d ⟧ → d2 == ε ⟦ d ⟧ → + d1 == d2 + eq-ctx-eq FHOuter FHOuter = refl + eq-ctx-eq (FHAp1 ctx1) (FHAp1 ctx2) rewrite eq-ctx-eq ctx1 ctx2 = refl + eq-ctx-eq (FHAp2 ctx1) (FHAp2 ctx2) rewrite eq-ctx-eq ctx1 ctx2 = refl + eq-ctx-eq (FHTAp ctx1) (FHTAp ctx2) rewrite eq-ctx-eq ctx1 ctx2 = refl + eq-ctx-eq (FHNEHole ctx1) (FHNEHole ctx2) rewrite eq-ctx-eq ctx1 ctx2 = refl + eq-ctx-eq (FHCast ctx1) (FHCast ctx2) rewrite eq-ctx-eq ctx1 ctx2 = refl + eq-ctx-eq (FHFailedCast ctx1) (FHFailedCast ctx2) rewrite eq-ctx-eq ctx1 ctx2 = refl + + evalctx-compose-func : (ε ε' : ectx) → ectx + evalctx-compose-func ⊙ e2 = e2 + evalctx-compose-func (e1 ∘₁ x) e2 = ((evalctx-compose-func e1 e2) ∘₁ x) + evalctx-compose-func (x ∘₂ e1) e2 = (x ∘₂ (evalctx-compose-func e1 e2)) + evalctx-compose-func (e1 < x >) e2 = ((evalctx-compose-func e1 e2) < x >) + evalctx-compose-func ⦇⌜ e1 ⌟⦈ e2 = ⦇⌜ (evalctx-compose-func e1 e2) ⌟⦈ + evalctx-compose-func (e1 ⟨ x ⇒ x₁ ⟩) e2 = ((evalctx-compose-func e1 e2) ⟨ x ⇒ x₁ ⟩) + evalctx-compose-func (e1 ⟨ x ⇒⦇-⦈⇏ x₁ ⟩) e2 = ((evalctx-compose-func e1 e2) ⟨ x ⇒⦇-⦈⇏ x₁ ⟩) + + evalctx-compose : ∀{d d' d'' ε ε'} → + d == ε ⟦ d' ⟧ → + d' == ε' ⟦ d'' ⟧ → + (d == (evalctx-compose-func ε ε') ⟦ d'' ⟧) + evalctx-compose FHOuter ec2 = ec2 + evalctx-compose (FHAp1 ec1) ec2 = FHAp1 (evalctx-compose ec1 ec2) + evalctx-compose (FHAp2 ec1) ec2 = FHAp2 (evalctx-compose ec1 ec2) + evalctx-compose (FHTAp ec1) ec2 = FHTAp (evalctx-compose ec1 ec2) + evalctx-compose (FHNEHole ec1) ec2 = FHNEHole (evalctx-compose ec1 ec2) + evalctx-compose (FHCast ec1) ec2 = FHCast (evalctx-compose ec1 ec2) + evalctx-compose (FHFailedCast ec1) ec2 = FHFailedCast (evalctx-compose ec1 ec2) + + evalctx-uncompose : ∀{d d' d'' ε ε'} → + (d == (evalctx-compose-func ε ε') ⟦ d'' ⟧) → + d' == ε' ⟦ d'' ⟧ → + d == ε ⟦ d' ⟧ + evalctx-uncompose {ε = ⊙} ec1 ec2 rewrite eq-ctx-eq ec1 ec2 = FHOuter + evalctx-uncompose {ε = ε ∘₁ x} (FHAp1 ec1) ec2 = FHAp1 (evalctx-uncompose ec1 ec2) + evalctx-uncompose {ε = x ∘₂ ε} (FHAp2 ec1) ec2 = FHAp2 (evalctx-uncompose ec1 ec2) + evalctx-uncompose {ε = ε < x >} (FHTAp ec1) ec2 = FHTAp (evalctx-uncompose ec1 ec2) + evalctx-uncompose {ε = ⦇⌜ ε ⌟⦈} (FHNEHole ec1) ec2 = FHNEHole (evalctx-uncompose ec1 ec2) + evalctx-uncompose {ε = ε ⟨ x ⇒ x₁ ⟩} (FHCast ec1) ec2 = FHCast (evalctx-uncompose ec1 ec2) + evalctx-uncompose {ε = ε ⟨ x ⇒⦇-⦈⇏ x₁ ⟩} (FHFailedCast ec1) ec2 = FHFailedCast (evalctx-uncompose ec1 ec2) + + evalctx-out : ∀{d d1 ε} → + (d2 : ihexp) → + d == ε ⟦ d1 ⟧ → + Σ[ d' ∈ ihexp ] (d' == ε ⟦ d2 ⟧) + evalctx-out d2 FHOuter = d2 , FHOuter + evalctx-out d2 (FHAp1 ec) with evalctx-out d2 ec + ... | d' , ctx = _ , FHAp1 ctx + evalctx-out d2 (FHAp2 ec) with evalctx-out d2 ec + ... | d' , ctx = _ , FHAp2 ctx + evalctx-out d2 (FHTAp ec) with evalctx-out d2 ec + ... | d' , ctx = _ , FHTAp ctx + evalctx-out d2 (FHNEHole ec) with evalctx-out d2 ec + ... | d' , ctx = _ , FHNEHole ctx + evalctx-out d2 (FHCast ec) with evalctx-out d2 ec + ... | d' , ctx = _ , FHCast ctx + evalctx-out d2 (FHFailedCast ec) with evalctx-out d2 ec + ... | d' , ctx = _ , FHFailedCast ctx + + evalctx-compose-ms : ∀{d d' din din' ε} → + din ↦* din' → + d == ε ⟦ din ⟧ → + d' == ε ⟦ din' ⟧ → + d ↦* d' + evalctx-compose-ms MSRefl ctxin ctxout with eq-ctx-eq ctxin ctxout + ... | refl = MSRefl + evalctx-compose-ms (MSStep (Step {d0 = d0} {d0' = d0'} x x₁ x₂) ms) ctxin ctxout with evalctx-out d0' (evalctx-compose ctxin x) + ... | d'' , ctxmid = MSStep (Step (evalctx-compose ctxin x) x₁ ctxmid) (evalctx-compose-ms ms (evalctx-uncompose ctxmid x₂) ctxout) + + + val-cast-final : ∀{d τ1 τ2} → + d val → ∅ ⊢ d :: τ1 → ∅ ⊢ τ1 wf → ∅ ⊢ τ2 wf → τ1 ≠ τ2 → τ1 ~ τ2 → + Σ[ d' ∈ ihexp ] ((d ⟨ τ1 ⇒ τ2 ⟩) =0c d' × ((d ⟨ τ1 ⇒ τ2 ⟩) ↦* d') × d' final) + val-cast-final v wt wf1 wf2 neq ConsistBase = abort (neq refl) + val-cast-final v wt wf1 wf2 neq ConsistVar = abort (neq refl) + val-cast-final {τ1 = τ1} v wt wf1 wf2 neq ConsistHole1 with ground-dec τ1 + ... | Inl gnd = _ , eq0c-refl , MSRefl , FBoxedVal (BVHoleCast gnd (BVVal v)) + val-cast-final {τ1 = b} v wt wf1 wf2 neq ConsistHole1 | Inr gnd = abort (gnd GBase) + val-cast-final {τ1 = T x} v wt () wf2 neq ConsistHole1 | Inr gnd + val-cast-final {τ1 = ⦇-⦈} v wt wf1 wf2 neq ConsistHole1 | Inr gnd = abort (neq refl) + val-cast-final {τ1 = τ1 ==> τ2} v wt wf1 wf2 neq ConsistHole1 | Inr gnd with htyp-eq-dec (τ1 ==> τ2) (⦇-⦈ ==> ⦇-⦈) + ... | Inl refl = abort (gnd GArr) + ... | Inr neq' = _ , Eq0CastL (eq0cr-lemma (eq0cr-lemma eq0c-refl)) , MSStep (Step FHOuter (ITGround (MGArr neq')) FHOuter) MSRefl , FBoxedVal (BVHoleCast GArr (BVArrCast neq' (BVVal v))) + val-cast-final {τ1 = ·∀ τ1} v wt wf1 wf2 neq ConsistHole1 | Inr gnd with htyp-eq-dec (·∀ τ1) (·∀ ⦇-⦈) + ... | Inl refl = abort (gnd GForall) + ... | Inr neq' = _ , Eq0CastL (eq0cr-lemma (eq0cr-lemma eq0c-refl)) , MSStep (Step FHOuter (ITGround (MGForall neq')) FHOuter) MSRefl , FBoxedVal (BVHoleCast GForall (BVForallCast neq' (BVVal v))) + val-cast-final VConst () wf1 wf2 neq ConsistHole2 + val-cast-final VLam () wf1 wf2 neq ConsistHole2 + val-cast-final VTLam () wf1 wf2 neq ConsistHole2 + val-cast-final v wt wf1 wf2 neq (ConsistArr consis consis₁) = _ , eq0c-refl , MSRefl , FBoxedVal (BVArrCast neq (BVVal v)) + val-cast-final v wt wf1 wf2 neq (ConsistForall consis) = _ , eq0c-refl , MSRefl , FBoxedVal (BVForallCast neq (BVVal v)) + + eq0cn-val-val : ∀{d d'} → + d val → d =0cn d' → d' val + eq0cn-val-val VConst Eq0Const = VConst + eq0cn-val-val VLam (Eq0Lam x) = VLam + eq0cn-val-val VTLam (Eq0TLam x) = VTLam + + mstrans : ∀{d d' d''} → + d ↦* d' → d' ↦* d'' → d ↦* d'' + mstrans MSRefl ms2 = ms2 + mstrans (MSStep x ms1) ms2 = MSStep x (mstrans ms1 ms2) + + preservation-trans : ∀ { d d' τ } → + ∅ ⊢ d :: τ → + d ↦* d' → + ∅ ⊢ d' :: τ + preservation-trans wt MSRefl = wt + preservation-trans wt (MSStep x ms) = preservation-trans (preservation wt x) ms + + fin-arr-lemma : ∀{d τ1 τ2 τ3 τ4} → + d final → τ1 ==> τ2 ≠ τ3 ==> τ4 → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) final + fin-arr-lemma (FBoxedVal x) ne = FBoxedVal (BVArrCast ne x) + fin-arr-lemma (FIndet x) ne = FIndet (ICastArr ne x) + + fin-forall-lemma : ∀{d τ1 τ2 } → + d final → ·∀ τ1 ≠ ·∀ τ2 → (d ⟨ ·∀ τ1 ⇒ ·∀ τ2 ⟩) final + fin-forall-lemma (FBoxedVal x) ne = FBoxedVal (BVForallCast ne x) + fin-forall-lemma (FIndet x) ne = FIndet (ICastForall ne x) + + fin-gndhole-lemma : ∀{d τ} → + d final → τ ground → (d ⟨ τ ⇒ ⦇-⦈ ⟩) final + fin-gndhole-lemma (FBoxedVal x) gnd = FBoxedVal (BVHoleCast gnd x) + fin-gndhole-lemma (FIndet x) gnd = FIndet (ICastGroundHole gnd x) + + fin-gndhole-lemma' : ∀{d τ} → + (d ⟨ τ ⇒ ⦇-⦈ ⟩) final → d final + fin-gndhole-lemma' (FBoxedVal (BVHoleCast x x₁)) = FBoxedVal x₁ + fin-gndhole-lemma' (FIndet (ICastGroundHole x x₁)) = FIndet x₁ + + ITCastSucceed' : ∀{d τ1 τ2} → τ1 == τ2 → τ1 ground → (d ⟨ τ1 ⇒ ⦇-⦈ ⇒ τ2 ⟩) →> d + ITCastSucceed' eq gnd rewrite eq = ITCastSucceed gnd + + confluence : Set + confluence = (d dm1 dm2 : ihexp) → d ↦* dm1 → d ↦* dm2 → Σ[ df ∈ ihexp ](dm1 ↦* df × dm2 ↦* df) + + confluence-implies-unique-normal-form : ∀{d d1 d2} → + confluence → + d ↦* d1 → + d ↦* d2 → + d1 final → + d2 final → + d1 == d2 + confluence-implies-unique-normal-form {d} {d1} {d2} conf steps1 steps2 final1 final2 + with conf d d1 d2 steps1 steps2 + ... | df , steps1' , step2' rewrite finality* final1 steps1' rewrite finality* final2 step2' = refl + \ No newline at end of file diff --git a/parametricity2-lemmas1.agda b/parametricity2-lemmas1.agda new file mode 100644 index 0000000..0c5b25b --- /dev/null +++ b/parametricity2-lemmas1.agda @@ -0,0 +1,240 @@ +{-# OPTIONS --no-termination-check #-} +{-# OPTIONS --allow-unsolved-metas #-} + +open import Nat +open import Prelude +open import core +open import core-type +open import core-exp +open import core-subst + +open import parametricity2-defs + +open import preservation +open import ground-dec +open import lemmas-consistency +open import lemmas-wf +open import eq-dec +open import lemmas-ground + +module parametricity2-lemmas1 where + + {- + Idea bin -- all cast transitions preserve =0c -- ITApCast ITCastID ITCastSucceed ITApCast ITExpand etc. + We rule out ITCastFail by assumption (d1 terminates successfully, d2 is allowed to indet. + + Use =0c to constrain forms, and find that ignoring cast forms, d2 can match the rule d1 uses. + Note: Can't use progress since we need the same part of each form to step. + + I think I can phrase it as + d1 steps and they're equal or + they both step and they're equal or + d2 does a cast step and they're equal, and some ordering on casts decreases + + Basically saying that we cannot pick the third option infinitely. + + I would like to show that third part by saying only the cast steps can preserve =0c. I.e. that ITLam and ITTLam do not. + However a difficulty here is Omega... if d1 -> d1 through ITLam then clearly =0c is preserved... + So I guess I'll have to argue its termination via some ordering on terms based on lexicographic cast positioning? + At its core, I just need to show "eventually we take a step that's not a cast" -- though in the current rules formulation that may not be true, + since we can do ITExpand infinitely??? + + Or perhaps I can say 2nd case is d1 steps and d2 steps multiple times to something equal. That way I can do like + ITExpand -> ITApCast (Though even then that doesn't change the form and I may have to repeat that. Certainly only a finite number of times though?) + -} + -- I think I need to remove the third branch. I think the statement of the conclusion should be + -- d1' =0c d2 + Σ[ d2' ∈ ihexp ] (d2 ↦* d2' × d1' =0c d2') + parametricity21-lemma-ctx : ∀{d1 d2 d1' τ1 τ2} → + ∅ ⊢ d1 :: τ1 → + ∅ ⊢ d2 :: τ2 → + d1 =0c d2 → + d1 ↦ d1' → + Σ[ d2' ∈ ihexp ] (d2 ↦* d2' × (d1' =0c d2' + d2' indet)) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin step ctxout) with eq0-ctxinc eq0 ctxin + + -- See note above -- all of these preserve =0c + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITCastID ctxout) | d2in , ε2 , ctxin' , Eq0CastL eq0in , eq0e , form = _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0CastL eq0c-refl) eq0) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin (ITCastSucceed x) ctxout) | d2in , ε2 , ctxin' , Eq0CastL eq0in , eq0e , form = _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0CastL (Eq0CastL eq0c-refl)) eq0) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin (ITCastFail x x₁ x₂) ctxout) | d2in , ε2 , ctxin' , Eq0CastL eq0in , eq0e , form = _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0CastL (Eq0CastL (eq0cr-lemma' eq0c-refl))) eq0) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin (ITGround x) ctxout) | d2in , ε2 , ctxin' , Eq0CastL eq0in , eq0e , form = _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0CastL (eq0cr-lemma (eq0cr-lemma eq0c-refl))) eq0) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin (ITExpand x) ctxout) | d2in , ε2 , ctxin' , Eq0CastL eq0in , eq0e , form = _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0CastL (eq0cr-lemma (eq0cr-lemma eq0c-refl))) eq0) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITApCast ctxout) + | .(_ ∘ _) , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap x x₁)) , eq0e , form = + _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0NoLeft (Eq0CastR (Eq0NoCasts (Eq0Ap (Eq0CastL eq0c-refl) (eq0cr-lemma eq0c-refl))))) eq0) -- Using ITApCast doesn't change =0 status + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITTApCast ctxout) | .(_ < _ >) , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0TAp x)) , eq0e = -- Using ITTApCast doesn't either + _ , MSRefl , Inl (eq0c-ctx ctxin ctxout (Eq0NoLeft (Eq0CastR (Eq0NoCasts (Eq0TAp (Eq0CastL eq0c-refl))))) eq0) + + -- Pick a better context. Add as a conclusion to eq0-ctxinc that the ctx we select absorbs all casts from the term. + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin step ctxout) | .(_ ⟨ _ ⇒ _ ⟩) , ε2 , ctxin' , Eq0NoLeft (Eq0CastR x) , eq0e , form + = abort (π1 (form _ _ _) refl) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin step ctxout) | .(_ ⟨ _ ⇒⦇-⦈⇏ _ ⟩) , ε2 , ctxin' , Eq0NoLeft (Eq0FailedCastR x) , eq0e , form + = abort (π2 (form _ _ _) refl) + + -- Cases where we have an ITLam but the right side has some casts to the left of the application to deal with (we have to find our way to an ITApCast) + -- The termination checker isn't happy with my use of induction here, but I know it terminates because every time I call it inductively, + -- I'm reducing the metric of: let n_k be the number of casts to the left of k apps. Let n = the syntactic size of the term. + -- Lexicographically order these measures n_infinity > ... > n_2 > n_1 > n_0 > n. + -- Note that only ITExpand and ITGround increase these measures, with other cast steps decreasing them, but + -- I always provide following sequences of reductions such that + -- By the time I use the inductive hypothesis, this measure has decreased. + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | (.((_ ⟨ _ ⇒ _ ⟩) ∘ _) , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form) with wt-filling wt2 ctxin' + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR (Eq0NoCasts ()))) x₁)) , eq0e , form | (_ , (TAAp (TACast {d = .⦇-⦈} {τ2 = .(_ ==> _)} TAEHole x₃ ConsistHole2) wt2'')) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR (Eq0NoCasts ()))) x₁)) , eq0e , form | _ , TAAp (TACast {d = ⦇⌜ _ ⌟⦈} {τ2 = (_ ==> _)} (TANEHole wt2') x₃ ConsistHole2) wt2'' + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR (Eq0NoCasts ()))) x₁)) , eq0e , form | _ , TAAp (TACast {d = .(_ ∘ _)} {τ2 = .(_ ==> _)} (TAAp wt2' wt2c) x₃ ConsistHole2) wt2'' + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR (Eq0NoCasts ()))) x₁)) , eq0e , form | _ , TAAp (TACast {d = .(_ < _ >)} {τ2 = .(_ ==> _)} (TATAp x₄ wt2' x₆) x₃ ConsistHole2) wt2'' + ... | _ , TAAp (TACast {d = .(_ ⟨ _ ⇒⦇-⦈⇏ _ ⟩)} {τ2 = .(_ ==> _)} (TAFailedCast wt2' x₄ x₆ x₇) x₃ ConsistHole2) wt2'' = {! !} + -- Consider, evaluation of the argument diverges. We can get a terminating execution by substituting it in (which can throw it away). But + -- By having a failed cast we force evaluation of the argument, which can be non-terminating (think Ω). + -- This can be fixed with call-by-value semantics. + -- Supposing d4 is a value, then we know we have to reduce the left hand side of the ap. But since we have =0c, it must be a Lam. + -- But then, we get that d2 is indet, exactly what we want to show. + ... | _ , TAAp {d2 = d22} (TACast {d = d21} {τ1 = τ1 ==> τ2} {τ2 = (τ3 ==> τ4)} wt2' x₃ (ConsistArr x₄ x₆)) wt2'' with evalctx-out (((d21 ∘ (d22 ⟨ τ3 ⇒ τ1 ⟩)) ⟨ τ2 ⇒ τ4 ⟩)) ctxin' + ... | _ , ctxout' with parametricity21-lemma-ctx wt1 (preservation wt2 (Step ctxin' ITApCast ctxout')) (eq0c-sym (eq0c-ctx ctxin' ctxout' (Eq0NoLeft (Eq0CastR (Eq0NoCasts (Eq0Ap (Eq0CastL eq0c-refl) (eq0cr-lemma eq0c-refl))))) (eq0c-sym eq0))) ((Step ctxin ITLam ctxout)) + ... | d2' , steps' , eq0final = d2' , MSStep (Step ctxin' ITApCast ctxout') steps' , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' with ground-dec τ1 | ground-dec (τ2 ==> τ3) + ... | Inl gndl | Inl gndr with ~dec τ1 (τ2 ==> τ3) + ... | Inl consis with evalctx-out (d3 ∘ d4) ctxin' + ... | _ , ctxout' rewrite gnd-gnd-consis-eq gndl gndr consis with parametricity21-lemma-ctx wt1 (preservation wt2 (Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITCastSucceed gndr) (evalctx-compose ctxout' (FHAp1 FHOuter)))) ((eq0c-sym (eq0c-ctx ctxin' ctxout' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL eq0c-refl)) eq0c-refl))) (eq0c-sym eq0)))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , MSStep (Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITCastSucceed gndr) (evalctx-compose ctxout' (FHAp1 FHOuter))) steps' , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inl gndl | Inl gndr | Inr consis with evalctx-out ((d3 ⟨ τ1 ⇒⦇-⦈⇏ (τ2 ==> τ3) ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with parametricity21-lemma-ctx wt1 (preservation wt2 (Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITCastFail gndl gndr consis) (evalctx-compose ctxout' (FHAp1 FHOuter)))) ((eq0c-sym (eq0c-ctx ctxin' ctxout' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma' eq0c-refl))) eq0c-refl))) (eq0c-sym eq0)))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , MSStep (Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITCastFail gndl gndr consis) (evalctx-compose ctxout' (FHAp1 FHOuter))) steps' , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inl gndl | Inr gndr with ground-match-exists gndr x₃ (λ ()) + ... | τ2' ==> τ3' , gndr' with evalctx-out (((d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with ~dec τ1 (τ2' ==> τ3') + ... | Inl (ConsistArr c1 c2) with evalctx-out ((d3 ⟨ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxout' + ... | _ , ctxout'' with parametricity21-lemma-ctx wt1 + (preservation (preservation wt2 ((Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITExpand gndr') ((evalctx-compose ctxout' (FHAp1 FHOuter)))))) + ((Step (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) (ITCastSucceed' (gnd-gnd-consis-eq gndl (ground-match gndr') (ConsistArr c1 c2)) gndl) (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter)))))) + (eq0c-sym (eq0c-ctx ctxin' ctxout'' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma eq0c-refl))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , + MSStep (Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITExpand gndr') ((evalctx-compose ctxout' (FHAp1 FHOuter)))) + (MSStep (Step (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) (ITCastSucceed' (gnd-gnd-consis-eq gndl (ground-match gndr') (ConsistArr c1 c2)) gndl) (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter)))) steps') , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inl gndl | Inr gndr | τ2' ==> τ3' , gndr' | _ , ctxout' | Inr consis with evalctx-out (((d3 ⟨ τ1 ⇒⦇-⦈⇏ τ2' ==> τ3' ⟩) ⟨ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxout' + ... | _ , ctxout'' with parametricity21-lemma-ctx wt1 (preservation (preservation wt2 ((Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITExpand gndr') ((evalctx-compose ctxout' (FHAp1 FHOuter)))))) + ((Step (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) (ITCastFail gndl (ground-match gndr') consis) (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter)))))) + (eq0c-sym (eq0c-ctx ctxin' ctxout'' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma (eq0cr-lemma' eq0c-refl)))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , + MSStep (Step (evalctx-compose ctxin' (FHAp1 FHOuter)) (ITExpand gndr') ((evalctx-compose ctxout' (FHAp1 FHOuter)))) + (MSStep (Step (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) (ITCastFail gndl (ground-match gndr') consis) (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter)))) steps') , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inr gndl | Inl gndr with htyp-eq-dec τ1 ⦇-⦈ + ... | Inl refl with evalctx-out ((d3 ⟨ ⦇-⦈ ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with parametricity21-lemma-ctx wt1 (preservation wt2 ((Step (evalctx-compose ctxin' (FHAp1 (FHCast (FHOuter)))) ITCastID (evalctx-compose ctxout' (FHAp1 (FHCast (FHOuter))))))) + (eq0c-sym (eq0c-ctx ctxin' ctxout' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma eq0c-refl))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , MSStep (Step (evalctx-compose ctxin' (FHAp1 (FHCast (FHOuter)))) ITCastID (evalctx-compose ctxout' (FHAp1 (FHCast (FHOuter))))) steps' , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inr gndl | Inl gndr | Inr neq with ground-match-exists gndl (wf-ta CtxWFEmpty wt2') neq + ... | τ1' , gndl' with evalctx-out ((((d3 ⟨ τ1 ⇒ τ1' ⟩) ⟨ τ1' ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with ~dec τ1' (τ2 ==> τ3) + ... | Inl consis with evalctx-out ((d3 ⟨ τ1 ⇒ τ1' ⟩) ∘ d4) ctxout' + ... | _ , ctxout'' with parametricity21-lemma-ctx wt1 (preservation (preservation wt2 + ((Step ((evalctx-compose ctxin' (FHAp1 (FHCast (FHOuter))))) (ITGround gndl') ((evalctx-compose ctxout' (FHAp1 (FHCast (FHOuter)))))))) + ((Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITCastSucceed' (gnd-gnd-consis-eq (ground-match gndl') gndr consis) (ground-match gndl')) (evalctx-compose ctxout'' (FHAp1 FHOuter))))) + (eq0c-sym (eq0c-ctx ctxin' ctxout'' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma eq0c-refl))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , + MSStep (Step ((evalctx-compose ctxin' (FHAp1 (FHCast (FHOuter))))) (ITGround gndl') ((evalctx-compose ctxout' (FHAp1 (FHCast (FHOuter)))))) + (MSStep (Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITCastSucceed' (gnd-gnd-consis-eq (ground-match gndl') gndr consis) (ground-match gndl')) (evalctx-compose ctxout'' (FHAp1 FHOuter))) steps') , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inr gndl | Inl gndr | Inr neq | τ1' , gndl' | _ , ctxout' | Inr consis with evalctx-out (((d3 ⟨ τ1 ⇒ τ1' ⟩) ⟨ τ1' ⇒⦇-⦈⇏ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout'' with parametricity21-lemma-ctx wt1 (preservation (preservation wt2 + (Step ((evalctx-compose ctxin' (FHAp1 (FHCast (FHOuter))))) (ITGround gndl') ((evalctx-compose ctxout' (FHAp1 (FHCast (FHOuter))))))) + (Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITCastFail (ground-match gndl') gndr consis) (evalctx-compose ctxout'' (FHAp1 FHOuter)))) + (eq0c-sym (eq0c-ctx ctxin' ctxout'' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma' (eq0cr-lemma eq0c-refl)))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | d2' , steps' , eq0final = d2' , + MSStep (Step ((evalctx-compose ctxin' (FHAp1 (FHCast (FHOuter))))) (ITGround gndl') ((evalctx-compose ctxout' (FHAp1 (FHCast (FHOuter)))))) + (MSStep (Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITCastFail (ground-match gndl') gndr consis) (evalctx-compose ctxout'' (FHAp1 FHOuter))) steps') , + eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inr gndl | Inr gndr with htyp-eq-dec τ1 ⦇-⦈ + ... | Inl refl with evalctx-out ((d3 ⟨ ⦇-⦈ ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with parametricity21-lemma-ctx wt1 (preservation wt2 (Step (evalctx-compose ctxin' (FHAp1 (FHCast FHOuter))) ITCastID (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))))) + (eq0c-sym (eq0c-ctx ctxin' ctxout' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma eq0c-refl))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | d2' , step' , eq0final = d2' , MSStep (Step (evalctx-compose ctxin' (FHAp1 (FHCast FHOuter))) ITCastID (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter)))) step' , eq0final + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inr gndl | Inr gndr | Inr neq with ground-match-exists gndl (wf-ta CtxWFEmpty wt2') neq | ground-match-exists gndr x₃ (λ ()) + ... | τ1' , gndl' | τ2' ==> τ3' , gndr' with ~dec τ1' (τ2' ==> τ3') + ... | Inl consis with evalctx-out (((d3 ⟨ τ1 ⇒ τ1' ⟩ ⟨ τ1' ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with evalctx-out (((d3 ⟨ τ1 ⇒ τ1' ⟩ ⟨ τ1' ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ2' ==> τ3' ⟩ ⟨ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxout' + ... | _ , ctxout'' with evalctx-out ((d3 ⟨ τ1 ⇒ τ1' ⟩ ⟨ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxout'' + ... | _ , ctxout''' with parametricity21-lemma-ctx wt1 (preservation (preservation (preservation wt2 step1) step2) step3) + (eq0c-sym (eq0c-ctx ctxin' ctxout''' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma (eq0cr-lemma eq0c-refl)))) eq0c-refl))) (eq0c-sym eq0))) + (Step ctxin ITLam ctxout) + where + eq = gnd-gnd-consis-eq (ground-match gndl') (ground-match gndr') consis + step1 = Step (evalctx-compose ctxin' (FHAp1 (FHCast FHOuter))) (ITGround gndl') (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) + step2 = Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITExpand gndr') (evalctx-compose ctxout'' (FHAp1 FHOuter)) + step3 = Step (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter))) (ITCastSucceed' eq (ground-match gndl')) (evalctx-compose ctxout''' (FHAp1 (FHCast FHOuter))) + ... | d2' , step' , eq0final = d2' , MSStep step1 (MSStep step2 (MSStep step3 step')) , eq0final + where + eq = gnd-gnd-consis-eq (ground-match gndl') (ground-match gndr') consis + step1 = Step (evalctx-compose ctxin' (FHAp1 (FHCast FHOuter))) (ITGround gndl') (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) + step2 = Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITExpand gndr') (evalctx-compose ctxout'' (FHAp1 FHOuter)) + step3 = Step (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter))) (ITCastSucceed' eq (ground-match gndl')) (evalctx-compose ctxout''' (FHAp1 (FHCast FHOuter))) + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | _ , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0CastR x)) x₁)) , eq0e , form | _ , TAAp {d2 = d4} (TACast {d = (d3 ⟨ τ1 ⇒ ⦇-⦈ ⟩)} {τ2 = (τ2 ==> τ3)} (TACast wt2' x₄ x₆) x₃ ConsistHole2) wt2'' + | Inr gndl | Inr gndr | Inr neq | τ1' , gndl' | τ2' ==> τ3' , gndr' + | Inr consis {- Basically the same but with failedcast at the end -} with evalctx-out (((d3 ⟨ τ1 ⇒ τ1' ⟩ ⟨ τ1' ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with evalctx-out (((d3 ⟨ τ1 ⇒ τ1' ⟩ ⟨ τ1' ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ2' ==> τ3' ⟩ ⟨ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxout' + ... | _ , ctxout'' with evalctx-out ((d3 ⟨ τ1 ⇒ τ1' ⟩ ⟨ τ1' ⇒⦇-⦈⇏ τ2' ==> τ3' ⟩ ⟨ τ2' ==> τ3' ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxout'' + ... | _ , ctxout''' with parametricity21-lemma-ctx wt1 (preservation (preservation (preservation wt2 step1) step2) step3) + (eq0c-sym (eq0c-ctx ctxin' ctxout''' (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma (eq0cr-lemma' (eq0cr-lemma eq0c-refl))))) eq0c-refl))) (eq0c-sym eq0))) + (Step ctxin ITLam ctxout) + where + step1 = Step (evalctx-compose ctxin' (FHAp1 (FHCast FHOuter))) (ITGround gndl') (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) + step2 = Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITExpand gndr') (evalctx-compose ctxout'' (FHAp1 FHOuter)) + step3 = Step (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter))) (ITCastFail (ground-match gndl') (ground-match gndr') consis) (evalctx-compose ctxout''' (FHAp1 (FHCast FHOuter))) + ... | d2' , step' , eq0final = d2' , MSStep step1 (MSStep step2 (MSStep step3 step')) , eq0final + where + step1 = Step (evalctx-compose ctxin' (FHAp1 (FHCast FHOuter))) (ITGround gndl') (evalctx-compose ctxout' (FHAp1 (FHCast FHOuter))) + step2 = Step (evalctx-compose ctxout' (FHAp1 FHOuter)) (ITExpand gndr') (evalctx-compose ctxout'' (FHAp1 FHOuter)) + step3 = Step (evalctx-compose ctxout'' (FHAp1 (FHCast FHOuter))) (ITCastFail (ground-match gndl') (ground-match gndr') consis) (evalctx-compose ctxout''' (FHAp1 (FHCast FHOuter))) + +{- + ~dec τ1 (τ2 ==> τ3) + ... | Inl consis = {! !} + ... | Inr notconsis with evalctx-out ((d3 ⟨ τ1 ⇒ τ2 ==> τ3 ⟩) ∘ d4) ctxin' + ... | _ , ctxout' with parametricity21-lemma-ctx wt1 (wt-different-fill ctxin' wt2 {! !} {! !} ctxout') (eq0c-sym (eq0c-ctx ctxin' ctxout' ctxin (eq0ε''-sym eq0e) (Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0CastL (Eq0CastL (eq0cr-lemma eq0c-refl))) eq0c-refl))) (eq0c-sym eq0))) (Step ctxin ITLam ctxout) + ... | Inl res = {! !} + ... | Inr (d2' , steps' , eq0final) with evalctx-compose ctxin' (FHAp1 FHOuter) | evalctx-compose ctxout' (FHAp1 FHOuter) + ... | (_ , ctxin'') | (_ , ctxout'') = Inr (d2' , MSStep (Step ctxin'' (ITCastSucceed {! !} {! !} {! !}) {! !}) steps' , eq0final) +-} + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITLam ctxout) + | .((_ ⟨ _ ⇒⦇-⦈⇏ _ ⟩) ∘ _) , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0Ap (Eq0NoLeft (Eq0FailedCastR x)) x₁)) , eq0e , form = + {! !} -- d2 contains a failed cast so it will be indet (must show it doesn't diverge?) + -- Note that this requires that the inside must be able to terminate. + -- This is guaranteed if ITLam requires the argument to be final. + + + -- These proceed basically identically to the ITLam cases though with type substitution + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITTLam ctxout) | .((_ ⟨ _ ⇒ _ ⟩) < _ >) , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0TAp (Eq0NoLeft (Eq0CastR x)))) , eq0e , form = {! !} + parametricity21-lemma-ctx {d2 = d2} wt1 wt2 eq0 (Step ctxin ITTLam ctxout) | .((_ ⟨ _ ⇒⦇-⦈⇏ _ ⟩) < _ >) , ε2 , ctxin' , Eq0NoLeft (Eq0NoCasts (Eq0TAp (Eq0NoLeft (Eq0FailedCastR x)))) , eq0e , form = {! !} + +-- These are the actual interesting cases. + parametricity21-lemma-ctx {d1 = d1} {d2 = d2} wt1 wt2 eq0 (Step ctxin (ITLam {d1 = d3} {d2 = d4}) ctxout) + | ((·λ[ _ ] _) ∘ _) , ε2 , ctxin' , + Eq0NoLeft (Eq0NoCasts (Eq0Ap {d4 = d6} (Eq0NoLeft (Eq0NoCasts (Eq0Lam {d2 = d5} x))) x₁)) , eq0e , form with eq0c-ctxout (eq0c-ttSub x₁ x) eq0e ctxout + ... | (d2out , eqeout , eq0out) = _ , MSStep (Step ctxin' ITLam eqeout) MSRefl , Inl eq0out + parametricity21-lemma-ctx wt1 wt2 eq0 (Step ctxin (ITTLam {d = d1}) ctxout) + | .(·Λ _ < _ >) , ε2 , ctxin' , + Eq0NoLeft (Eq0NoCasts (Eq0TAp (Eq0NoLeft (Eq0NoCasts (Eq0TLam {d2 = d2} x))))) , eq0e , form with eq0c-ctxout (eq0-TtSub x) eq0e ctxout + ... | (d2out , eqeout , eq0out) = _ , MSStep (Step ctxin' ITTLam eqeout) MSRefl , Inl eq0out + + \ No newline at end of file diff --git a/parametricity2-lemmas2.agda b/parametricity2-lemmas2.agda new file mode 100644 index 0000000..2d7ccff --- /dev/null +++ b/parametricity2-lemmas2.agda @@ -0,0 +1,291 @@ +open import Nat +open import Prelude +open import core +open import core-type +open import core-exp +open import core-subst + +open import parametricity2-defs + +open import preservation +open import ground-dec +open import lemmas-consistency +open import lemmas-wf +open import eq-dec +open import lemmas-ground + +module parametricity2-lemmas2 where + + {- These inductions are valid because the syntactic size decreases every time except in the expand+ground case -} + useless-cast-cases : ∀{d d1 τ2} → + d1 =0cr d → ∅ ⊢ τ2 wf → τ2 ≠ ⦇-⦈ → + ∅ ⊢ d :: ⦇-⦈ → + ((d' : ihexp) → (τ τ' : htyp) → d ≠ (d' ⟨ τ ⇒ τ' ⟩)) → d final → + Σ[ d' ∈ ihexp ] ( (d1 =0cr d') × ((d ⟨ ⦇-⦈ ⇒ τ2 ⟩) ⟨ τ2 ⇒ ⦇-⦈ ⟩) ↦* d' × d' final) + useless-cast-cases {τ2 = τ2} eq0 _ _ () form (FBoxedVal (BVVal VConst)) + useless-cast-cases {τ2 = τ2} eq0 _ _ () form (FBoxedVal (BVVal VLam)) + useless-cast-cases {τ2 = τ2} eq0 _ _ () form (FBoxedVal (BVVal VTLam)) + useless-cast-cases {τ2 = τ2} eq0 _ _ wt form (FBoxedVal (BVHoleCast {τ = τ} {d = d} x x₁)) = abort (form d τ ⦇-⦈ refl) + useless-cast-cases {τ2 = τ2} eq0 wf ne wt form (FIndet x) with ground-dec τ2 + ... | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , fin-gndhole-lemma (FIndet (ICastHoleGround (λ d' τ' → form d' τ' ⦇-⦈) x gnd)) gnd + ... | Inr gnd with ground-match-exists gnd wf ne + useless-cast-cases {τ2 = τ2 ==> τ3} eq0 wf ne wt form (FIndet x) | Inr gnd | τ' ==> τ'' , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR (Eq0CastR eq0))) , + MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) (MSStep (Step FHOuter (ITGround gnd') FHOuter) MSRefl) , + FIndet (ICastGroundHole (ground-match gnd') (ICastArr (ground-match-neq gnd') (ICastArr (flip (ground-match-neq gnd')) (ICastHoleGround (λ d' τ' → form d' τ' ⦇-⦈) x (ground-match gnd'))))) + useless-cast-cases {τ2 = ·∀ τ2} eq0 wf ne wt form (FIndet x) | Inr gnd | ·∀ τ' , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR (Eq0CastR eq0))) , + MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) (MSStep (Step FHOuter (ITGround gnd') FHOuter) MSRefl) , + FIndet (ICastGroundHole (ground-match gnd') (ICastForall (ground-match-neq gnd') (ICastForall (flip (ground-match-neq gnd')) (ICastHoleGround (λ d' τ' → form d' τ' ⦇-⦈) x (ground-match gnd'))))) + + case-helper : ∀{d τ1} → + (d ⟨ τ1 ⇒ ⦇-⦈ ⟩) final → τ1 ≠ ⦇-⦈ + case-helper (FBoxedVal (BVHoleCast x x₁)) = ground-not-hole x + case-helper (FIndet (ICastGroundHole x x₁)) = ground-not-hole x + + fin-ground-cast : ∀{d τ τ'} → + d final → τ ▸gnd τ' → (d ⟨ τ ⇒ τ' ⟩) final + fin-ground-cast (FBoxedVal x) (MGArr x₁) = FBoxedVal (BVArrCast x₁ x) + fin-ground-cast (FBoxedVal x) (MGForall x₁) = FBoxedVal (BVForallCast x₁ x) + fin-ground-cast (FIndet x) (MGArr x₁) = FIndet (ICastArr x₁ x) + fin-ground-cast (FIndet x) (MGForall x₁) = FIndet (ICastForall x₁ x) + + fin-ground-cast' : ∀{d τ τ'} → + d final → τ' ▸gnd τ → (d ⟨ τ ⇒ τ' ⟩) final + fin-ground-cast' (FBoxedVal x) (MGArr x₁) = FBoxedVal (BVArrCast (flip x₁) x) + fin-ground-cast' (FBoxedVal x) (MGForall x₁) = FBoxedVal (BVForallCast (flip x₁) x) + fin-ground-cast' (FIndet x) (MGArr x₁) = FIndet (ICastArr (flip x₁) x) + fin-ground-cast' (FIndet x) (MGForall x₁) = FIndet (ICastForall (flip x₁) x) + + mutual + parametricity-onesided-lemma-doublecast-case : ∀{d1 τ d2 τ1 τ2 τ3} → + τ1 ≠ τ2 → τ2 ≠ τ3 → τ2 ≠ ⦇-⦈ → + ∅ ⊢ d1 :: τ → + ∅ ⊢ (d2 ⟨ τ1 ⇒ τ2 ⟩) ⟨ τ2 ⇒ τ3 ⟩ :: τ3 → + d1 =0cr d2 → + d1 val → + d2 final → + Σ[ d2' ∈ ihexp ] (d1 =0cr d2' × ((d2 ⟨ τ1 ⇒ τ2 ⟩) ⟨ τ2 ⇒ τ3 ⟩)↦* d2' × d2' final) + parametricity-onesided-lemma-doublecast-case {τ1 = τ1} {τ3 = _} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ x₃) x ConsistHole2) eq0 v fin = abort (neq'' refl) + parametricity-onesided-lemma-doublecast-case {τ1 = τ1} {τ3 = b} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ x₃) x ConsistBase) eq0 v fin = abort (neq' refl) + parametricity-onesided-lemma-doublecast-case {τ1 = .b} {τ2 = b} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ ConsistBase) x x₁) eq0 v fin = abort (neq refl) + parametricity-onesided-lemma-doublecast-case {τ1 = τ1} {τ2 = ⦇-⦈} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ x₃) x x₁) eq0 v fin = abort (neq' refl) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast wt2₀@(TACast (TACast wt2 x₃ x₄) x₂ ConsistHole2) x x₁) (Eq0CastR eq0) v fin + with parametricity-onesided-lemma-holecast-case (case-helper fin) neq'' wt1 wt2₀ eq0 v (fin-gndhole-lemma' fin) + ... | d2' , eq0' , steps , fin with ground-dec τ2 + ... | Inl gnd = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-gndhole-lemma fin gnd + ... | Inr gnd with ground-match-exists gnd x₂ neq'' + parametricity-onesided-lemma-doublecast-case {τ = _} {_} {.⦇-⦈} {τ2 = τ2 ==> τ3} {⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TACast wt2 x₃ x₄) x₂ ConsistHole2) x x₁) (Eq0CastR eq0) v fin₁ + | d2' , eq0' , steps , fin | Inr gnd | (_ ==> _) , gnd' = _ , Eq0CastR (Eq0CastR eq0') , MSStep (Step FHOuter (ITGround gnd') FHOuter) (evalctx-compose-ms steps (FHCast (FHCast FHOuter)) (FHCast (FHCast FHOuter))) , fin-gndhole-lemma (fin-arr-lemma fin (ground-match-neq gnd')) (ground-match gnd') + parametricity-onesided-lemma-doublecast-case {τ = _} {_} {.⦇-⦈} {τ2 = ·∀ τ2} {⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TACast wt2 x₃ x₄) x₂ ConsistHole2) x x₁) (Eq0CastR eq0) v fin₁ + | d2' , eq0' , steps , fin | Inr gnd | (·∀ _) , gnd' = _ , Eq0CastR (Eq0CastR eq0') , MSStep (Step FHOuter (ITGround gnd') FHOuter) (evalctx-compose-ms steps (FHCast (FHCast FHOuter)) (FHCast (FHCast FHOuter))) , fin-gndhole-lemma (fin-forall-lemma fin (ground-match-neq gnd')) (ground-match gnd') + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) x₂ ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal ())) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TATAp x₃ wt2 x₄) x₂ ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal ())) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) x₂ ConsistHole2) x x₁) eq0 v (FIndet x₃) with ground-dec τ2 + ... | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , FIndet (ICastGroundHole gnd (ICastHoleGround (λ d' τ' ()) x₃ gnd)) + ... | Inr gnd with ground-match-exists gnd x₂ neq'' + parametricity-onesided-lemma-doublecast-case {τ = _} {_} {.⦇-⦈} {τ2 = τ2 ==> τ3} {⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) x₂ ConsistHole2) x x₁) eq0 v (FIndet x₃) | Inr gnd | (τ2' ==> τ2'') , gnd' = + _ , Eq0CastR (Eq0CastR (Eq0CastR (Eq0CastR eq0))) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) (MSStep (Step FHOuter (ITGround gnd') FHOuter) MSRefl) , FIndet (ICastGroundHole (ground-match gnd') (ICastArr (ground-match-neq gnd') (ICastArr (flip (ground-match-neq gnd')) (ICastHoleGround (λ d' τ' ()) x₃ (ground-match gnd'))))) + parametricity-onesided-lemma-doublecast-case {τ = _} {_} {.⦇-⦈} {τ2 = ·∀ τ2} {⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) x₂ ConsistHole2) x x₁) eq0 v (FIndet x₃) | Inr gnd | (·∀ τ2') , gnd' = + _ , Eq0CastR (Eq0CastR (Eq0CastR (Eq0CastR eq0))) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) (MSStep (Step FHOuter (ITGround gnd') FHOuter) MSRefl) , FIndet (ICastGroundHole (ground-match gnd') (ICastForall (ground-match-neq gnd') (ICastForall (flip (ground-match-neq gnd')) (ICastHoleGround (λ d' τ' ()) x₃ (ground-match gnd'))))) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TATAp x₃ wt2 x₄) x₂ ConsistHole2) x x₁) eq0 v (FIndet x₅) = useless-cast-cases eq0 x₂ neq'' (TATAp x₃ wt2 x₄) (λ d' τ τ' ()) (FIndet x₅) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast TAEHole x₂ ConsistHole2) x x₁) eq0 v fin = useless-cast-cases eq0 x₂ neq'' TAEHole (λ d' τ τ' ()) fin + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast (TANEHole wt2) x₂ ConsistHole2) x x₁) eq0 v fin = useless-cast-cases eq0 x₂ neq'' (TANEHole wt2) (λ d' τ τ' ()) fin + parametricity-onesided-lemma-doublecast-case {τ1 = τ1 ==> τ1'} {τ2 = τ2 ==> τ3} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ (ConsistArr x₃ x₄)) x x₁) eq0 v fin with ground-dec (τ2 ==> τ3) + ... | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , fin-gndhole-lemma (fin-arr-lemma fin neq) gnd + ... | Inr gnd with ground-match-exists gnd x₂ neq'' + ... | (τ2' ==> τ3') , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step FHOuter (ITGround gnd') FHOuter) MSRefl , fin-gndhole-lemma (fin-arr-lemma (fin-arr-lemma fin neq) (ground-match-neq gnd')) (ground-match gnd') + parametricity-onesided-lemma-doublecast-case {τ1 = ·∀ τ1} {τ2 = ·∀ τ2} {τ3 = ⦇-⦈} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ (ConsistForall x₃)) x x₁) eq0 v fin with ground-dec (·∀ τ2) + ... | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , fin-gndhole-lemma (fin-forall-lemma fin neq) gnd + ... | Inr gnd with ground-match-exists gnd x₂ neq'' + ... | (·∀ τ2') , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step FHOuter (ITGround gnd') FHOuter) MSRefl , fin-gndhole-lemma (fin-forall-lemma (fin-forall-lemma fin neq) (ground-match-neq gnd')) (ground-match gnd') + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ1 ==> τ2} {τ3 = τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal x₅) with ground-dec (τ1 ==> τ2) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast () x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal (BVVal VConst)) | Inl gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast () x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal (BVVal VLam)) | Inl gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast () x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal (BVVal VTLam)) | Inl gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ ConsistHole2) x (ConsistArr x₁ x₄)) (Eq0CastR eq0) v + (FBoxedVal (BVHoleCast x₃ x₅)) | _ with parametricity-onesided-lemma-holecast-case (ground-not-hole x₃) neq'' wt1 ((TACast wt2 x₂ ConsistHole2)) eq0 v (FBoxedVal x₅) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-arr-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast () x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal (BVVal VConst)) | Inr gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast () x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal (BVVal VLam)) | Inr gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast () x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal (BVVal VTLam)) | Inr gnd + parametricity-onesided-lemma-doublecast-case {τ1 = .(_ ==> _)} {τ3 = τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ (ConsistArr x₃ x₆)) x (ConsistArr x₁ x₄)) eq0 v (FBoxedVal x₅) = _ , (Eq0CastR (Eq0CastR eq0)) , MSRefl , FBoxedVal (BVArrCast neq' (BVArrCast neq x₅)) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ1 ==> τ2} {τ3 = τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) with ground-dec (τ1 ==> τ2) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet (IAp x₃ x₅ x₆)) | Inl gnd = _ , (Eq0CastR (Eq0CastR eq0)) , MSRefl , FIndet (ICastArr neq' (ICastHoleGround (λ d' τ' ()) (IAp x₃ x₅ x₆) gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast (TATAp x₃ wt2 x₆) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet (ITAp x₅ x₇)) | Inl gnd = _ , (Eq0CastR (Eq0CastR eq0)) , MSRefl , FIndet (ICastArr neq' (ICastHoleGround (λ d' τ' ()) (ITAp x₅ x₇) gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast TAEHole x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) | Inl gnd = _ , (Eq0CastR (Eq0CastR eq0)) , MSRefl , FIndet (ICastArr neq' (ICastHoleGround (λ d' τ' ()) x₅ gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast (TANEHole wt2) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) | Inl gnd = _ , (Eq0CastR (Eq0CastR eq0)) , MSRefl , FIndet (ICastArr neq' (ICastHoleGround (λ d' τ' ()) x₅ gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast wt2₀@(TACast (TACast wt2 x₃ x₆) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) (Eq0CastR eq0) v (FIndet (ICastGroundHole x₅ x₇)) + | Inl gnd with parametricity-onesided-lemma-holecast-case (ground-not-hole x₅) neq'' wt1 wt2₀ eq0 v (FIndet x₇) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-arr-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = τ1 ==> τ2} {τ3 = τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) + | Inr gnd with ground-match-exists gnd x₂ neq'' + parametricity-onesided-lemma-doublecast-case {d2 = .(_ ∘ _)} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) | Inr gnd | τg ==> τg₁ , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , FIndet (ICastArr neq' (ICastArr (gnd-ngnd-neq (ground-match gnd') gnd) (ICastHoleGround (λ d' τ' ()) x₅ (ground-match gnd')))) + parametricity-onesided-lemma-doublecast-case {d2 = .(_ < _ >)} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast (TATAp x₃ wt2 x₆) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) | Inr gnd | τg ==> τg₁ , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , FIndet (ICastArr neq' (ICastArr (gnd-ngnd-neq (ground-match gnd') gnd) (ICastHoleGround (λ d' τ' ()) x₅ (ground-match gnd')))) + parametricity-onesided-lemma-doublecast-case {d2 = .⦇-⦈} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast TAEHole x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) | Inr gnd | τg ==> τg₁ , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , FIndet (ICastArr neq' (ICastArr (gnd-ngnd-neq (ground-match gnd') gnd) (ICastHoleGround (λ d' τ' ()) x₅ (ground-match gnd')))) + parametricity-onesided-lemma-doublecast-case {d2 = .(⦇⌜ _ ⌟⦈)} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast (TANEHole wt2) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) | Inr gnd | τg ==> τg₁ , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , FIndet (ICastArr neq' (ICastArr (gnd-ngnd-neq (ground-match gnd') gnd) (ICastHoleGround (λ d' τ' ()) x₅ (ground-match gnd')))) + parametricity-onesided-lemma-doublecast-case {d2 = .(_ ⟨ _ ⇒ ⦇-⦈ ⟩)} {.⦇-⦈} {τ1 ==> τ2} {τ3 ==> τ4} neq neq' neq'' wt1 (TACast wt2₀@(TACast (TACast wt2 x₃ x₆) x₂ ConsistHole2) x (ConsistArr x₁ x₄)) (Eq0CastR eq0) v (FIndet (ICastGroundHole x₅ x₇)) + | Inr gnd | τg ==> τg₁ , gnd' with parametricity-onesided-lemma-holecast-case (ground-not-hole x₅) neq'' wt1 wt2₀ eq0 v (FIndet x₇) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-arr-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {τ1 = .(_ ==> _)} {τ3 = τ3 ==> τ4} neq neq' neq'' wt1 (TACast (TACast wt2 x₂ (ConsistArr x₃ x₆)) x (ConsistArr x₁ x₄)) eq0 v (FIndet x₅) = _ , (Eq0CastR (Eq0CastR eq0)) , MSRefl , FIndet (ICastArr neq' (ICastArr neq x₅)) + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = ·∀ τ2} {τ3 = ·∀ τ3} neq neq' neq'' wt1 (TACast (TACast wt2 (WFForall x₂) ConsistHole2) x x₁) eq0 v fin with ground-dec (·∀ τ2) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast () (WFForall x₂) ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal VConst)) | Inl gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast () (WFForall x₂) ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal VLam)) | Inl gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast () (WFForall x₂) ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal VTLam)) | Inl gnd + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast wt2₀@(TACast wt2 (WFForall x₂) ConsistHole2) x x₁) (Eq0CastR eq0) v (FBoxedVal (BVHoleCast x₃ x₄)) + | Inl gnd with parametricity-onesided-lemma-holecast-case (ground-not-hole x₃) neq'' wt1 wt2₀ eq0 v (FBoxedVal x₄) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-forall-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet x₃) | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , FIndet (ICastForall neq' (ICastHoleGround (λ d' τ' ()) x₃ gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast (TATAp x₄ wt2 x₅) (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet x₃) | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , FIndet (ICastForall neq' (ICastHoleGround (λ d' τ' ()) x₃ gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast TAEHole (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet x₃) | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , FIndet (ICastForall neq' (ICastHoleGround (λ d' τ' ()) x₃ gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast (TANEHole wt2) (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet x₃) | Inl gnd = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , FIndet (ICastForall neq' (ICastHoleGround (λ d' τ' ()) x₃ gnd)) + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast wt2₀@(TACast (TACast wt2 x₄ x₅) (WFForall x₂) ConsistHole2) x x₁) (Eq0CastR eq0) v (FIndet (ICastGroundHole x₃ x₆)) + | Inl gnd with parametricity-onesided-lemma-holecast-case (ground-not-hole x₃) neq'' wt1 wt2₀ eq0 v (FIndet x₆) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-forall-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {τ1 = .⦇-⦈} {τ2 = ·∀ τ2} {τ3 = ·∀ τ3} neq neq' neq'' wt1 (TACast (TACast wt2 (WFForall x₂) ConsistHole2) x x₁) eq0 v fin + | Inr gnd with ground-match-exists gnd (WFForall x₂) neq'' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast () (WFForall x₂) ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal VConst)) | Inr gnd | ·∀ τ2' , gnd' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast () (WFForall x₂) ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal VLam)) | Inr gnd | ·∀ τ2' , gnd' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast () (WFForall x₂) ConsistHole2) x x₁) eq0 v (FBoxedVal (BVVal VTLam)) | Inr gnd | ·∀ τ2' , gnd' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast wt2₀@(TACast wt2 (WFForall x₂) ConsistHole2) x x₁) (Eq0CastR eq0) v (FBoxedVal (BVHoleCast x₃ x₄)) + | Inr gnd | ·∀ τ2' , gnd' with parametricity-onesided-lemma-holecast-case (ground-not-hole x₃) neq'' wt1 wt2₀ eq0 v (FBoxedVal x₄) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-forall-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast TAEHole (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet IEHole) | Inr gnd | ·∀ τ2' , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , fin-forall-lemma (fin-forall-lemma (FIndet (ICastHoleGround (λ d' τ' ()) IEHole (ground-match gnd'))) (flip (ground-match-neq gnd'))) neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast (TANEHole wt2) (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet (INEHole x₃)) | Inr gnd | ·∀ τ2' , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , fin-forall-lemma (fin-forall-lemma (FIndet (ICastHoleGround (λ d' τ' ()) (INEHole x₃) (ground-match gnd'))) (flip (ground-match-neq gnd'))) neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast (TAAp wt2 wt3) (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet (IAp x₃ x₄ x₅)) | Inr gnd | ·∀ τ2' , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , fin-forall-lemma (fin-forall-lemma (FIndet (ICastHoleGround (λ d' τ' ()) (IAp x₃ x₄ x₅) (ground-match gnd'))) (flip (ground-match-neq gnd'))) neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast (TACast (TATAp x₃ wt2 x₄) (WFForall x₂) ConsistHole2) x x₁) eq0 v (FIndet (ITAp x₅ x₆)) | Inr gnd | ·∀ τ2' , gnd' = _ , Eq0CastR (Eq0CastR (Eq0CastR eq0)) , MSStep (Step (FHCast FHOuter) (ITExpand gnd') (FHCast FHOuter)) MSRefl , fin-forall-lemma (fin-forall-lemma (FIndet (ICastHoleGround (λ d' τ' ()) (ITAp x₅ x₆) (ground-match gnd'))) (flip (ground-match-neq gnd'))) neq' + parametricity-onesided-lemma-doublecast-case {d2 = _} {.⦇-⦈} {·∀ τ2} {·∀ τ3} neq neq' neq'' wt1 (TACast wt2₀@(TACast (TACast wt2 x₃ x₄) (WFForall x₂) ConsistHole2) x x₁) (Eq0CastR eq0) v (FIndet (ICastGroundHole x₅ x₆)) + | Inr gnd | ·∀ τ2' , gnd' with parametricity-onesided-lemma-holecast-case (ground-not-hole x₅) neq'' wt1 wt2₀ eq0 v (FIndet x₆) + ... | d2' , eq0' , steps , fin = _ , Eq0CastR eq0' , evalctx-compose-ms steps (FHCast FHOuter) (FHCast FHOuter) , fin-forall-lemma fin neq' + parametricity-onesided-lemma-doublecast-case {τ1 = ·∀ τ1} {τ2 = ·∀ τ2} {τ3 = ·∀ τ3} neq neq' neq'' wt1 (TACast (TACast wt2 (WFForall x₂) (ConsistForall x₃)) x x₁) eq0 v fin + = _ , Eq0CastR (Eq0CastR eq0) , MSRefl , fin-forall-lemma (fin-forall-lemma fin neq) neq' + + parametricity-onesided-lemma-holecast-case : ∀{d1 τ d2 τ1 τ3} → + τ1 ≠ ⦇-⦈ → τ3 ≠ ⦇-⦈ → + ∅ ⊢ d1 :: τ → + ∅ ⊢ (d2 ⟨ τ1 ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ3 ⟩ :: τ3 → + d1 =0cr d2 → + d1 val → + d2 final → + Σ[ d2' ∈ ihexp ] (d1 =0cr d2' × ((d2 ⟨ τ1 ⇒ ⦇-⦈ ⟩) ⟨ ⦇-⦈ ⇒ τ3 ⟩)↦* d2' × d2' final) + parametricity-onesided-lemma-holecast-case {τ1 = τ1} {τ3 = τ3} neq neq' wt1 (TACast (TACast wt2 x₂ x₃) x x₁) eq0 v fin with ground-dec τ1 | ground-dec τ3 + ... | Inl g1 | Inl g2 with ~dec τ1 τ3 + ... | Inl consis rewrite gnd-gnd-consis-eq g1 g2 consis = _ , eq0 , MSStep (Step FHOuter (ITCastSucceed g2) FHOuter) MSRefl , fin + ... | Inr consis = _ , Eq0FailedCastR eq0 , MSStep (Step FHOuter (ITCastFail g1 g2 consis) FHOuter) MSRefl , FIndet (IFailedCast fin g1 g2 (~̸-≠ consis)) + parametricity-onesided-lemma-holecast-case neq neq' wt1 (TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁) eq0 v fin + | Inl g1 | Inr g2 with ground-match-exists g2 x neq' + ... | τ3' , g2' with ~dec τ1 τ3' + ... | Inl consis rewrite gnd-gnd-consis-eq g1 (ground-match g2') consis + = _ , Eq0CastR eq0 , MSStep (Step FHOuter (ITExpand g2') FHOuter) (MSStep (Step (FHCast FHOuter) (ITCastSucceed (ground-match g2')) (FHCast FHOuter)) MSRefl) , fin-ground-cast' fin g2' + ... | Inr consis = _ , Eq0CastR (Eq0FailedCastR eq0) , MSStep (Step FHOuter (ITExpand g2') FHOuter) (MSStep (Step (FHCast FHOuter) (ITCastFail g1 (ground-match g2') consis) (FHCast FHOuter)) MSRefl), fin-ground-cast' (FIndet (IFailedCast fin g1 (ground-match g2') (~̸-≠ consis))) g2' + parametricity-onesided-lemma-holecast-case neq neq' wt1 (TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁) eq0 v fin + | Inr g1 | Inl g2 with ground-match-exists g1 (wf-ta CtxWFEmpty wt2) neq + ... | τ1' , g1' with ~dec τ1' τ3 + ... | Inl consis rewrite ! (gnd-gnd-consis-eq (ground-match g1') g2 consis) + = _ , Eq0CastR eq0 , MSStep (Step (FHCast FHOuter) (ITGround g1') (FHCast FHOuter)) + (MSStep (Step FHOuter (ITCastSucceed (ground-match g1')) FHOuter) MSRefl) , fin-ground-cast fin g1' + ... | Inr consis = _ , Eq0FailedCastR (Eq0CastR eq0) , MSStep (Step (FHCast FHOuter) (ITGround g1') (FHCast FHOuter)) + (MSStep (Step FHOuter (ITCastFail (ground-match g1') g2 consis) FHOuter) MSRefl) , FIndet (IFailedCast (fin-ground-cast fin g1') (ground-match g1') g2 (~̸-≠ consis)) + parametricity-onesided-lemma-holecast-case neq neq' wt1 (wt2₀@(TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁)) eq0 v fin + | Inr g1 | Inr g2 with ground-match-exists g1 (wf-ta CtxWFEmpty wt2) neq | ground-match-exists g2 x neq' + ... | τ1' , g1' | τ3' , g2' with ~dec τ1' τ3' + ... | Inl consis with preservation (preservation (preservation wt2₀ step1) step2) step3 + where + eq = gnd-gnd-consis-eq (ground-match g1') (ground-match g2') consis + step1 = (Step (FHCast FHOuter) (ITGround g1') (FHCast FHOuter)) + step2 = (Step FHOuter (ITExpand g2') FHOuter) + step3 = (Step (FHCast FHOuter) (ITCastSucceed' eq (ground-match g1')) (FHCast FHOuter)) + ... | wt2₀'@(TACast (TACast wt2' _ consis1) _ consis2) with parametricity-onesided-lemma-doublecast-case (ground-match-neq g1') (flip (ground-match-neq g2')) (ground-not-hole (ground-match g2')) wt1 wt2₀' eq0 v fin + ... | d2' , eq0' , steps , fin = d2' , eq0' , MSStep step1 (MSStep step2 (MSStep step3 steps)) , fin + where + eq = (gnd-gnd-consis-eq (ground-match g1') (ground-match g2') consis) + step1 = (Step (FHCast FHOuter) (ITGround g1') (FHCast FHOuter)) + step2 = (Step FHOuter (ITExpand g2') FHOuter) + step3 = (Step (FHCast FHOuter) (ITCastSucceed' eq (ground-match g1')) (FHCast FHOuter)) + parametricity-onesided-lemma-holecast-case neq neq' wt1 (wt2₀@(TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁)) eq0 v fin + | Inr g1 | Inr g2 | τ1' , g1' | τ3' , g2' | Inr consis = + _ , Eq0CastR (Eq0FailedCastR (Eq0CastR eq0)) , + MSStep (Step (FHCast FHOuter) (ITGround g1') (FHCast FHOuter)) + (MSStep (Step FHOuter (ITExpand g2') FHOuter) + (MSStep (Step (FHCast FHOuter) (ITCastFail (ground-match g1') (ground-match g2') consis) (FHCast FHOuter)) MSRefl)) , + fin-ground-cast' (FIndet (IFailedCast (fin-ground-cast fin g1') (ground-match g1') (ground-match g2') (~̸-≠ consis))) g2' + + + {-# TERMINATING #-} + {- The case this complains about is when we resolve an inner cast and have to bring in consistency constraints from an outer cast. -} + {- Now, this is terminating on syntactic size of d2, so that's not an issue. (termination structure TODO) -} + parametricity-onesided-lemma-valr : + ∀{d1 d2 τ1 τ2} → + ∅ ⊢ d1 :: τ1 → + ∅ ⊢ d2 :: τ2 → + d1 =0cr d2 → + d1 val → + Σ[ d2' ∈ ihexp ]( d1 =0cr d2' × d2 ↦* d2' × d2' final) + parametricity-onesided-lemma-valr wt1 (TACast {τ1 = τ1} {τ2 = τ2} wt2 x x₁) (Eq0CastR eq0) v with htyp-eq-dec τ1 τ2 + ... | Inl refl with parametricity-onesided-lemma-valr wt1 wt2 eq0 v + ... | d2' , eq0' , steps , fin = _ , eq0' , MSStep (Step FHOuter ITCastID FHOuter) steps , fin + parametricity-onesided-lemma-valr wt1 (TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁) (Eq0CastR (Eq0CastR eq0)) v | Inr neq with htyp-eq-dec τ1 ⦇-⦈ | htyp-eq-dec τ2 ⦇-⦈ + ... | Inl refl | Inl refl with parametricity-onesided-lemma-valr wt1 (TACast wt2 x x₁) (Eq0CastR eq0) v + ... | d2' , eq0' , steps , fin = _ , eq0' , MSStep (Step (FHCast FHOuter) ITCastID (FHCast FHOuter)) steps , fin + parametricity-onesided-lemma-valr wt1 (TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁) (Eq0CastR (Eq0CastR eq0)) v | Inr neq + | Inr neq' | Inl refl with parametricity-onesided-lemma-valr wt1 wt2 eq0 v + ... | d2' , eq0' , steps , fin with parametricity-onesided-lemma-holecast-case neq' (flip neq) wt1 (TACast (TACast (preservation-trans wt2 steps) x₂ x₃) x x₁) eq0' v fin + ... | d2'' , eq0'' , steps' , fin' = _ , eq0'' , mstrans (evalctx-compose-ms steps (FHCast (FHCast FHOuter)) (FHCast (FHCast FHOuter))) steps' , fin' + parametricity-onesided-lemma-valr wt1 (TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁) (Eq0CastR (Eq0CastR eq0)) v | Inr neq + | _ | Inr neq' with htyp-eq-dec τ1 τ2 + ... | Inl refl with parametricity-onesided-lemma-valr wt1 (TACast wt2 x x₁) (Eq0CastR eq0) v + ... | d2' , eq0' , steps , fin = _ , eq0' , MSStep (Step (FHCast FHOuter) ITCastID (FHCast FHOuter)) steps , fin + parametricity-onesided-lemma-valr wt1 wt2₀@(TACast {τ1 = τ2} {τ2 = τ3} (TACast {τ1 = τ1} wt2 x₂ x₃) x x₁) (Eq0CastR (Eq0CastR eq0)) v | Inr neq | _ | Inr neq' + | Inr neq'' with parametricity-onesided-lemma-valr wt1 wt2 eq0 v + ... | d2' , eq0' , steps , fin with parametricity-onesided-lemma-doublecast-case neq'' neq neq' wt1 (TACast (TACast (preservation-trans wt2 steps) x₂ x₃) x x₁) eq0' v fin + ... | d2'' , eq0'' , steps' , fin' = _ , eq0'' , mstrans (evalctx-compose-ms steps (FHCast (FHCast FHOuter)) (FHCast (FHCast FHOuter))) steps' , fin' + parametricity-onesided-lemma-valr wt1 (TACast (TAFailedCast wt2 x₂ x₃ x₄) x x₁) (Eq0CastR (Eq0FailedCastR eq0)) v | Inr neq with parametricity-onesided-lemma-valr wt1 wt2 eq0 v + parametricity-onesided-lemma-valr wt1 (TACast (TAFailedCast wt2 x₂ x₃ x₄) x ConsistBase) (Eq0CastR (Eq0FailedCastR eq0)) v | Inr neq + | d2' , eq0' , steps , fin = _ , Eq0FailedCastR eq0' , MSStep (Step FHOuter ITCastID FHOuter) (evalctx-compose-ms steps (FHFailedCast FHOuter) (FHFailedCast FHOuter)) , FIndet (IFailedCast fin x₂ x₃ (λ _ → neq refl)) + parametricity-onesided-lemma-valr wt1 (TACast (TAFailedCast wt2 x₂ x₃ x₄) x ConsistHole1) (Eq0CastR (Eq0FailedCastR eq0)) v | Inr neq + | d2' , eq0' , steps , fin = _ , Eq0CastR (Eq0FailedCastR eq0') , (evalctx-compose-ms steps (FHCast (FHFailedCast FHOuter)) (FHCast (FHFailedCast FHOuter))) , FIndet (ICastGroundHole x₃ (IFailedCast fin x₂ x₃ (~̸-≠ x₄))) + parametricity-onesided-lemma-valr wt1 (TACast (TAFailedCast wt2 x₂ x₃ x₄) x (ConsistArr x₁ x₅)) (Eq0CastR (Eq0FailedCastR eq0)) v | Inr neq + | d2' , eq0' , steps , fin = _ , Eq0CastR (Eq0FailedCastR eq0') , (evalctx-compose-ms steps (FHCast (FHFailedCast FHOuter)) (FHCast (FHFailedCast FHOuter))) , FIndet (ICastArr neq (IFailedCast fin x₂ x₃ (~̸-≠ x₄))) + parametricity-onesided-lemma-valr wt1 (TACast (TAFailedCast wt2 x₂ x₃ x₄) x (ConsistForall x₁)) (Eq0CastR (Eq0FailedCastR eq0)) v | Inr neq + | d2' , eq0' , steps , fin = _ , Eq0CastR (Eq0FailedCastR eq0') , (evalctx-compose-ms steps (FHCast (FHFailedCast FHOuter)) (FHCast (FHFailedCast FHOuter))) , FIndet (ICastForall neq (IFailedCast fin x₂ x₃ (~̸-≠ x₄))) + parametricity-onesided-lemma-valr wt1 (TACast wt2 x x₁) (Eq0CastR (Eq0NoCasts eq0)) v | Inr neq with val-cast-final (eq0cn-val-val v eq0) wt2 (wf-ta CtxWFEmpty wt2) x neq x₁ + ... | d2' , Eq0CastL eq0' , steps , fin = d2' , eq0cnr-trans eq0 eq0' , steps , fin + ... | d2' , Eq0NoLeft x₂ , steps , fin = abort (π1 (eq0ccastr-meaning x₂) refl) + parametricity-onesided-lemma-valr {d2 = d2 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩} wt1 (TAFailedCast wt2 x x₁ x₂) (Eq0FailedCastR eq0) v with parametricity-onesided-lemma-valr wt1 wt2 eq0 v + ... | d2' , eq0' , steps , fin = d2' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ , Eq0FailedCastR eq0' , evalctx-compose-ms steps (FHFailedCast FHOuter) (FHFailedCast FHOuter) , FIndet (IFailedCast fin x x₁ (~̸-≠ x₂)) + parametricity-onesided-lemma-valr _ _ (Eq0NoCasts Eq0Const) VConst = _ , Eq0NoCasts Eq0Const , MSRefl , FBoxedVal (BVVal VConst) + parametricity-onesided-lemma-valr _ _ (Eq0NoCasts (Eq0Lam eq0')) VLam = _ , Eq0NoCasts (Eq0Lam eq0') , MSRefl , FBoxedVal (BVVal VLam) + parametricity-onesided-lemma-valr _ _ (Eq0NoCasts (Eq0TLam eq0')) VTLam = _ , Eq0NoCasts (Eq0TLam eq0') , MSRefl , FBoxedVal (BVVal VTLam) + + helper : ∀{d1 d2} → + Σ[ d2' ∈ ihexp ]( d1 =0cr d2' × d2 ↦* d2' × d2' final) → + Σ[ d2' ∈ ihexp ]( d1 =0c d2' × d2 ↦* d2' × d2' final) + helper (x0 , x1 , x2 , x3) = (x0 , Eq0NoLeft x1 , x2 , x3) + + parametricity-onesided-lemma-val : + ∀{d1 d2 τ1 τ2} → + ∅ ⊢ d1 :: τ1 → + ∅ ⊢ d2 :: τ2 → + d1 =0c d2 → + d1 val → + Σ[ d2' ∈ ihexp ]( d1 =0c d2' × d2 ↦* d2' × d2' final) + parametricity-onesided-lemma-val wt1 wt2 (Eq0NoLeft x) VConst = helper (parametricity-onesided-lemma-valr wt1 wt2 x VConst) + parametricity-onesided-lemma-val wt1 wt2 (Eq0NoLeft x) VLam = helper (parametricity-onesided-lemma-valr wt1 wt2 x VLam) + parametricity-onesided-lemma-val wt1 wt2 (Eq0NoLeft x) VTLam = helper (parametricity-onesided-lemma-valr wt1 wt2 x VTLam) + + parametricity-onesided-lemma : + ∀{d1 d2 τ1 τ2} → + ∅ ⊢ d1 :: τ1 → + ∅ ⊢ d2 :: τ2 → + d1 =0c d2 → + d1 boxedval → + Σ[ d2' ∈ ihexp ]( d1 =0c d2' × d2 ↦* d2' × d2' final) + parametricity-onesided-lemma wt1 wt2 eq0 (BVVal x) = parametricity-onesided-lemma-val wt1 wt2 eq0 x + parametricity-onesided-lemma (TACast wt1 x₁ x₂) wt2 (Eq0CastL eq0) (BVArrCast x bv) with parametricity-onesided-lemma wt1 wt2 eq0 bv + ... | (d2' , eq0' , steps , fin) = d2' , Eq0CastL eq0' , steps , fin + parametricity-onesided-lemma wt1 wt2 (Eq0NoLeft x₁) (BVArrCast x bv) = abort (π1 (eq0ccastr-meaning x₁) refl) + parametricity-onesided-lemma (TACast wt1 x₁ x₂) wt2 (Eq0CastL eq0) (BVForallCast x bv) with parametricity-onesided-lemma wt1 wt2 eq0 bv + ... | (d2' , eq0' , steps , fin) = d2' , Eq0CastL eq0' , steps , fin + parametricity-onesided-lemma wt1 wt2 (Eq0NoLeft x₁) (BVForallCast x bv) = abort (π1 (eq0ccastr-meaning x₁) refl) + parametricity-onesided-lemma (TACast wt1 x₁ x₂) wt2 (Eq0CastL eq0) (BVHoleCast x bv) with parametricity-onesided-lemma wt1 wt2 eq0 bv + ... | (d2' , eq0' , steps , fin) = d2' , Eq0CastL eq0' , steps , fin + parametricity-onesided-lemma wt1 wt2 (Eq0NoLeft x₁) (BVHoleCast x bv) = abort (π1 (eq0ccastr-meaning x₁) refl) + diff --git a/parametricity2.agda b/parametricity2.agda new file mode 100644 index 0000000..a75496f --- /dev/null +++ b/parametricity2.agda @@ -0,0 +1,48 @@ +open import Nat +open import Prelude +open import core +open import core-type +open import core-exp + +open import parametricity2-defs +open import parametricity2-lemmas1 +open import parametricity2-lemmas2 + +open import preservation +open import progress-checks + +module parametricity2 where + + parametricity21 : + ∀{d1 d2 v1 τ1 τ2} → + ∅ ⊢ d1 :: τ1 → + ∅ ⊢ d2 :: τ2 → + d1 =0c d2 → + d1 ↦* v1 → + v1 boxedval → + Σ[ v2 ∈ ihexp ]( d2 ↦* v2 × ((v2 boxedval × v1 =0c v2) + v2 indet )) + parametricity21 wt1 wt2 eq0 MSRefl bv with parametricity-onesided-lemma wt1 wt2 eq0 bv + ... | d2' , eq0' , steps , FBoxedVal x = d2' , steps , Inl (x , eq0') + ... | d2' , eq0' , steps , FIndet x = d2' , steps , Inr x + parametricity21 wt1 wt2 eq0 (MSStep x step) bv with parametricity21-lemma-ctx wt1 wt2 eq0 x + ... | d2' , steps , Inr x₁ = d2' , steps , Inr x₁ + ... | d2' , steps , Inl x₁ with parametricity21 (preservation wt1 x) (preservation-trans wt2 steps) x₁ step bv + ... | v2 , steps' , next = v2 , mstrans steps steps' , next + + parametricity22 : + ∀{d1 d2 v1 v2 τ1 τ2} → + confluence → + ∅ ⊢ d1 :: τ1 → + ∅ ⊢ d2 :: τ2 → + d1 =0c d2 → + d1 ↦* v1 → + d2 ↦* v2 → + v1 boxedval → + v2 boxedval → + v1 =0c v2 + parametricity22 conf wt1 wt2 eq0 steps1 steps2 bv1 bv2 + with parametricity21 wt1 wt2 eq0 steps1 bv1 + ... | d2' , steps2' , Inl (bv2' , eq0') with confluence-implies-unique-normal-form conf steps2 steps2' (FBoxedVal bv2) (FBoxedVal bv2') + ... | refl = eq0' + parametricity22 conf wt1 wt2 eq0 steps1 steps2 bv1 bv2 | d2' , steps2' , Inr ind with confluence-implies-unique-normal-form conf steps2 steps2' (FBoxedVal bv2) (FIndet ind) + ... | refl = abort (boxedval-not-indet bv2 ind) diff --git a/postulates.sh b/postulates.sh deleted file mode 100755 index 5b11fe1..0000000 --- a/postulates.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/bash - -grep --color=auto -A 1 'postulate' *.agda - -echo "---------------------------------------------------------------------------------------" -echo "used in:" -echo "---------------------------------------------------------------------------------------" - -grep --color=auto "open import structural-assumptions" *.agda | cut -d ':' -f 1,1 | sort | uniq diff --git a/preci-trans.agda b/preci-trans.agda new file mode 100644 index 0000000..7ca1848 --- /dev/null +++ b/preci-trans.agda @@ -0,0 +1,44 @@ +open import Nat +open import Prelude +open import core-type +open import core-exp +open import core +open import lemmas-index +open import lemmas-consistency +open import lemmas-prec +open import lemmas-meet +open import lemmas-wf +open import typed-elaboration +open import type-assignment-unicity + +module preci-trans where + + ⊑i-trans : ∀{Θ Γ1 Γ2 Γ3 d1 d2 d3} → Γ1 ⊑c Γ2 → Γ2 ⊑c Γ3 → Θ , Γ1 , Γ2 ⊢ d1 ⊑i d2 → Θ , Γ2 , Γ3 ⊢ d2 ⊑i d3 → Θ , Γ1 , Γ3 ⊢ d1 ⊑i d3 + ⊑i-trans precc1 precc2 prec1 (PIEHole wt prec2) = PIEHole {! !} {! !} + ⊑i-trans precc1 precc2 (PIBlame TAConst PTBase) PIConst = PIBlame TAConst PTBase + ⊑i-trans precc1 precc2 (PIBlame (TAVar inctx) prec) PIVar with ⊑c-var inctx precc2 + ... | τ , inctx' , prec' = PIBlame (TAVar inctx') (⊑t-trans prec prec') + ⊑i-trans precc1 precc2 (PIBlame (TALam x₁ wt) prec1) (PILam prec2 x) = PIBlame (TALam (wf-⊑t x₁ x) {! !}) {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PITLam prec2) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PINEHole prec2 x) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PIAp prec2 prec3) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PITAp prec2 x) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PICast prec2 x x₁) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PIFailedCast prec2 x x₁) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PIRemoveCast prec2 x x₁ x₂) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PIAddCast prec2 x x₁ x₂) = {! !} + ⊑i-trans precc1 precc2 (PIBlame wt prec1) (PIBlame x x₁) = {! !} + ⊑i-trans precc1 precc2 PIConst PIConst = {! !} + ⊑i-trans precc1 precc2 (PIRemoveCast prec1 x x₁ x₂) PIConst = {! !} + ⊑i-trans precc1 precc2 prec1 PIVar = {! !} + ⊑i-trans precc1 precc2 (PILam prec1 prec2) (PILam prec3 prec4) = PILam (⊑i-trans (PCExtend prec2 precc1) (PCExtend prec4 precc2) prec1 prec3) (⊑t-trans prec2 prec4) + ⊑i-trans precc1 precc2 (PIRemoveCast prec1 x₁ x₂ x₃) (PILam prec2 x) = {! !} + ⊑i-trans precc1 precc2 prec1 (PITLam prec2) = {! !} + ⊑i-trans precc1 precc2 prec1 (PINEHole prec2 x) = {! !} + ⊑i-trans precc1 precc2 prec1 (PIAp prec2 prec3) = {! !} + ⊑i-trans precc1 precc2 prec1 (PITAp prec2 x) = {! !} + ⊑i-trans precc1 precc2 prec1 (PICast prec2 x x₁) = {! !} + ⊑i-trans precc1 precc2 prec1 (PIFailedCast prec2 x x₁) = {! !} + ⊑i-trans precc1 precc2 prec1 (PIRemoveCast prec2 x x₁ x₂) = {! !} + ⊑i-trans precc1 precc2 prec1 (PIAddCast prec2 x x₁ x₂) = {! !} + ⊑i-trans precc1 precc2 prec1 (PIBlame x x₁) = {! !} \ No newline at end of file diff --git a/preservation.agda b/preservation.agda index e6d38a1..4e69b25 100644 --- a/preservation.agda +++ b/preservation.agda @@ -1,100 +1,74 @@ -open import Nat open import Prelude +open import core-type open import core -open import contexts open import lemmas-consistency -open import type-assignment-unicity -open import binders-disjoint-checks +open import lemmas-wf +open import lemmas-subst +open import typing-subst -open import lemmas-subst-ta +open import type-assignment-unicity module preservation where - -- if d and d' both result from filling the hole in ε with terms of the - -- same type, they too have the same type. - wt-different-fill : ∀{ Δ Γ d ε d1 d2 d' τ τ1 } → - d == ε ⟦ d1 ⟧ → - Δ , Γ ⊢ d :: τ → - Δ , Γ ⊢ d1 :: τ1 → - Δ , Γ ⊢ d2 :: τ1 → - d' == ε ⟦ d2 ⟧ → - Δ , Γ ⊢ d' :: τ - wt-different-fill FHOuter D1 D2 D3 FHOuter - with type-assignment-unicity D1 D2 - ... | refl = D3 - wt-different-fill (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (wt-different-fill eps D1 D3 D4 D5) D2 - wt-different-fill (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (wt-different-fill eps D2 D3 D4 D5) - wt-different-fill (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (wt-different-fill eps D1 D2 D3 D4) x₁ - wt-different-fill (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (wt-different-fill eps D1 D2 D3 D4) x - wt-different-fill (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (wt-different-fill x y D3 D4 eps) x₁ x₂ x₃ - - -- if a well typed term results from filling the hole in ε, then the term - -- that filled the hole is also well typed - wt-filling : ∀{ ε Δ Γ d τ d' } → - Δ , Γ ⊢ d :: τ → - d == ε ⟦ d' ⟧ → - Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ') - wt-filling TAConst FHOuter = _ , TAConst - wt-filling (TAVar x₁) FHOuter = _ , TAVar x₁ - wt-filling (TALam f ta) FHOuter = _ , TALam f ta - wt-filling (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁ - wt-filling (TAAp ta ta₁) (FHAp1 eps) = wt-filling ta eps - wt-filling (TAAp ta ta₁) (FHAp2 eps) = wt-filling ta₁ eps + wt-filling : ∀{ ε Γ d τ d' } → + Γ ⊢ d :: τ → + d == ε ⟦ d' ⟧ → + Σ[ τ' ∈ htyp ] (Γ ⊢ d' :: τ') + wt-filling wt FHOuter = _ , wt + wt-filling (TAAp wt _) (FHAp1 fill) = wt-filling wt fill + wt-filling (TAAp _ wt) (FHAp2 fill) = wt-filling wt fill + wt-filling (TATAp _ wt _) (FHTAp fill) = wt-filling wt fill + wt-filling (TANEHole wt) (FHNEHole fill) = wt-filling wt fill + wt-filling (TACast wt _ _) (FHCast fill) = wt-filling wt fill + wt-filling (TAFailedCast wt _ _ _) (FHFailedCast fill) = wt-filling wt fill - wt-filling (TAEHole x x₁) FHOuter = _ , TAEHole x x₁ - wt-filling (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁ - wt-filling (TANEHole x ta x₁) (FHNEHole eps) = wt-filling ta eps - wt-filling (TACast ta x) FHOuter = _ , TACast ta x - wt-filling (TACast ta x) (FHCast eps) = wt-filling ta eps - wt-filling (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w - wt-filling (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = wt-filling x y + wt-different-fill : ∀{ Γ d ε d1 d2 d' τ1 τ2} → + d == ε ⟦ d1 ⟧ → + d' == ε ⟦ d2 ⟧ → + Γ ⊢ d :: τ1 → + Γ ⊢ d1 :: τ2 → + Γ ⊢ d2 :: τ2 → + Γ ⊢ d' :: τ1 + wt-different-fill FHOuter FHOuter wt wt2 wt3 rewrite type-assignment-unicity wt wt2 = wt3 + wt-different-fill (FHAp1 fill1) (FHAp1 fill2) (TAAp wt wt1) wt2 wt3 = TAAp (wt-different-fill fill1 fill2 wt wt2 wt3) wt1 + wt-different-fill (FHAp2 fill1) (FHAp2 fill2) (TAAp wt wt1) wt2 wt3 = TAAp wt (wt-different-fill fill1 fill2 wt1 wt2 wt3) + wt-different-fill (FHTAp fill1) (FHTAp fill2) (TATAp x wt sub) wt2 wt3 = TATAp x (wt-different-fill fill1 fill2 wt wt2 wt3) sub + wt-different-fill (FHNEHole fill1) (FHNEHole fill2) (TANEHole wt) wt2 wt3 = TANEHole (wt-different-fill fill1 fill2 wt wt2 wt3) + wt-different-fill (FHCast fill1) (FHCast fill2) (TACast wt wf con) wt2 wt3 = TACast (wt-different-fill fill1 fill2 wt wt2 wt3) wf con + wt-different-fill (FHFailedCast fill1) (FHFailedCast fill2) (TAFailedCast wt gnd1 gnd2 incon) wt2 wt3 = TAFailedCast (wt-different-fill fill1 fill2 wt wt2 wt3) gnd1 gnd2 incon -- instruction transitions preserve type - preserve-trans : ∀{ Δ Γ d τ d' } → - binders-unique d → - Δ , Γ ⊢ d :: τ → - d →> d' → - Δ , Γ ⊢ d' :: τ - preserve-trans bd TAConst () - preserve-trans bd (TAVar x₁) () - preserve-trans bd (TALam _ ta) () - preserve-trans (BUAp (BULam bd x₁) bd₁ (BDLam x₂ x₃)) (TAAp (TALam apt ta) ta₁) ITLam = lem-subst apt x₂ bd₁ ta ta₁ - preserve-trans bd (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl - preserve-trans bd (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁ - preserve-trans bd (TAEHole x x₁) () - preserve-trans bd (TANEHole x ta x₁) () - preserve-trans bd (TACast ta x) (ITCastID) = ta - preserve-trans bd (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta - preserve-trans bd (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1 - preserve-trans bd (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2) - preserve-trans bd (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z - preserve-trans bd (TAFailedCast x y z q) () - - lem-bd-ε1 : ∀{ d ε d0} → d == ε ⟦ d0 ⟧ → binders-unique d → binders-unique d0 - lem-bd-ε1 FHOuter bd = bd - lem-bd-ε1 (FHAp1 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd - lem-bd-ε1 (FHAp2 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd₁ - lem-bd-ε1 (FHNEHole eps) (BUNEHole bd x) = lem-bd-ε1 eps bd - lem-bd-ε1 (FHCast eps) (BUCast bd) = lem-bd-ε1 eps bd - lem-bd-ε1 (FHFailedCast eps) (BUFailedCast bd) = lem-bd-ε1 eps bd - - -- this is the main preservation theorem, gluing together the above - preservation : {Δ : hctx} {d d' : ihexp} {τ : htyp} {Γ : tctx} → - binders-unique d → - Δ , Γ ⊢ d :: τ → - d ↦ d' → - Δ , Γ ⊢ d' :: τ - preservation bd D (Step x x₁ x₂) - with wt-filling D x - ... | (_ , wt) = wt-different-fill x D wt (preserve-trans (lem-bd-ε1 x bd) wt x₁) x₂ + preserve-trans : ∀{ d d' τ } → + ∅ ⊢ d :: τ → + d →> d' → + ∅ ⊢ d' :: τ + preserve-trans TAConst () + preserve-trans (TAVar x) () + preserve-trans (TALam x wt) () + preserve-trans (TATLam wt) () + preserve-trans (TAAp (TALam wf wt1) wt2) ITLam = wt-ttSub wt2 wt1 + preserve-trans (TAAp (TACast wt1 (WFArr _ wf1) (ConsistArr con1 con2)) wt2) ITApCast with wf-ta CtxWFEmpty wt1 + ... | WFArr wf2 _ = TACast (TAAp wt1 (TACast wt2 wf2 (~sym con1))) wf1 con2 + preserve-trans (TATAp wf (TATLam wt) refl) ITTLam = wt-TtSub wf wt + preserve-trans (TATAp wf1 (TACast wt (WFForall wf2) (ConsistForall con)) refl) ITTApCast with wf-ta CtxWFEmpty wt + ... | WFForall wf3 = TACast (TATAp wf1 wt refl) (wf-TTSub wf1 wf2) (~TTSub wf3 wf2 con) + preserve-trans TAEHole () + preserve-trans (TANEHole _) () + preserve-trans (TACast wt _ _) ITCastID = wt + preserve-trans (TACast (TACast wt _ _) _ _) (ITCastSucceed gnd) = wt + preserve-trans (TACast (TACast wt _ _) _ _) (ITCastFail gnd1 gnd2 incon) = TAFailedCast wt gnd1 gnd2 incon + preserve-trans (TACast wt wf _) (ITGround (MGArr _)) = TACast (TACast wt (WFArr wf wf) (ConsistArr ConsistHole1 ConsistHole1)) wf ConsistHole1 + preserve-trans (TACast wt wf _) (ITGround (MGForall _)) = TACast (TACast wt (WFForall WFHole) (ConsistForall ConsistHole1)) wf ConsistHole1 + preserve-trans (TACast wt wf _) (ITExpand (MGArr _)) = TACast (TACast wt (WFArr WFHole WFHole) ConsistHole2) wf (ConsistArr ConsistHole2 ConsistHole2) + preserve-trans (TACast wt wf _) (ITExpand (MGForall _)) = TACast (TACast wt (WFForall WFHole) ConsistHole2) wf (ConsistForall ConsistHole2) + preserve-trans (TAFailedCast _ _ _ _) () - -- note that the exact statement of preservation in the paper, where Γ is - -- empty indicating that the terms are closed, is an immediate corrolary - -- of the slightly more general statement above. - preservation' : {Δ : hctx} {d d' : ihexp} {τ : htyp} → - binders-unique d → - Δ , ∅ ⊢ d :: τ → - d ↦ d' → - Δ , ∅ ⊢ d' :: τ - preservation' = preservation + -- evaluation steps preserve type + preservation : ∀ { d d' τ } → + ∅ ⊢ d :: τ → + d ↦ d' → + ∅ ⊢ d' :: τ + preservation wt (Step fill1 trans fill2) with wt-filling wt fill1 + ... | _ , wt' = wt-different-fill fill1 fill2 wt wt' (preserve-trans wt' trans) + \ No newline at end of file diff --git a/progress-checks.agda b/progress-checks.agda index ba44d0c..8b16459 100644 --- a/progress-checks.agda +++ b/progress-checks.agda @@ -1,7 +1,9 @@ open import Nat open import Prelude open import core -open import contexts +open import core-exp +open import core-type +-- open import contexts open import lemmas-consistency open import type-assignment-unicity open import lemmas-progress-checks @@ -23,6 +25,7 @@ module progress-checks where boxedval-not-indet (BVVal VConst) () boxedval-not-indet (BVVal VLam) () boxedval-not-indet (BVArrCast x bv) (ICastArr x₁ ind) = boxedval-not-indet bv ind + boxedval-not-indet (BVForallCast x bv) (ICastForall x₁ ind) = boxedval-not-indet bv ind boxedval-not-indet (BVHoleCast x bv) (ICastGroundHole x₁ ind) = boxedval-not-indet bv ind boxedval-not-indet (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = boxedval-not-indet bv ind @@ -32,12 +35,15 @@ module progress-checks where boxedval-not-step (BVVal VLam) (d' , Step FHOuter () x₃) boxedval-not-step (BVArrCast x bv) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl boxedval-not-step (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃) - boxedval-not-step (BVHoleCast () bv) (d' , Step FHOuter (ITCastID) FHOuter) - boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed ()) FHOuter) - boxedval-not-step (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround (MGArr x)) FHOuter) = x refl + boxedval-not-step (BVForallCast x bv) (_ , Step FHOuter (ITCastID) FHOuter) = x refl + boxedval-not-step (BVForallCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃) + -- boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed g1 g2 eq) FHOuter) = {! !} + boxedval-not-step (BVHoleCast GBase x) (_ , Step FHOuter (ITGround ()) FHOuter) + boxedval-not-step (BVHoleCast GArr bv) (_ , Step FHOuter (ITGround (MGArr x)) FHOuter) = x refl + boxedval-not-step (BVHoleCast GForall bv) (_ , Step FHOuter (ITGround (MGForall x)) FHOuter) = x refl boxedval-not-step (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃) - boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter) - boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter) + -- boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter) + -- boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter) mutual -- indeterminates don't step @@ -46,22 +52,27 @@ module progress-checks where indet-not-step (INEHole x) (d' , Step FHOuter () FHOuter) indet-not-step (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = final-sub-not-trans x x₁ x₂ indet-not-step (IAp x₁ () x₂) (_ , Step FHOuter (ITLam) FHOuter) - indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast) FHOuter) = x _ _ _ _ _ refl + indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast) FHOuter) = x _ _ _ _ _ refl indet-not-step (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄) indet-not-step (IAp x ind f) (_ , Step (FHAp2 x₃) x₄ (FHAp2 x₆)) = final-not-step f (_ , Step x₃ x₄ x₆) + indet-not-step (ITAp x ind) (_ , Step FHOuter (ITTApCast) FHOuter) = x _ _ _ refl + indet-not-step (ITAp x ind) (_ , Step (FHTAp x₂) x₃ (FHTAp x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄) indet-not-step (ICastArr x ind) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl indet-not-step (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) - indet-not-step (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID) FHOuter) - indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed ()) FHOuter) - indet-not-step (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (MGArr x₁)) FHOuter) = x₁ refl + indet-not-step (ICastForall x ind) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl + indet-not-step (ICastForall x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) + -- indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed g1 g2 eq) FHOuter) = {! !} + indet-not-step (ICastGroundHole GBase x) (_ , Step FHOuter (ITGround ()) FHOuter) + indet-not-step (ICastGroundHole GArr ind) (_ , Step FHOuter (ITGround (MGArr x₁)) FHOuter) = x₁ refl + indet-not-step (ICastGroundHole GForall ind) (_ , Step FHOuter (ITGround (MGForall x₁)) FHOuter) = x₁ refl indet-not-step (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) - indet-not-step (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID ) FHOuter) - indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₂) FHOuter) = x _ _ refl - indet-not-step (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand (MGArr x₂)) FHOuter) = x₂ refl + indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed g') FHOuter) = x _ _ refl + indet-not-step (ICastHoleGround x ind GArr) (_ , Step FHOuter (ITExpand (MGArr x₂)) FHOuter) = x₂ refl + indet-not-step (ICastHoleGround x ind GForall) (_ , Step FHOuter (ITExpand (MGForall x₂)) FHOuter) = x₂ refl indet-not-step (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) - indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter) - indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITGround ()) FHOuter) - indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter) + -- indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter) + -- indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITGround ()) FHOuter) + -- indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter) indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITCastFail x₃ x₄ x₅) FHOuter) = x _ _ refl indet-not-step (IFailedCast x x₁ x₂ x₃) (d' , Step FHOuter () FHOuter) indet-not-step (IFailedCast x x₁ x₂ x₃) (_ , Step (FHFailedCast x₄) x₅ (FHFailedCast x₆)) = final-not-step x (_ , Step x₄ x₅ x₆) diff --git a/progress.agda b/progress.agda index aed144b..fe925d0 100644 --- a/progress.agda +++ b/progress.agda @@ -1,164 +1,148 @@ -open import Nat open import Prelude +open import core-type +open import core-exp open import core -open import contexts -open import lemmas-consistency -open import lemmas-ground - -open import progress-checks -open import canonical-boxed-forms -open import canonical-value-forms -open import canonical-indeterminate-forms +open import eq-dec +open import ground-dec -open import ground-decidable -open import htype-decidable +open import lemmas-consistency +open import lemmas-wf +open import lemmas-ground module progress where - -- this is a little bit of syntactic sugar to avoid many layer nested Inl - -- and Inrs that you would get from the more literal transcription of the - -- consequent of progress - data ok : (d : ihexp) (Δ : hctx) → Set where - S : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → ok d Δ - I : ∀{d Δ} → d indet → ok d Δ - BV : ∀{d Δ} → d boxedval → ok d Δ - progress : {Δ : hctx} {d : ihexp} {τ : htyp} → - Δ , ∅ ⊢ d :: τ → - ok d Δ - -- constants - progress TAConst = BV (BVVal VConst) + data ok : (d : ihexp) → Set where + S : ∀{d} → Σ[ d' ∈ ihexp ] (d ↦ d') → ok d + I : ∀{d} → d indet → ok d + BV : ∀{d} → d boxedval → ok d - -- variables - progress (TAVar x₁) = abort (somenotnone (! x₁)) - - -- lambdas + progress : {d : ihexp} {τ : htyp} → + ∅ ⊢ d :: τ → + ok d + progress TAConst = BV (BVVal VConst) progress (TALam _ wt) = BV (BVVal VLam) - - -- applications - progress (TAAp wt1 wt2) - with progress wt1 | progress wt2 - -- if the left steps, the whole thing steps - progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z)) - -- if the left is indeterminate, step the right - progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2 z)) - -- if they're both indeterminate, step when the cast steps and indet otherwise - progress (TAAp wt1 wt2) | I x | I x₁ - with canonical-indeterminate-forms-arr wt1 x - progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter) - progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) - progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) - progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) - progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) - progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) - -- similar if the left is indetermiante but the right is a boxed val - progress (TAAp wt1 wt2) | I x | BV x₁ - with canonical-indeterminate-forms-arr wt1 x - progress (TAAp wt1 wt2) | I x | BV y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter) - progress (TAAp wt1 wt2) | I x | BV y | CIFAEHole (_ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) - progress (TAAp wt1 wt2) | I x | BV y | CIFANEHole (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) - progress (TAAp wt1 wt2) | I x | BV y | CIFAAp (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) - progress (TAAp wt1 wt2) | I x | BV y | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) - progress (TAAp wt1 wt2) | I x | BV y | CIFAFailedCast (_ , _ , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) - -- if the left is a boxed value, inspect the right - progress (TAAp wt1 wt2) | BV v | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2 z)) - progress (TAAp wt1 wt2) | BV v | I i - with canonical-boxed-forms-arr wt1 v - ... | CBFLam (_ , _ , refl , _) = S (_ , Step FHOuter ITLam FHOuter) - ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter) - progress (TAAp wt1 wt2) | BV v | BV v₂ - with canonical-boxed-forms-arr wt1 v - ... | CBFLam (_ , _ , refl , _) = S (_ , Step FHOuter ITLam FHOuter) - ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter) - - -- empty holes are indeterminate - progress (TAEHole _ _ ) = I IEHole - - -- nonempty holes step if the innards step, indet otherwise - progress (TANEHole xin wt x₁) - with progress wt - ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z)) - ... | I x = I (INEHole (FIndet x)) + progress (TATLam wt) = BV (BVVal VTLam) + progress TAEHole = I IEHole + progress (TANEHole wt) with progress wt + ... | S (_ , Step x y z) = S (_ , (Step (FHNEHole x) y (FHNEHole z))) + ... | I x = I (INEHole (FIndet x)) ... | BV x = I (INEHole (FBoxedVal x)) + progress (TAFailedCast wt y z w) with progress wt + ... | S (d' , Step x y' z') = S (_ , Step (FHFailedCast x) y' (FHFailedCast z')) + ... | I x = I (IFailedCast (FIndet x) y z \{ refl → w ~refl}) + ... | BV x = I (IFailedCast (FBoxedVal x) y z \{ refl → w ~refl}) + progress (TATAp wf wt refl) with progress wt + ... | S (_ , Step x y z) = S (_ , (Step (FHTAp x) y (FHTAp z))) + ... | I IEHole = I (ITAp (λ τ1 τ2 d' ()) IEHole) + ... | I (INEHole x) = I (ITAp (λ τ1 τ2 d' ()) (INEHole x)) + ... | I (IAp x ind x₁) = I (ITAp (λ τ1 τ2 d' ()) (IAp x ind x₁)) + ... | I (ITAp x ind) = I (ITAp (λ τ1 τ2 d' ()) (ITAp x ind)) + ... | I (ICastForall x ind) = S (_ , Step FHOuter ITTApCast FHOuter) + ... | I (ICastHoleGround x ind x₁) = I (ITAp (λ τ1 τ2 d' ()) (ICastHoleGround x ind x₁)) + ... | I (IFailedCast x x₁ x₂ x₃) = I (ITAp (λ τ1 τ2 d' ()) (IFailedCast x x₁ x₂ x₃)) + ... | BV (BVVal VTLam) = S (_ , Step FHOuter ITTLam FHOuter) + ... | BV (BVForallCast neq bv) = S (_ , Step FHOuter ITTApCast FHOuter) + + progress (TAAp wt1 wt2) with progress wt1 | progress wt2 + ... | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z)) + ... | I _ | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2 z)) + ... | I (ICastArr x ind) | I x₁ = S (_ , Step FHOuter ITApCast FHOuter) + ... | I (ICastArr x ind) | BV x₁ = S (_ , Step FHOuter ITApCast FHOuter) + ... | I IEHole | I x = I (IAp (λ _ _ _ _ _ ()) IEHole (FIndet x)) + ... | I IEHole | BV x = I (IAp (λ _ _ _ _ _ ()) IEHole (FBoxedVal x)) + ... | I (INEHole x) | I x₁ = I (IAp (λ _ _ _ _ _ ()) (INEHole x) (FIndet x₁)) + ... | I (INEHole x) | BV x₁ = I (IAp (λ _ _ _ _ _ ()) (INEHole x) (FBoxedVal x₁)) + ... | I (IAp x ind x₁) | I x₂ = I (IAp (λ _ _ _ _ _ ()) (IAp x ind x₁) (FIndet x₂)) + ... | I (IAp x ind x₁) | BV x₂ = I (IAp (λ _ _ _ _ _ ()) (IAp x ind x₁) (FBoxedVal x₂)) + ... | I (ITAp x ind) | I x₁ = I (IAp (λ _ _ _ _ _ ()) (ITAp x ind) (FIndet x₁)) + ... | I (ITAp x ind) | BV x₁ = I (IAp (λ _ _ _ _ _ ()) (ITAp x ind) (FBoxedVal x₁)) + ... | I (ICastHoleGround x ind x₁) | I x₂ = I (IAp (λ _ _ _ _ _ ()) (ICastHoleGround x ind x₁) (FIndet x₂)) + ... | I (ICastHoleGround x ind x₁) | BV x₂ = I (IAp (λ _ _ _ _ _ ()) (ICastHoleGround x ind x₁) (FBoxedVal x₂)) + ... | I (IFailedCast x x₁ x₂ x₃) | I x₄ = I (IAp (λ _ _ _ _ _ ()) (IFailedCast x x₁ x₂ x₃) (FIndet x₄)) + ... | I (IFailedCast x x₁ x₂ x₃) | BV x₄ = I (IAp (λ _ _ _ _ _ ()) (IFailedCast x x₁ x₂ x₃) (FBoxedVal x₄)) + ... | BV bv | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2 z)) + ... | BV (BVVal VLam) | I x = S (_ , Step FHOuter ITLam FHOuter) + ... | BV (BVVal VLam) | BV x = S (_ , Step FHOuter ITLam FHOuter) + ... | BV (BVArrCast x₁ bv) | I x = S (_ , Step FHOuter ITApCast FHOuter) + ... | BV (BVArrCast x₁ bv) | BV x = S (_ , Step FHOuter ITApCast FHOuter) + + progress (TACast wt wf con) with progress wt + progress (TACast wt wf con) | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z)) + progress (TACast wt wf ConsistBase) | x = S (_ , (Step FHOuter ITCastID FHOuter)) + progress (TACast wt wf (ConsistArr {τ1 = τ1} {τ2 = τ2} {τ3 = τ3} {τ4 = τ4} con1 con2)) | I x with htyp-eq-dec (τ1 ==> τ2) (τ3 ==> τ4) + ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) + ... | Inr neq = I (ICastArr neq x) + progress (TACast wt wf (ConsistArr {τ1 = τ1} {τ2 = τ2} {τ3 = τ3} {τ4 = τ4} con1 con2)) | BV x with htyp-eq-dec (τ1 ==> τ2) (τ3 ==> τ4) + ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) + ... | Inr neq = BV (BVArrCast neq x) + progress (TACast wt wf (ConsistForall {τ1 = τ1} {τ2 = τ2} con)) | I x with htyp-eq-dec (·∀ τ1) (·∀ τ2) + ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) + ... | Inr neq = I (ICastForall neq x) + progress (TACast wt wf (ConsistForall {τ1 = τ1} {τ2 = τ2} con)) | BV x with htyp-eq-dec (·∀ τ1) (·∀ τ2) + ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) + ... | Inr neq = BV (BVForallCast neq x) - -- casts - progress (TACast wt con) - with progress wt - -- step if the innards step - progress (TACast wt con) | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z)) - -- if indet, inspect how the types in the cast are realted by consistency: - -- if they're the same, step by ID - progress (TACast wt TCRefl) | I x = S (_ , Step FHOuter ITCastID FHOuter) - -- if first type is hole - progress (TACast {τ1 = τ1} wt TCHole1) | I x - with τ1 - progress (TACast wt TCHole1) | I x | b = I (ICastGroundHole GBase x) - progress (TACast wt TCHole1) | I x | ⦇-⦈ = S (_ , Step FHOuter ITCastID FHOuter) - progress (TACast wt TCHole1) | I x | τ11 ==> τ12 - with ground-decidable (τ11 ==> τ12) - progress (TACast wt TCHole1) | I x₁ | .⦇-⦈ ==> .⦇-⦈ | Inl GHole = I (ICastGroundHole GHole x₁) - progress (TACast wt TCHole1) | I x₁ | τ11 ==> τ12 | Inr x = S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole x))) FHOuter) - -- if second type is hole - progress (TACast wt (TCHole2 {b})) | I x - with canonical-indeterminate-forms-hole wt x - progress (TACast wt (TCHole2 {b})) | I x | CIFHEHole (_ , _ , _ , refl , f) = I (ICastHoleGround (λ _ _ ()) x GBase) - progress (TACast wt (TCHole2 {b})) | I x | CIFHNEHole (_ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase) - progress (TACast wt (TCHole2 {b})) | I x | CIFHAp (_ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase) - progress (TACast wt (TCHole2 {b})) | I x | CIFHCast (_ , τ , refl , _) - with htype-dec τ b - progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , .b , refl , _ , grn , _) | Inl refl = S (_ , Step FHOuter (ITCastSucceed grn ) FHOuter) - progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , _ , refl , π2 , grn , _) | Inr x = S (_ , Step FHOuter (ITCastFail grn GBase x) FHOuter) - progress (TACast wt (TCHole2 {⦇-⦈}))| I x = S (_ , Step FHOuter ITCastID FHOuter) - progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x - with ground-decidable (τ11 ==> τ12) - progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x₁ | Inl GHole - with canonical-indeterminate-forms-hole wt x₁ - progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHEHole (_ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole) - progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHNEHole (_ , _ , _ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole) - progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHAp (_ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GHole) - progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , _ , GBase , _) = S (_ , Step FHOuter (ITCastFail GBase GHole (λ ())) FHOuter ) - progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , _ , GHole , _) = S (_ , Step FHOuter (ITCastSucceed GHole) FHOuter) - progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x₁ | Inr x = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter) - -- if both are arrows - progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x - with htype-dec (τ1 ==> τ2) (τ1' ==> τ2') - progress (TACast wt (TCArr c1 c2)) | I x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) - progress (TACast wt (TCArr c1 c2)) | I x₁ | Inr x = I (ICastArr x x₁) - -- boxed value cases, inspect how the casts are realted by consistency - -- step by ID if the casts are the same - progress (TACast wt TCRefl) | BV x = S (_ , Step FHOuter ITCastID FHOuter) - -- if left is hole - progress (TACast wt (TCHole1 {τ = τ})) | BV x - with ground-decidable τ - progress (TACast wt TCHole1) | BV x₁ | Inl g = BV (BVHoleCast g x₁) - progress (TACast wt (TCHole1 {b})) | BV x₁ | Inr x = abort (x GBase) - progress (TACast wt (TCHole1 {⦇-⦈})) | BV x₁ | Inr x = S (_ , Step FHOuter ITCastID FHOuter) - progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₁ | Inr x - with (htype-dec (τ1 ==> τ2) (⦇-⦈ ==> ⦇-⦈)) - progress (TACast wt (TCHole1 {.⦇-⦈ ==> .⦇-⦈})) | BV x₂ | Inr x₁ | Inl refl = BV (BVHoleCast GHole x₂) - progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₂ | Inr x₁ | Inr x = S (_ , Step FHOuter (ITGround (MGArr x)) FHOuter) - -- if right is hole - progress {τ = τ} (TACast wt TCHole2) | BV x - with canonical-boxed-forms-hole wt x - progress {τ = τ} (TACast wt TCHole2) | BV x | d' , τ' , refl , gnd , wt' - with htype-dec τ τ' - progress (TACast wt TCHole2) | BV x₁ | d' , τ , refl , gnd , wt' | Inl refl = S (_ , Step FHOuter (ITCastSucceed gnd) FHOuter) - progress {τ = τ} (TACast wt TCHole2) | BV x₁ | _ , _ , refl , _ , _ | Inr _ - with ground-decidable τ - progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , gnd , _ | Inr x₁ | Inl x = S(_ , Step FHOuter (ITCastFail gnd x (flip x₁)) FHOuter) - progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , _ , _ | Inr x₁ | Inr x - with notground x - progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr _ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) - progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr x | Inr (_ , _ , refl) = S(_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter ) - -- if both arrows - progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x - with htype-dec (τ1 ==> τ2) (τ1' ==> τ2') - progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) - progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inr x = BV (BVArrCast x x₁) + progress {_ ⟨ b ⇒ _ ⟩} (TACast wt wf ConsistHole1) | I x = I (ICastGroundHole GBase x) + progress {_ ⟨ T _ ⇒ _ ⟩} (TACast wt wf ConsistHole1) | I x with wf-ta CtxWFEmpty wt + ... | () + progress {_ ⟨ ⦇-⦈ ⇒ _ ⟩} (TACast wt wf ConsistHole1) | I x = S (_ , Step FHOuter ITCastID FHOuter) + progress {_ ⟨ τ1 ==> τ2 ⇒ _ ⟩} (TACast wt wf ConsistHole1) | I x with ground-dec (τ1 ==> τ2) + ... | Inl GArr = I (ICastGroundHole GArr x) + ... | Inr ngdn = S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole ngdn))) FHOuter) + progress {_ ⟨ ·∀ τ ⇒ _ ⟩} (TACast wt wf ConsistHole1) | I x with ground-dec (·∀ τ) + ... | Inl GForall = I (ICastGroundHole GForall x) + ... | Inr ngdn = S (_ , Step FHOuter (ITGround (MGForall (ground-forall-not-hole ngdn))) FHOuter) + + progress (TACast (TACast wt x₃ x₄) wf ConsistHole2) | I (ICastHoleGround x x₁ x₂) = S (_ , Step (FHCast FHOuter) ITCastID (FHCast FHOuter)) + progress {τ = b} (TACast wt wf ConsistHole2) | I IEHole = I (ICastHoleGround (λ _ _ ()) IEHole GBase) + progress {τ = b} (TACast wt wf ConsistHole2) | I (INEHole x) = I (ICastHoleGround (λ _ _ ()) (INEHole x) GBase) + progress {τ = b} (TACast wt wf ConsistHole2) | I (IAp x x₁ x₂) = I (ICastHoleGround (λ _ _ ()) (IAp x x₁ x₂) GBase) + progress {τ = b} (TACast wt wf ConsistHole2) | I (ITAp x x₁) = I (ICastHoleGround (λ _ _ ()) (ITAp x x₁) GBase) + progress {τ = b} (TACast wt wf ConsistHole2) | I (IFailedCast x x₁ x₂ x₃) = I (ICastHoleGround (λ _ _ ()) (IFailedCast x x₁ x₂ x₃) GBase) + progress {τ = b} (TACast wt wf ConsistHole2) | I (ICastGroundHole GBase x₁) = S (_ , Step FHOuter (ITCastSucceed GBase) FHOuter) + progress {τ = b} (TACast wt wf ConsistHole2) | I (ICastGroundHole GArr x₁) = S (_ , Step FHOuter (ITCastFail GArr GBase λ ()) FHOuter) + progress {τ = b} (TACast wt wf ConsistHole2) | I (ICastGroundHole GForall x₁) = S (_ , Step FHOuter (ITCastFail GForall GBase λ ()) FHOuter) + progress {τ = ⦇-⦈} (TACast wt wf ConsistHole2) | I x = S (_ , Step FHOuter ITCastID FHOuter) + progress {τ = τ1 ==> τ2} (TACast wt wf ConsistHole2) | I x with ground-dec (τ1 ==> τ2) + progress (TACast wt wf ConsistHole2) | I x | Inr ngnd = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole ngnd))) FHOuter) + progress (TACast wt wf ConsistHole2) | I IEHole | Inl GArr = I (ICastHoleGround (λ _ _ ()) IEHole GArr) + progress (TACast wt wf ConsistHole2) | I (INEHole x) | Inl GArr = I (ICastHoleGround (λ _ _ ()) (INEHole x) GArr) + progress (TACast wt wf ConsistHole2) | I (IAp x x₁ x₂) | Inl GArr = I (ICastHoleGround (λ _ _ ()) (IAp x x₁ x₂) GArr) + progress (TACast wt wf ConsistHole2) | I (ITAp x x₁) | Inl GArr = I (ICastHoleGround (λ _ _ ()) (ITAp x x₁) GArr) + progress (TACast wt wf ConsistHole2) | I (IFailedCast x x₁ x₂ x₃) | Inl GArr = I (ICastHoleGround (λ _ _ ()) (IFailedCast x x₁ x₂ x₃) GArr) + progress (TACast (TACast wt x₃ x₄) wf ConsistHole2) | I (ICastHoleGround x x₁ x₂) | Inl GArr = S (_ , Step (FHCast FHOuter) ITCastID (FHCast FHOuter)) + progress (TACast wt wf ConsistHole2) | I (ICastGroundHole {τ = .b} GBase x₁) | Inl GArr = S (_ , Step FHOuter (ITCastFail GBase GArr (λ ())) FHOuter ) + progress (TACast wt wf ConsistHole2) | I (ICastGroundHole {τ = .(⦇-⦈ ==> ⦇-⦈)} GArr x₁) | Inl GArr = S (_ , Step FHOuter (ITCastSucceed GArr) FHOuter ) + progress (TACast wt wf ConsistHole2) | I (ICastGroundHole {τ = .(·∀ ⦇-⦈)} GForall x₁) | Inl GArr = S (_ , Step FHOuter (ITCastFail GForall GArr (λ ())) FHOuter ) + progress {τ = ·∀ τ} (TACast wt wf ConsistHole2) | I x with ground-dec (·∀ τ) + progress {τ = ·∀ τ} (TACast wt wf ConsistHole2) | I x | Inr ngnd = S (_ , Step FHOuter (ITExpand (MGForall (ground-forall-not-hole ngnd))) FHOuter) + progress (TACast wt wf ConsistHole2) | I IEHole | Inl GForall = I (ICastHoleGround (λ _ _ ()) IEHole GForall) + progress (TACast wt wf ConsistHole2) | I (INEHole x) | Inl GForall = I (ICastHoleGround (λ _ _ ()) (INEHole x) GForall) + progress (TACast wt wf ConsistHole2) | I (IAp x x₁ x₂) | Inl GForall = I (ICastHoleGround (λ _ _ ()) (IAp x x₁ x₂) GForall) + progress (TACast wt wf ConsistHole2) | I (ITAp x x₁) | Inl GForall = I (ICastHoleGround (λ _ _ ()) (ITAp x x₁) GForall) + progress (TACast wt wf ConsistHole2) | I (IFailedCast x x₁ x₂ x₃) | Inl GForall = I (ICastHoleGround (λ _ _ ()) (IFailedCast x x₁ x₂ x₃) GForall) + progress (TACast (TACast wt x₃ x₄) wf ConsistHole2) | I (ICastHoleGround x x₁ x₂) | Inl GForall = S (_ , Step (FHCast FHOuter) ITCastID (FHCast FHOuter)) + progress (TACast wt wf ConsistHole2) | I (ICastGroundHole GBase x₁) | Inl GForall = S (_ , Step FHOuter (ITCastFail GBase GForall (λ ())) FHOuter ) + progress (TACast wt wf ConsistHole2) | I (ICastGroundHole GArr x₁) | Inl GForall = S (_ , Step FHOuter (ITCastFail GArr GForall (λ ())) FHOuter ) + progress (TACast wt wf ConsistHole2) | I (ICastGroundHole GForall x₁) | Inl GForall = S (_ , Step FHOuter (ITCastSucceed GForall) FHOuter ) - -- failed casts - progress (TAFailedCast wt y z w) - with progress wt - progress (TAFailedCast wt y z w) | S (d' , Step x a q) = S (_ , Step (FHFailedCast x) a (FHFailedCast q)) - progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w) - progress (TAFailedCast wt y z w) | BV x = I (IFailedCast (FBoxedVal x) y z w) + progress (TACast wt wf (ConsistHole1 {τ = τ})) | BV x with ground-dec τ + progress (TACast wt wf (ConsistHole1 {τ = τ})) | BV x | Inl gnd = BV (BVHoleCast gnd x) + progress {_ ⟨ b ⇒ .⦇-⦈ ⟩} (TACast wt wf (ConsistHole1 {b})) | BV x | Inr ngnd = abort (ngnd GBase) + progress {_ ⟨ T x₁ ⇒ .⦇-⦈ ⟩} (TACast wt wf (ConsistHole1 {T x₁})) | BV x | Inr ngnd with wf-ta CtxWFEmpty wt + ... | () + progress {_ ⟨ ⦇-⦈ ⇒ .⦇-⦈ ⟩} (TACast wt wf (ConsistHole1 {⦇-⦈})) | BV x | Inr ngnd = S (_ , Step FHOuter ITCastID FHOuter) + progress (TACast wt wf (ConsistHole1 {τ1 ==> τ2})) | BV x | Inr ngnd = S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole ngnd))) FHOuter) + progress {_ ⟨ ·∀ τ ⇒ .⦇-⦈ ⟩} (TACast wt wf (ConsistHole1 {·∀ τ})) | BV x | Inr ngnd = S (_ , Step FHOuter (ITGround (MGForall (ground-forall-not-hole ngnd))) FHOuter) + progress (TACast () wf ConsistHole2) | BV (BVVal VConst) + progress (TACast () wf ConsistHole2) | BV (BVVal VLam) + progress (TACast () wf ConsistHole2) | BV (BVVal VTLam) + progress {τ = τ1} (TACast wt wf ConsistHole2) | BV (BVHoleCast {τ = τ2} gnd bv) with htyp-eq-dec τ2 τ1 + progress {τ = τ1} (TACast wt wf ConsistHole2) | BV (BVHoleCast {τ = τ2} gnd bv) | Inl refl = S (_ , Step FHOuter (ITCastSucceed gnd) FHOuter) + progress {τ = τ1} (TACast wt wf ConsistHole2) | BV (BVHoleCast {τ = τ2} gnd bv) | Inr neq with ground-dec τ1 + progress {τ = τ1} (TACast wt wf ConsistHole2) | BV (BVHoleCast {τ = τ2} gnd bv) | Inr neq | Inl gnd' = S (_ , Step FHOuter (ITCastFail gnd gnd' (ground-neq~ gnd gnd' neq)) FHOuter) + progress {τ = b} (TACast wt wf ConsistHole2) | BV (BVHoleCast gnd bv) | Inr neq | Inr ngnd = abort (ngnd GBase) + progress {τ = ⦇-⦈} (TACast wt wf ConsistHole2) | BV (BVHoleCast gnd bv) | Inr neq | Inr ngnd = S (_ , Step FHOuter ITCastID FHOuter) + progress {τ = τ1 ==> τ2} (TACast wt wf ConsistHole2) | BV (BVHoleCast gnd bv) | Inr neq | Inr ngnd = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole ngnd))) FHOuter) + progress {τ = ·∀ τ1} (TACast wt wf ConsistHole2) | BV (BVHoleCast gnd bv) | Inr neq | Inr ngnd = S (_ , Step FHOuter (ITExpand (MGForall (ground-forall-not-hole ngnd))) FHOuter) \ No newline at end of file diff --git a/status.sh b/status.sh deleted file mode 100755 index 097f7d9..0000000 --- a/status.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -echo -echo "\`\`\`" -echo "Status as of " `date` -echo "todos: " `grep -i todo * | wc -l` -echo "postulates: " `grep -i postulate *.agda | wc -l` -echo "red brackets:" `grep -i 'red brackets' *.agda | wc -l` -echo "\`\`\`" diff --git a/synth-unicity.agda b/synth-unicity.agda deleted file mode 100644 index a817078..0000000 --- a/synth-unicity.agda +++ /dev/null @@ -1,26 +0,0 @@ -open import Prelude -open import core -open import contexts - -module synth-unicity where - -- synthesis only produces equal types. note that there is no need for an - -- analagous theorem for analytic positions because we think of - -- the type as an input - synthunicity : {Γ : tctx} {e : hexp} {t t' : htyp} → - (Γ ⊢ e => t) - → (Γ ⊢ e => t') - → t == t' - synthunicity (SAsc _) (SAsc _) = refl - synthunicity {Γ = G} (SVar in1) (SVar in2) = ctxunicity {Γ = G} in1 in2 - synthunicity (SAp _ D1 MAHole _) (SAp _ D2 MAHole y) = refl - synthunicity (SAp _ D1 MAHole _) (SAp _ D2 MAArr y) with synthunicity D1 D2 - ... | () - synthunicity (SAp _ D1 MAArr _) (SAp _ D2 MAHole y) with synthunicity D1 D2 - ... | () - synthunicity (SAp _ D1 MAArr _) (SAp _ D2 MAArr y) with synthunicity D1 D2 - ... | refl = refl - synthunicity SEHole SEHole = refl - synthunicity (SNEHole _ _) (SNEHole _ _) = refl - synthunicity SConst SConst = refl - synthunicity (SLam _ D1) (SLam _ D2) with synthunicity D1 D2 - synthunicity (SLam x₁ D1) (SLam x₂ D2) | refl = refl diff --git a/type-assignment-unicity.agda b/type-assignment-unicity.agda index ed47f55..47233c8 100644 --- a/type-assignment-unicity.agda +++ b/type-assignment-unicity.agda @@ -1,31 +1,49 @@ open import Nat open import Prelude +open import core-type open import core -open import contexts +open import lemmas-meet module type-assignment-unicity where - -- type assignment only assigns one type - type-assignment-unicity : {Γ : tctx} {d : ihexp} {τ' τ : htyp} {Δ : hctx} → - Δ , Γ ⊢ d :: τ → - Δ , Γ ⊢ d :: τ' → - τ == τ' - type-assignment-unicity TAConst TAConst = refl - type-assignment-unicity {Γ = Γ} (TAVar x₁) (TAVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ - type-assignment-unicity (TALam _ d1) (TALam _ d2) - with type-assignment-unicity d1 d2 - ... | refl = refl - type-assignment-unicity (TAAp x x₁) (TAAp y y₁) - with type-assignment-unicity x y - ... | refl = refl - type-assignment-unicity (TAEHole {Δ = Δ} x y) (TAEHole x₁ x₂) - with ctxunicity {Γ = Δ} x x₁ - ... | refl = refl - type-assignment-unicity (TANEHole {Δ = Δ} x d1 y) (TANEHole x₁ d2 x₂) - with ctxunicity {Γ = Δ} x₁ x + + context-unicity : ∀{Γ n τ τ'} → + n , τ ∈ Γ → + n , τ' ∈ Γ → + τ == τ' + context-unicity (InCtxSkip inctx1) (InCtxSkip inctx2) rewrite context-unicity inctx1 inctx2 = refl + context-unicity InCtxZ InCtxZ = refl + context-unicity (InCtx1+ inctx1) (InCtx1+ inctx2) = context-unicity inctx1 inctx2 + + synth-unicity : ∀{Γ d τ' τ} → + Γ ⊢ d => τ → + Γ ⊢ d => τ' → + τ == τ' + synth-unicity SConst SConst = refl + synth-unicity (SAsc x x₁) (SAsc x₂ x₃) = refl + synth-unicity (SVar x) (SVar x₁) = context-unicity x x₁ + synth-unicity (SAp syn1 x x₁) (SAp syn2 x₂ x₃) rewrite synth-unicity syn1 syn2 with ⊓-unicity x x₂ ... | refl = refl - type-assignment-unicity (TACast d1 x) (TACast d2 x₁) - with type-assignment-unicity d1 d2 + synth-unicity SEHole SEHole = refl + synth-unicity (SNEHole syn1) (SNEHole syn2) = refl + synth-unicity (SLam x syn1) (SLam x₁ syn2) rewrite synth-unicity syn1 syn2 = refl + synth-unicity (STLam syn1) (STLam syn2) rewrite synth-unicity syn1 syn2 = refl + synth-unicity (STAp x syn1 x₁ refl) (STAp x₃ syn2 x₄ refl) rewrite synth-unicity syn1 syn2 with ⊓-unicity x₁ x₄ ... | refl = refl - type-assignment-unicity (TAFailedCast x x₁ x₂ x₃) (TAFailedCast y x₄ x₅ x₆) - with type-assignment-unicity x y + + -- type assignment only assigns one type + type-assignment-unicity : ∀{Γ d τ' τ} → + Γ ⊢ d :: τ → + Γ ⊢ d :: τ' → + τ == τ' + type-assignment-unicity TAConst TAConst = refl + type-assignment-unicity (TAVar inctx1) (TAVar inctx2) = context-unicity inctx1 inctx2 + type-assignment-unicity (TALam _ wt1) (TALam _ wt2) rewrite type-assignment-unicity wt1 wt2 = refl + type-assignment-unicity (TATLam wt1) (TATLam wt2) rewrite type-assignment-unicity wt1 wt2 = refl + type-assignment-unicity (TAAp wt1 _) (TAAp wt2 _) with type-assignment-unicity wt1 wt2 ... | refl = refl + type-assignment-unicity (TATAp _ wt1 eq1) (TATAp _ wt2 eq2) with type-assignment-unicity wt1 wt2 + ... | refl rewrite eq1 = eq2 + type-assignment-unicity TAEHole TAEHole = refl + type-assignment-unicity (TANEHole _) (TANEHole _) = refl + type-assignment-unicity (TACast wt1 _ _) (TACast wt2 _ _) rewrite type-assignment-unicity wt1 wt2 = refl + type-assignment-unicity (TAFailedCast wt1 _ _ _) (TAFailedCast wt2 _ _ _) rewrite type-assignment-unicity wt1 wt2 = refl diff --git a/typed-elaboration.agda b/typed-elaboration.agda index 13a8c13..40b8875 100644 --- a/typed-elaboration.agda +++ b/typed-elaboration.agda @@ -1,41 +1,61 @@ open import Nat open import Prelude +open import core-type open import core -open import contexts -open import lemmas-consistency -open import lemmas-disjointness open import weakening +open import lemmas-wf +open import lemmas-consistency +open import lemmas-prec +open import lemmas-meet module typed-elaboration where - mutual - typed-elaboration-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} → - Γ ⊢ e ⇒ τ ~> d ⊣ Δ → - Δ , Γ ⊢ d :: τ - typed-elaboration-synth ESConst = TAConst - typed-elaboration-synth (ESVar x₁) = TAVar x₁ - typed-elaboration-synth (ESLam x₁ ex) = TALam x₁ (typed-elaboration-synth ex) - typed-elaboration-synth (ESAp {Δ1 = Δ1} _ d x₁ x₂ x₃ x₄) - with typed-elaboration-ana x₃ | typed-elaboration-ana x₄ - ... | con1 , ih1 | con2 , ih2 = TAAp (TACast (weaken-ta-Δ1 d ih1) con1) (TACast (weaken-ta-Δ2 {Δ1 = Δ1} d ih2) con2) - typed-elaboration-synth (ESEHole {Γ = Γ} {u = u}) = TAEHole (ctx-top ∅ u (Γ , ⦇-⦈) refl)(STAId (λ x τ z → z)) - typed-elaboration-synth (ESNEHole {Γ = Γ} {τ = τ} {u = u} {Δ = Δ} (d1 , d2) ex) - with typed-elaboration-synth ex - ... | ih1 = TANEHole {Δ = Δ ,, (u , Γ , ⦇-⦈)} (ctx-top Δ u (Γ , ⦇-⦈) (d2 u (lem-domsingle _ _))) (weaken-ta-Δ1 (d1 , d2) ih1)(STAId (λ x τ₁ z → z)) - typed-elaboration-synth (ESAsc x) - with typed-elaboration-ana x - ... | con , ih = TACast ih con - typed-elaboration-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} → - Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → - (τ' ~ τ) × (Δ , Γ ⊢ d :: τ') - typed-elaboration-ana (EALam x₁ MAHole ex) - with typed-elaboration-ana ex - ... | con , D = TCHole1 , TALam x₁ D - typed-elaboration-ana (EALam x₁ MAArr ex) - with typed-elaboration-ana ex - ... | con , D = TCArr TCRefl con , TALam x₁ D - typed-elaboration-ana (EASubsume x x₁ x₂ x₃) = ~sym x₃ , typed-elaboration-synth x₂ - typed-elaboration-ana (EAEHole {Γ = Γ} {u = u}) = TCRefl , TAEHole (ctx-top ∅ u (Γ , _) refl) (STAId (λ x τ z → z)) - typed-elaboration-ana (EANEHole {Γ = Γ} {u = u} {τ = τ} {Δ = Δ} (d1 , d2) x) - with typed-elaboration-synth x - ... | ih1 = TCRefl , TANEHole {Δ = Δ ,, (u , Γ , τ)} (ctx-top Δ u (Γ , τ) (d2 u (lem-domsingle _ _)) ) (weaken-ta-Δ1 (d1 , d2) ih1) (STAId (λ x₁ τ₁ z → z)) + ⊑t-ana : ∀{Γ e τ d τ'} → Γ ⊢ e ⇐ τ ~> d :: τ' → τ' ⊑t τ + ⊑t-ana (EALam meet ana) with ⊓-lb meet + ... | PTHole , _ = PTHole + ... | PTArr prec1 prec2 , _ = PTArr prec1 (⊑t-trans (⊑t-ana ana) prec2) + ⊑t-ana (EATLam meet ana) with ⊓-lb meet + ... | PTHole , _ = PTHole + ... | PTForall prec , _ = PTForall (⊑t-trans (⊑t-ana ana) prec) + ⊑t-ana (EASubsume neq syn meet) = π1 (⊓-lb meet) + + consist-ana : ∀{Γ e τ τ' d} → + ⊢ Γ ctxwf → + Γ ⊢ τ wf → + Γ ⊢ e ⇐ τ ~> d :: τ' → + τ' ~ τ + consist-ana ctxwf wf ana = ⊑t-consist (⊑t-ana ana) + + mutual + + typed-elaboration-syn : ∀{Γ e τ d} → + (⊢ Γ ctxwf) → + (Γ ⊢ e ⇒ τ ~> d) → + (Γ ⊢ d :: τ) + typed-elaboration-syn ctxwf ESConst = TAConst + typed-elaboration-syn ctxwf (ESVar x) = TAVar x + typed-elaboration-syn ctxwf (ESLam x syn) = TALam x (typed-elaboration-syn (CtxWFVar x ctxwf) syn) + typed-elaboration-syn ctxwf (ESTLam syn) = TATLam (typed-elaboration-syn (CtxWFTVar ctxwf) syn) + typed-elaboration-syn ctxwf (ESAp syn meet ana1 ana2) with ⊓-lb meet | wf-⊓ meet (wf-syn ctxwf syn) (WFArr WFHole WFHole) + ... | prec1 , prec2 | WFArr wf1 wf2 = + TAAp (TACast (typed-elaboration-ana ctxwf (WFArr wf1 wf2) ana1) (WFArr wf1 wf2) (consist-ana ctxwf (WFArr wf1 wf2) ana1)) + ((TACast (typed-elaboration-ana ctxwf wf1 ana2) wf1 (consist-ana ctxwf wf1 ana2))) + typed-elaboration-syn ctxwf (ESTAp wf syn meet ana refl) = + let wf' = wf-⊓ meet (wf-syn ctxwf syn) (WFForall WFHole) in + TATAp wf (TACast (typed-elaboration-ana ctxwf wf' ana) wf' (consist-ana ctxwf wf' ana)) refl + typed-elaboration-syn ctxwf ESEHole = TAEHole + typed-elaboration-syn ctxwf (ESNEHole syn) = TANEHole (typed-elaboration-syn ctxwf syn) + typed-elaboration-syn ctxwf (ESAsc wf ana) = TACast (typed-elaboration-ana ctxwf wf ana) wf (consist-ana ctxwf wf ana) + + typed-elaboration-ana : ∀{Γ e τ τ' d} → + ⊢ Γ ctxwf → + Γ ⊢ τ wf → + Γ ⊢ e ⇐ τ ~> d :: τ' → + Γ ⊢ d :: τ' + typed-elaboration-ana ctxwf wf (EALam meet ana) with wf-⊓ meet wf (WFArr WFHole WFHole) + ... | WFArr wf1 wf2 = TALam wf1 (typed-elaboration-ana (CtxWFVar wf1 ctxwf) (weakening-wf-var wf2) ana) + typed-elaboration-ana ctxwf wf (EATLam meet ana) with wf-⊓ meet wf (WFForall WFHole) + ... | WFForall wf' = TATLam (typed-elaboration-ana (CtxWFTVar ctxwf) wf' ana) + typed-elaboration-ana ctxwf wf (EASubsume neq syn meet) = + TACast (typed-elaboration-syn ctxwf syn) (wf-⊓ meet wf (wf-elab-syn ctxwf syn)) (~sym (⊑t-consist (π2 (⊓-lb meet)))) + \ No newline at end of file diff --git a/typing-subst.agda b/typing-subst.agda new file mode 100644 index 0000000..c60d797 --- /dev/null +++ b/typing-subst.agda @@ -0,0 +1,318 @@ +open import Nat +open import Prelude +open import core-type +open import core-exp +open import core-subst +open import core +open import weakening +open import lemmas-index +open import lemmas-ctx +open import lemmas-consistency +open import lemmas-meet +open import lemmas-subst +open import lemmas-wf + +module typing-subst where + + -- TtSub section + + consist-sub : ∀{m τ1 τ2 τ3} → τ2 ~ τ3 → TTSub m τ1 τ2 ~ TTSub m τ1 τ3 + consist-sub ConsistBase = ConsistBase + consist-sub {m} (ConsistVar {x}) with natEQ m x + ... | Inl refl = ~refl + ... | Inr neq = ~refl + consist-sub ConsistHole1 = ConsistHole1 + consist-sub ConsistHole2 = ConsistHole2 + consist-sub (ConsistArr con1 con2) = ConsistArr (consist-sub con1) (consist-sub con2) + consist-sub (ConsistForall con) = ConsistForall (consist-sub con) + + nat-shift-miss : (t x : Nat) → t ≠ ↑Nat t 1 x + nat-shift-miss Z x () + nat-shift-miss (1+ t) Z () + nat-shift-miss (1+ t) (1+ x) eq = nat-shift-miss t x (1+inj _ _ eq) + + sub-shift-miss : (t : Nat) → (τ' τ : htyp) → TTSub t τ' (↑ t 1 τ) == τ + sub-shift-miss t τ' b = refl + sub-shift-miss t τ' (T x) with natEQ t (↑Nat t 1 x) + ... | Inl eq = abort (nat-shift-miss _ _ eq) + ... | Inr neq rewrite ↓↑Nat-invert Z t x rewrite ↑NatZ t x = refl + sub-shift-miss t τ' ⦇-⦈ = refl + sub-shift-miss t τ' (τ1 ==> τ2) rewrite sub-shift-miss t τ' τ1 rewrite sub-shift-miss t τ' τ2 = refl + sub-shift-miss t τ' (·∀ τ) rewrite sub-shift-miss (1+ t) τ' τ = refl + + some-equation-nat : (n m x : Nat) → ↓Nat (1+ n nat+ m) 1 (↑Nat n 1 x) == ↑Nat n 1 (↓Nat (n nat+ m) 1 x) + some-equation-nat Z m x = refl + some-equation-nat (1+ n) m Z = refl + some-equation-nat (1+ n) m (1+ x) rewrite some-equation-nat n m x = refl + + some-equation : (n m : Nat) → (τ : htyp) → ↓ (1+ n nat+ m) 1 (↑ n 1 τ) == ↑ n 1 (↓ (n nat+ m) 1 τ) + some-equation n m b = refl + some-equation n m (T x) rewrite some-equation-nat n m x = refl + some-equation n m ⦇-⦈ = refl + some-equation n m (τ1 ==> τ2) rewrite some-equation n m τ1 rewrite some-equation n m τ2 = refl + some-equation n m (·∀ τ) rewrite some-equation (1+ n) m τ = refl + + other-equation-nat : (m n x : Nat) → ↑Nat m 1 (↑Nat (m nat+ n) 1 x) == ↑Nat (1+ m nat+ n) 1 (↑Nat m 1 x) + other-equation-nat Z n x = refl + other-equation-nat (1+ m) n Z = refl + other-equation-nat (1+ m) n (1+ x) rewrite other-equation-nat m n x = refl + + other-equation : (m n : Nat) → (τ : htyp) → ↑ m 1 (↑ (m nat+ n) 1 τ) == ↑ (1+ m nat+ n) 1 (↑ m 1 τ) + other-equation m n b = refl + other-equation m n (T x) rewrite other-equation-nat m n x = refl + other-equation m n ⦇-⦈ = refl + other-equation m n (τ1 ==> τ2) rewrite other-equation m n τ1 rewrite other-equation m n τ2 = refl + other-equation m n (·∀ τ) rewrite other-equation (1+ m) n τ = refl + + sub-incr : (m x : Nat) → (τ : htyp) → TTSub (1+ m) τ (T (1+ x)) == ↑ Z 1 (TTSub m τ (T x)) + sub-incr m x τ with natEQ m x + ... | Inr neq = refl + ... | Inl refl rewrite sym (some-equation Z m (↑ 0 (1+ m) τ)) rewrite ↑compose Z (1+ m) τ = refl + + sub-shift : (n m : Nat) → (τ' τ : htyp) → TTSub (1+ n nat+ m) τ' (↑ n 1 τ) == ↑ n 1 (TTSub (n nat+ m) τ' τ) + sub-shift n m τ' b = refl + sub-shift n m τ' ⦇-⦈ = refl + sub-shift n m τ' (τ1 ==> τ2) rewrite sub-shift n m τ' τ1 rewrite sub-shift n m τ' τ2 = refl + sub-shift n m τ' (·∀ τ) rewrite sub-shift (1+ n) m τ' τ = refl + sub-shift Z m τ' (T x) with natEQ m x + ... | Inl refl rewrite sym (↑compose Z (1+ m) τ') rewrite some-equation Z m (↑ 0 (1+ m) τ') = refl + ... | Inr neq = refl + sub-shift (1+ n) m τ' (T Z) = refl + sub-shift (1+ n) m τ' (T (1+ x)) with sub-shift n m τ' (T x) + ... | eq + rewrite sub-incr (1+ (n nat+ m)) (↑Nat n 1 x) τ' + rewrite sub-incr (n nat+ m) x τ' + rewrite eq = other-equation Z n _ + + inctx-subst : ∀{m τ1 n Γ τ2} → n , τ2 ∈ Γ → n , TTSub m τ1 τ2 ∈ TCtxSub m τ1 Γ + inctx-subst {Z} {τ1} (InCtxSkip {τ = τ} inctx) rewrite sub-shift-miss Z τ1 τ = inctx + inctx-subst {1+ m} {τ1} (InCtxSkip {τ = τ} inctx) rewrite sub-shift Z m τ1 τ = InCtxSkip (inctx-subst inctx) + inctx-subst InCtxZ = InCtxZ + inctx-subst (InCtx1+ inctx) = InCtx1+ (inctx-subst inctx) + + wf-subst : ∀{m τ1 τ2 Γ} → ∅ ⊢ τ1 wf → Γ ⊢ τ2 wf → TCtxSub m τ1 Γ ⊢ TTSub m τ1 τ2 wf + wf-subst wf1 (WFSkip wf2) = weakening-wf-var (wf-subst wf1 wf2) + wf-subst {Z} {τ1} wf1 WFVarZ rewrite ↓↑-invert {Z} {Z} {τ1} rewrite ↑Z Z τ1 = weakening-wf wf1 + wf-subst {1+ m} wf1 WFVarZ = WFVarZ + wf-subst {Z} wf1 (WFVarS wf2) = wf2 + wf-subst {1+ m} {τ1} wf1 (WFVarS {n = n} wf2) rewrite sub-incr m n τ1 = wf-inc (wf-subst {m} wf1 wf2) + wf-subst wf1 WFBase = WFBase + wf-subst wf1 WFHole = WFHole + wf-subst wf1 (WFArr wf2 wf3) = WFArr (wf-subst wf1 wf2) (wf-subst wf1 wf3) + wf-subst wf1 (WFForall wf2) = WFForall (wf-subst wf1 wf2) + + gt-neq : (n m : Nat) → 1+ (n nat+ m) ≠ n + gt-neq Z m () + gt-neq (1+ n) m eq = gt-neq n m ((1+inj _ _ eq)) + + other-shift-miss : (n m : Nat) → ↓Nat (1+ (n nat+ m)) 1 n == n + other-shift-miss Z m = refl + other-shift-miss (1+ n) m rewrite other-shift-miss n m = refl + + some-hit : (n m l : Nat) → ↓Nat (l nat+ n) 1 (↑Nat l (1+ n) (l nat+ m)) == l nat+ (n nat+ m) + some-hit Z m Z = refl + some-hit (1+ n) m Z rewrite some-hit n m Z = refl + some-hit n m (1+ l) rewrite some-hit n m l = refl + + some-other-equation-nat : (n m l k x : Nat) → ↓Nat (k nat+ (l nat+ (n nat+ m))) 1 (↑Nat k (1+ (l nat+ (n nat+ m))) x) == + ↓Nat (k nat+ (l nat+ n)) 1 (↑Nat (k nat+ l) (1+ n) (↓Nat (k nat+ (l nat+ m)) 1 (↑Nat k (1+ (l nat+ m)) x))) + some-other-equation-nat Z m Z Z x = refl + some-other-equation-nat (1+ n) m Z Z x rewrite some-other-equation-nat n m Z Z x = refl + some-other-equation-nat n m (1+ l) Z x rewrite some-other-equation-nat n m l Z x = refl + some-other-equation-nat n m l (1+ k) Z = refl + some-other-equation-nat n m l (1+ k) (1+ x) rewrite some-other-equation-nat n m l k x = refl + + some-other-equation : (n m l k : Nat) → (τ : htyp) → + ↓ (k nat+ (l nat+ (n nat+ m))) 1 (↑ k (1+ (l nat+ (n nat+ m))) τ) == + ↓ (k nat+ (l nat+ n)) 1 (↑ (k nat+ l) (1+ n) (↓ (k nat+ (l nat+ m)) 1 (↑ k (1+ (l nat+ m)) τ))) + some-other-equation n m l k b = refl + some-other-equation n m l k (T x) rewrite some-other-equation-nat n m l k x = refl + some-other-equation n m l k ⦇-⦈ = refl + some-other-equation n m l k (τ ==> τ₁) rewrite some-other-equation n m l k τ rewrite some-other-equation n m l k τ₁ = refl + some-other-equation n m l k (·∀ τ) rewrite some-other-equation n m l (1+ k) τ = refl + + an-inequality : (n m l x : Nat) → (l nat+ (n nat+ m)) == (↓Nat (l nat+ n) 1 (↑Nat l (1+ n) x)) → (l nat+ m) == x + an-inequality Z m l x eq rewrite nat+Z l rewrite ↓↑Nat-invert Z l x rewrite ↑NatZ l x = eq + an-inequality (1+ n) m Z x eq = an-inequality n m Z x (1+inj _ _ eq) + an-inequality n m (1+ l) (1+ x) eq rewrite an-inequality n m l x (1+inj _ _ eq) = refl + + extra-equation : (n m l x : Nat) → (↓Nat (l nat+ (n nat+ m)) 1 (↓Nat (l nat+ n) 1 (↑Nat l (1+ n) x))) == (↓Nat (l nat+ n) 1 (↑Nat l (1+ n) (↓Nat (l nat+ m) 1 x))) + extra-equation Z m Z Z = refl + extra-equation Z m Z (1+ x) = refl + extra-equation (1+ n) m Z x rewrite extra-equation n m Z x = refl + extra-equation n m (1+ l) Z = refl + extra-equation n m (1+ l) (1+ x) rewrite extra-equation n m l x = refl + + other-sub-shift : (n m l : Nat) → (τ1 τ2 : htyp) → TTSub (l nat+ (n nat+ m)) τ1 (↓ (l nat+ n) 1 (↑ l (1+ n) τ2)) == ↓ (l nat+ n) 1 (↑ l (1+ n) (TTSub (l nat+ m) τ1 τ2)) + other-sub-shift n m l τ1 b = refl + other-sub-shift n m l τ1 (T x) with natEQ (l nat+ m) x + other-sub-shift n m l τ1 (T x) | Inl refl rewrite some-hit n m l rewrite natEQrefl {l nat+ (n nat+ m)} = some-other-equation n m l Z τ1 + other-sub-shift n m l τ1 (T x) | Inr neq with natEQ (l nat+ (n nat+ m)) (↓Nat (l nat+ n) 1 (↑Nat l (1+ n) x)) + other-sub-shift n m l τ1 (T x) | Inr neq | Inl eq = abort (neq (an-inequality n m l x eq)) + other-sub-shift n m l τ1 (T x) | Inr neq | Inr _ rewrite extra-equation n m l x = refl + other-sub-shift n m l τ1 ⦇-⦈ = refl + other-sub-shift n m l τ1 (τ2 ==> τ3) rewrite other-sub-shift n m l τ1 τ2 rewrite other-sub-shift n m l τ1 τ3 = refl + other-sub-shift n m l τ1 (·∀ τ2) rewrite other-sub-shift n m (1+ l) τ1 τ2 = refl + + gt-shift : (n m : Nat) → ↓Nat n 1 (1+ (n nat+ m)) == (n nat+ m) + gt-shift Z m = refl + gt-shift (1+ n) m rewrite gt-shift n m = refl + + other-sub-shift-miss-var : (n m l x : Nat) → (l nat+ n) ≠ ↓Nat (1+ (l nat+ (n nat+ m))) 1 (↑Nat l (1+ (1+ (n nat+ m))) x) + other-sub-shift-miss-var Z m Z x () + other-sub-shift-miss-var (1+ n) m Z x eq = other-sub-shift-miss-var n m Z x (1+inj _ _ eq) + other-sub-shift-miss-var n m (1+ l) Z () + other-sub-shift-miss-var n m (1+ l) (1+ x) eq = other-sub-shift-miss-var n m l x (1+inj _ _ eq) + + an-equation : (n m l x : Nat) → + (↓Nat (l nat+ n) 1 (↓Nat (1+ (l nat+ (n nat+ m))) 1 (↑Nat l (1+ (1+ (n nat+ m))) x))) + == (↓Nat (l nat+ (n nat+ m)) 1 (↑Nat l (1+ (n nat+ m)) x)) + an-equation Z m Z x = refl + an-equation (1+ n) m Z x rewrite an-equation n m Z x = refl + an-equation n m (1+ l) Z = refl + an-equation n m (1+ l) (1+ x) rewrite an-equation n m l x = refl + + other-sub-shift-miss : (n m l : Nat) → (τ1 τ2 : htyp) → TTSub (l nat+ n) τ2 (↓ (1+ (l nat+ (n nat+ m))) 1 (↑ l (1+ (1+ (n nat+ m))) τ1)) == (↓ (l nat+ (n nat+ m)) 1 (↑ l (1+ (n nat+ m)) τ1)) + other-sub-shift-miss n m l b τ2 = refl + other-sub-shift-miss n m l (T x) τ2 with natEQ (l nat+ n) (↓Nat (1+ (l nat+ (n nat+ m))) 1 (↑Nat l (1+ (1+ (n nat+ m))) x)) + ... | Inl eq = abort (other-sub-shift-miss-var n m l x eq) + ... | Inr _ rewrite an-equation n m l x = refl + other-sub-shift-miss n m l ⦇-⦈ τ2 = refl + other-sub-shift-miss n m l (τ1 ==> τ3) τ2 rewrite other-sub-shift-miss n m l τ1 τ2 rewrite other-sub-shift-miss n m l τ3 τ2 = refl + other-sub-shift-miss n m l (·∀ τ1) τ2 rewrite other-sub-shift-miss n m (1+ l) τ1 τ2 = refl + + neq-relation : (n m x : Nat) → n ≠ x → 1+ (n nat+ m) ≠ x → (n nat+ m) ≠ (↓Nat n 1 x) + neq-relation Z m Z neq1 neq2 eq = neq1 refl + neq-relation Z m (1+ x) neq1 neq2 refl = neq2 refl + neq-relation (1+ n) m (1+ x) neq1 neq2 eq = neq-relation n m x (\ {refl → neq1 refl}) (\ {refl → neq2 refl}) (1+inj _ _ eq) + + neqs-relation : (n m x : Nat) → n ≠ x → 1+ (n nat+ m) ≠ x → n ≠ ↓Nat (1+ (n nat+ m)) 1 x + neqs-relation Z m Z neq1 neq2 eq = neq1 refl + neqs-relation (1+ n) m (1+ x) neq1 neq2 eq = neqs-relation n m x (\{ refl → neq1 refl}) (\{ refl → neq2 refl}) (1+inj _ _ eq) + + other-equation-nat-down : (n m x : Nat) → ↓Nat (n nat+ m) 1 (↓Nat n 1 x) == ↓Nat n 1 (↓Nat (1+ (n nat+ m)) 1 x) + other-equation-nat-down Z Z Z = refl + other-equation-nat-down Z m (1+ x) = refl + other-equation-nat-down Z (1+ m) Z = refl + other-equation-nat-down (1+ n) Z Z = refl + other-equation-nat-down (1+ n) m Z = refl + other-equation-nat-down (1+ n) m (1+ x) rewrite other-equation-nat-down n m x = refl + + subsub : (n m : Nat) → (τ1 τ2 τ3 : htyp) → TTSub (n nat+ m) τ1 (TTSub n τ2 τ3) == TTSub n (TTSub m τ1 τ2) (TTSub (1+ n nat+ m) τ1 τ3) + subsub n m τ1 τ2 b = refl + subsub n m τ1 τ2 ⦇-⦈ = refl + subsub n m τ1 τ2 (τ3 ==> τ4) rewrite subsub n m τ1 τ2 τ3 rewrite subsub n m τ1 τ2 τ4 = refl + subsub n m τ1 τ2 (·∀ τ3) rewrite subsub (1+ n) m τ1 τ2 τ3 = refl + subsub n m τ1 τ2 (T x) with natEQ n x + subsub n m τ1 τ2 (T x) | Inl refl with natEQ (1+ (n nat+ m)) n + subsub n m τ1 τ2 (T x) | Inl refl | Inl eq = abort (gt-neq _ _ eq) + subsub n m τ1 τ2 (T x) | Inl refl | Inr _ rewrite other-shift-miss n m with natEQ n n + subsub n m τ1 τ2 (T x) | Inl refl | Inr _ | Inr neq = abort (neq refl) + subsub n m τ1 τ2 (T x) | Inl refl | Inr _ | Inl refl = other-sub-shift n m Z τ1 τ2 + subsub n m τ1 τ2 (T x) | Inr neq with natEQ (1+ (n nat+ m)) x + subsub n m τ1 τ2 (T x) | Inr neq | Inl refl + rewrite gt-shift n m rewrite natEQrefl {n nat+ m} + rewrite other-sub-shift-miss n m Z τ1 (TTSub m τ1 τ2) = refl + subsub n m τ1 τ2 (T x) | Inr neq1 | Inr neq2 with natEQ (n nat+ m) (↓Nat n 1 x) + subsub n m τ1 τ2 (T x) | Inr neq1 | Inr neq2 | Inl eq = abort (neq-relation _ _ _ neq1 neq2 eq) + subsub n m τ1 τ2 (T x) | Inr neq1 | Inr neq2 | Inr _ with natEQ n (↓Nat (1+ (n nat+ m)) 1 x) + subsub n m τ1 τ2 (T x) | Inr neq1 | Inr neq2 | Inr _ | Inl eq = abort (neqs-relation n m x neq1 neq2 eq) + subsub n m τ1 τ2 (T x) | Inr neq1 | Inr neq2 | Inr _ | Inr neq3 rewrite other-equation-nat-down n m x = refl + + wt-TtSub-strong : ∀{m τ1 τ2 Γ d} → + (⊢ Γ ctxwf) → + (∅ ⊢ τ1 wf) → + (Γ ⊢ d :: τ2) → + (TCtxSub m τ1 Γ ⊢ TtSub m τ1 d :: TTSub m τ1 τ2) + wt-TtSub-strong ctxwf wf TAConst = TAConst + wt-TtSub-strong ctxwf wf (TAAp wt wt₁) = TAAp (wt-TtSub-strong ctxwf wf wt) (wt-TtSub-strong ctxwf wf wt₁) + wt-TtSub-strong {m} {τ1} ctxwf wf (TATAp {τ1 = τ2} {τ2 = τ3} x wt refl) = TATAp (wf-subst wf x) (wt-TtSub-strong ctxwf wf wt) (sym (subsub Z m τ1 τ2 τ3)) + wt-TtSub-strong ctxwf wf TAEHole = TAEHole + wt-TtSub-strong ctxwf wf (TANEHole wt) = TANEHole (wt-TtSub-strong ctxwf wf wt) + wt-TtSub-strong ctxwf wf (TACast wt x con) = TACast (wt-TtSub-strong ctxwf wf wt) (wf-subst wf x) (consist-sub con) + wt-TtSub-strong ctxwf wf (TALam x wt) = TALam (wf-subst wf x) (wt-TtSub-strong (CtxWFVar x ctxwf) wf wt) + wt-TtSub-strong ctxwf wf (TATLam wt) = TATLam (wt-TtSub-strong (CtxWFTVar ctxwf) wf wt) + wt-TtSub-strong ctxwf wf (TAVar x) = TAVar (inctx-subst x) + wt-TtSub-strong ctxwf wf (TAFailedCast wt GBase GBase incon) = abort (incon ConsistBase) + wt-TtSub-strong ctxwf wf (TAFailedCast wt GArr GArr incon) = abort (incon (ConsistArr ConsistHole1 ConsistHole1)) + wt-TtSub-strong ctxwf wf (TAFailedCast wt GForall GForall incon) = abort (incon (ConsistForall ConsistHole1)) + wt-TtSub-strong ctxwf wf (TAFailedCast wt GBase GArr incon) = TAFailedCast (wt-TtSub-strong ctxwf wf wt) GBase GArr incon + wt-TtSub-strong ctxwf wf (TAFailedCast wt GBase GForall incon) = TAFailedCast (wt-TtSub-strong ctxwf wf wt) GBase GForall incon + wt-TtSub-strong ctxwf wf (TAFailedCast wt GArr GBase incon) = TAFailedCast (wt-TtSub-strong ctxwf wf wt) GArr GBase incon + wt-TtSub-strong ctxwf wf (TAFailedCast wt GArr GForall incon) = TAFailedCast (wt-TtSub-strong ctxwf wf wt) GArr GForall incon + wt-TtSub-strong ctxwf wf (TAFailedCast wt GForall GBase incon) = TAFailedCast (wt-TtSub-strong ctxwf wf wt) GForall GBase incon + wt-TtSub-strong ctxwf wf (TAFailedCast wt GForall GArr incon) = TAFailedCast (wt-TtSub-strong ctxwf wf wt) GForall GArr incon + + wt-TtSub : ∀{d τ1 τ2} → + ∅ ⊢ τ1 wf → + (TVar, ∅) ⊢ d :: τ2 → + ∅ ⊢ TtSub Z τ1 d :: TTSub Z τ1 τ2 + wt-TtSub wf wt = wt-TtSub-strong (CtxWFTVar CtxWFEmpty) wf wt + + no-fvs-lemma-type : ∀{Γ t1 t2 τ} → (m : Nat) → context-counter Γ t1 t2 → Γ ⊢ τ wf → ↑ t2 m τ == τ + no-fvs-lemma-type m (CtxCtVar ctxct) (WFSkip wf) = no-fvs-lemma-type m ctxct wf + no-fvs-lemma-type m (CtxCtTVar ctxct) WFVarZ = refl + no-fvs-lemma-type m (CtxCtTVar ctxct) (WFVarS wf) with h1 (no-fvs-lemma-type m ctxct wf) + where + h1 : ∀{x1 x2} → T x1 == T x2 → x1 == x2 + h1 refl = refl + ... | eq rewrite eq = refl + no-fvs-lemma-type m ctxct WFBase = refl + no-fvs-lemma-type m ctxct WFHole = refl + no-fvs-lemma-type m ctxct (WFArr wf wf₁) rewrite no-fvs-lemma-type m ctxct wf rewrite no-fvs-lemma-type m ctxct wf₁ = refl + no-fvs-lemma-type m ctxct (WFForall wf) rewrite no-fvs-lemma-type m (CtxCtTVar ctxct) wf = refl + + inc-var-eq : ∀{x1 x2 : Nat} → (eq : Prelude._==_ {A = ihexp} (X x1) (X x2)) → (Prelude._==_ {A = ihexp} (X (1+ x1)) (X (1+ x2))) + inc-var-eq refl = refl + + no-fvs-lemma : ∀{Γ t1 t2 d τ} → (n m : Nat) → ⊢ Γ ctxwf → context-counter Γ t1 t2 → Γ ⊢ d :: τ → ↑d t1 n t2 m d == d + no-fvs-lemma n m ctxwf ctxct TAConst = refl + no-fvs-lemma n m ctxwf (CtxCtVar ctxct) (TAVar InCtxZ) = refl + no-fvs-lemma n m (CtxWFVar x₁ ctxwf) (CtxCtVar ctxct) (TAVar (InCtx1+ x)) = inc-var-eq (no-fvs-lemma n m ctxwf ctxct (TAVar x)) + no-fvs-lemma n m (CtxWFTVar ctxwf) (CtxCtTVar ctxct) (TAVar (InCtxSkip x)) = no-fvs-lemma n m ctxwf ctxct (TAVar x) + no-fvs-lemma n m ctxwf ctxct (TALam x wt) rewrite no-fvs-lemma-type m ctxct x rewrite no-fvs-lemma n m (CtxWFVar x ctxwf) (CtxCtVar ctxct) wt = refl + no-fvs-lemma n m ctxwf ctxct (TATLam wt) rewrite no-fvs-lemma n m (CtxWFTVar ctxwf) (CtxCtTVar ctxct) wt = refl + no-fvs-lemma n m ctxwf ctxct (TAAp wt wt₁) rewrite no-fvs-lemma n m ctxwf ctxct wt rewrite no-fvs-lemma n m ctxwf ctxct wt₁ = refl + no-fvs-lemma n m ctxwf ctxct (TATAp x wt x₁) rewrite no-fvs-lemma-type m ctxct x rewrite no-fvs-lemma n m ctxwf ctxct wt = refl + no-fvs-lemma n m ctxwf ctxct TAEHole = refl + no-fvs-lemma n m ctxwf ctxct (TANEHole wt) rewrite no-fvs-lemma n m ctxwf ctxct wt = refl + no-fvs-lemma n m ctxwf ctxct (TACast wt x x₁) rewrite no-fvs-lemma-type m ctxct x rewrite no-fvs-lemma-type m ctxct (wf-ta ctxwf wt) rewrite no-fvs-lemma n m ctxwf ctxct wt = refl + no-fvs-lemma n m ctxwf ctxct (TAFailedCast wt x x₁ x₂) rewrite no-fvs-lemma n m ctxwf ctxct wt rewrite no-fvs-lemma-type m ctxct (wf-gnd x) rewrite no-fvs-lemma-type m ctxct (wf-gnd x₁) = refl + + inctx-count1 : ∀{Γ n m τ1 τ2} → context-counter Γ n m → n , τ2 ∈ (Γ ctx+ (τ1 , ∅)) → τ2 == ↑ 0 m τ1 + inctx-count1 {τ1 = τ1} CtxCtEmpty InCtxZ rewrite ↑Z Z τ1 = refl + inctx-count1 (CtxCtVar ctxct) (InCtx1+ inctx) = inctx-count1 ctxct inctx + inctx-count1 {m = 1+ m} {τ1 = τ1} (CtxCtTVar ctxct) (InCtxSkip inctx) rewrite inctx-count1 ctxct inctx rewrite ↑compose Z m τ1 = refl + + inctx-count2 : ∀{Γ n m x τ1 τ2} → x ≠ n → context-counter Γ n m → x , τ2 ∈ (Γ ctx+ (τ1 , ∅)) → ↓Nat n 1 x , τ2 ∈ Γ + inctx-count2 neq CtxCtEmpty InCtxZ = abort (neq refl) + inctx-count2 neq (CtxCtVar ctxct) InCtxZ = InCtxZ + inctx-count2 neq (CtxCtVar ctxct) (InCtx1+ inctx) = InCtx1+ (inctx-count2 (\{refl → neq refl}) ctxct inctx) + inctx-count2 neq (CtxCtTVar ctxct) (InCtxSkip inctx) = InCtxSkip (inctx-count2 neq ctxct inctx) + + wt-ttSub-helper : ∀{Γ n m d1 d2 τ1 τ2} → + (⊢ Γ ctxwf) → + (context-counter Γ n m) → + (∅ ⊢ d1 :: τ1) → + ((Γ ctx+ (τ1 , ∅)) ⊢ d2 :: τ2) → + (Γ ⊢ ttSub n m d1 d2 :: τ2) + wt-ttSub-helper ctxwf ctxct wt1 TAConst = TAConst + wt-ttSub-helper ctxwf ctxct wt1 (TAAp wt2 wt3) = TAAp (wt-ttSub-helper ctxwf ctxct wt1 wt2) (wt-ttSub-helper ctxwf ctxct wt1 wt3) + wt-ttSub-helper ctxwf ctxct wt1 (TATAp x wt2 x₁) = TATAp (strengthen-wf-var-reverse x) (wt-ttSub-helper ctxwf ctxct wt1 wt2) x₁ + wt-ttSub-helper ctxwf ctxct wt1 TAEHole = TAEHole + wt-ttSub-helper ctxwf ctxct wt1 (TANEHole wt2) = TANEHole (wt-ttSub-helper ctxwf ctxct wt1 wt2) + wt-ttSub-helper ctxwf ctxct wt1 (TACast wt2 x x₁) = TACast (wt-ttSub-helper ctxwf ctxct wt1 wt2) (strengthen-wf-var-reverse x) x₁ + wt-ttSub-helper ctxwf ctxct wt1 (TAFailedCast wt2 x x₁ x₂) = TAFailedCast (wt-ttSub-helper ctxwf ctxct wt1 wt2) x x₁ x₂ + wt-ttSub-helper {Γ} {n} {m} {d1} ctxwf ctxct wt1 (TALam {τ1 = τ} {d = d} x wt2) = TALam (strengthen-wf-var-reverse x) (wt-ttSub-helper {Γ = (τ , Γ)} (CtxWFVar (strengthen-wf-var-reverse x) ctxwf) (CtxCtVar ctxct) wt1 wt2) + wt-ttSub-helper {Γ} {n} {m} {d1} ctxwf ctxct wt1 (TATLam {d = d} wt2) = TATLam (wt-ttSub-helper {Γ = (TVar, Γ)} (CtxWFTVar ctxwf) (CtxCtTVar ctxct) wt1 wt2) + wt-ttSub-helper {Γ} {n} {m} ctxwf ctxct wt1 (TAVar {n = x} inctx) with natEQ x n + wt-ttSub-helper {Γ} {n} {m} {d1} ctxwf ctxct wt1 (TAVar inctx) | Inl refl with wf-ta CtxWFEmpty wt1 + ... | wf rewrite no-fvs-lemma n m CtxWFEmpty CtxCtEmpty wt1 rewrite inctx-count1 ctxct inctx rewrite no-fvs-lemma-type m CtxCtEmpty wf = weakening-wt wt1 + wt-ttSub-helper {Γ} {n} {m} ctxwf ctxct wt1 (TAVar {n = x} inctx) | Inr neq = TAVar (inctx-count2 neq ctxct inctx) + + wt-ttSub : ∀{d1 d2 τ1 τ2} → + (∅ ⊢ d1 :: τ1) → + ((τ1 , ∅) ⊢ d2 :: τ2) → + (∅ ⊢ ttSub Z Z d1 d2 :: τ2) + wt-ttSub = wt-ttSub-helper CtxWFEmpty CtxCtEmpty + \ No newline at end of file diff --git a/weakening.agda b/weakening.agda index e7c275a..b001c18 100644 --- a/weakening.agda +++ b/weakening.agda @@ -1,89 +1,180 @@ open import Nat open import Prelude +open import core-type open import core -open import contexts -open import lemmas-disjointness -open import exchange --- this module contains all the proofs of different weakening structural --- properties that we use for the hypothetical judgements module weakening where - mutual - weaken-subst-Δ : ∀{Δ1 Δ2 Γ σ Γ'} → Δ1 ## Δ2 - → Δ1 , Γ ⊢ σ :s: Γ' - → (Δ1 ∪ Δ2) , Γ ⊢ σ :s: Γ' - weaken-subst-Δ disj (STAId x) = STAId x - weaken-subst-Δ disj (STASubst subst x) = STASubst (weaken-subst-Δ disj subst) (weaken-ta-Δ1 disj x) - - weaken-ta-Δ1 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2 - → Δ1 , Γ ⊢ d :: τ - → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ - weaken-ta-Δ1 disj TAConst = TAConst - weaken-ta-Δ1 disj (TAVar x₁) = TAVar x₁ - weaken-ta-Δ1 disj (TALam x₁ wt) = TALam x₁ (weaken-ta-Δ1 disj wt) - weaken-ta-Δ1 disj (TAAp wt wt₁) = TAAp (weaken-ta-Δ1 disj wt) (weaken-ta-Δ1 disj wt₁) - weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TAEHole {u = u} {Γ' = Γ'} x x₁) = TAEHole (x∈∪l Δ1 Δ2 u _ x ) (weaken-subst-Δ disj x₁) - weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TANEHole {Γ' = Γ'} {u = u} x wt x₁) = TANEHole (x∈∪l Δ1 Δ2 u _ x) (weaken-ta-Δ1 disj wt) (weaken-subst-Δ disj x₁) - weaken-ta-Δ1 disj (TACast wt x) = TACast (weaken-ta-Δ1 disj wt) x - weaken-ta-Δ1 disj (TAFailedCast wt x x₁ x₂) = TAFailedCast (weaken-ta-Δ1 disj wt) x x₁ x₂ - - -- this is a little bit of a time saver. since ∪ is commutative on - -- disjoint contexts, and we need that premise anyway in both positions, - -- there's no real reason to repeat the inductive argument above - weaken-ta-Δ2 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2 - → Δ2 , Γ ⊢ d :: τ - → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ - weaken-ta-Δ2 {Δ1} {Δ2} {Γ} {d} {τ} disj D = tr (λ q → q , Γ ⊢ d :: τ) (∪comm Δ2 Δ1 (##-comm disj)) (weaken-ta-Δ1 (##-comm disj) D) - - - -- note that these statements are somewhat stronger than usual. this is - -- because we don't have implcit α-conversion. this reifies the - -- often-silent on paper assumption that if you collide with a bound - -- variable you can just α-convert it away and not worry. - mutual - weaken-synth : ∀{ x Γ e τ τ'} → freshh x e - → Γ ⊢ e => τ - → (Γ ,, (x , τ')) ⊢ e => τ - weaken-synth FRHConst SConst = SConst - weaken-synth (FRHAsc frsh) (SAsc x₁) = SAsc (weaken-ana frsh x₁) - weaken-synth {Γ = Γ} (FRHVar {x = x} x₁) (SVar {x = y} x₂) = SVar (x∈∪l Γ (■(x , _)) y _ x₂) - weaken-synth {Γ = Γ} (FRHLam2 x₁ frsh) (SLam x₂ wt) = - SLam (apart-extend1 Γ (flip x₁) x₂) - (exchange-synth {Γ = Γ} (flip x₁) ((weaken-synth frsh wt))) - weaken-synth FRHEHole SEHole = SEHole - weaken-synth (FRHNEHole frsh) (SNEHole x₁ wt) = SNEHole x₁ (weaken-synth frsh wt) - weaken-synth (FRHAp frsh frsh₁) (SAp x₁ wt x₂ x₃) = SAp x₁ (weaken-synth frsh wt) x₂ (weaken-ana frsh₁ x₃) - - weaken-ana : ∀{x Γ e τ τ'} → freshh x e - → Γ ⊢ e <= τ - → (Γ ,, (x , τ')) ⊢ e <= τ - weaken-ana frsh (ASubsume x₁ x₂) = ASubsume (weaken-synth frsh x₁) x₂ - weaken-ana {Γ = Γ} (FRHLam1 neq frsh) (ALam x₂ x₃ wt) = - ALam (apart-extend1 Γ (flip neq) x₂) - x₃ - (exchange-ana {Γ = Γ} (flip neq) (weaken-ana frsh wt)) - - mutual - weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} → - envfresh x σ → - Δ , Γ ⊢ σ :s: Γ' → - Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ' - weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) ) - weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) = - STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst)) - (weaken-ta x₁ x₃) - - weaken-ta : ∀{x Γ Δ d τ τ'} → - fresh x d → - Δ , Γ ⊢ d :: τ → - Δ , Γ ,, (x , τ') ⊢ d :: τ - weaken-ta _ TAConst = TAConst - weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃) - weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y - weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl) - weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-extend1 Γ (flip x₁) x₄) (exchange-ta-Γ {Γ = Γ} (flip x₁) (weaken-ta x₃ wt)) - weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁) - weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃) - weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃) - weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁ - weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃ + + weakening-wf-var-n : ∀{Γ n τ τ'} → + ctx-extend-tvars n Γ ⊢ τ wf → + ctx-extend-tvars n (τ' , Γ) ⊢ τ wf + weakening-wf-var-n {n = Z} (WFSkip wf) = WFSkip (WFSkip wf) + weakening-wf-var-n {n = Z} WFVarZ = WFSkip WFVarZ + weakening-wf-var-n {n = Z} (WFVarS wf) = WFSkip (WFVarS wf) + weakening-wf-var-n {n = Z} WFBase = WFBase + weakening-wf-var-n {n = Z} WFHole = WFHole + weakening-wf-var-n {n = Z} (WFArr wf wf₁) = WFArr (weakening-wf-var-n wf) (weakening-wf-var-n wf₁) + weakening-wf-var-n {n = Z} (WFForall wf) = WFForall (weakening-wf-var-n wf) + weakening-wf-var-n {n = 1+ n} WFVarZ = WFVarZ + weakening-wf-var-n {n = 1+ n} (WFVarS wf) = WFVarS (weakening-wf-var-n wf) + weakening-wf-var-n {n = 1+ n} WFBase = WFBase + weakening-wf-var-n {n = 1+ n} WFHole = WFHole + weakening-wf-var-n {n = 1+ n} (WFArr wf wf₁) = WFArr (weakening-wf-var-n wf) (weakening-wf-var-n wf₁) + weakening-wf-var-n {n = 1+ n} (WFForall wf) = WFForall (weakening-wf-var-n wf) + + weakening-wf-var : ∀{Γ τ τ'} → + Γ ⊢ τ wf → + (τ' , Γ) ⊢ τ wf + weakening-wf-var = weakening-wf-var-n + + strengthen-wf-var-n : ∀{Γ n τ τ'} → + ctx-extend-tvars n (τ' , Γ) ⊢ τ wf → + ctx-extend-tvars n Γ ⊢ τ wf + strengthen-wf-var-n {n = Z} (WFSkip wf) = wf + strengthen-wf-var-n {n = Z} WFBase = WFBase + strengthen-wf-var-n {n = Z} WFHole = WFHole + strengthen-wf-var-n {n = Z} (WFArr wf wf₁) = WFArr (strengthen-wf-var-n wf) (strengthen-wf-var-n wf₁) + strengthen-wf-var-n {n = Z} (WFForall wf) = WFForall (strengthen-wf-var-n wf) + strengthen-wf-var-n {n = 1+ n} WFVarZ = WFVarZ + strengthen-wf-var-n {n = 1+ n} (WFVarS wf) = WFVarS (strengthen-wf-var-n wf) + strengthen-wf-var-n {n = 1+ n} WFBase = WFBase + strengthen-wf-var-n {n = 1+ n} WFHole = WFHole + strengthen-wf-var-n {n = 1+ n} (WFArr wf wf₁) = WFArr (strengthen-wf-var-n wf) (strengthen-wf-var-n wf₁) + strengthen-wf-var-n {n = 1+ n} (WFForall wf) = WFForall (strengthen-wf-var-n wf) + + strengthen-wf-var : ∀{Γ τ τ'} → + (τ' , Γ) ⊢ τ wf → + Γ ⊢ τ wf + strengthen-wf-var = strengthen-wf-var-n + + strengthen-wf-var-reverse-n : ∀{Γ n τ τ'} → + ctx-extend-tvars n (Γ ctx+ (τ' , ∅)) ⊢ τ wf → + ctx-extend-tvars n Γ ⊢ τ wf + strengthen-wf-var-reverse-n {Γ = x , Γ} {n = Z} (WFSkip wf) = WFSkip (strengthen-wf-var-reverse-n {n = Z} wf) + strengthen-wf-var-reverse-n {Γ = TVar, Γ} {n = Z} (WFVarS wf) = WFVarS (strengthen-wf-var-reverse-n {n = Z} wf) + strengthen-wf-var-reverse-n {Γ = Γ} {n = 1+ n} (WFVarS wf) = WFVarS (strengthen-wf-var-reverse-n {n = n} wf) + strengthen-wf-var-reverse-n {n = 1+ n} WFVarZ = WFVarZ + strengthen-wf-var-reverse-n {Γ = TVar, Γ} {n = Z} WFVarZ = WFVarZ + strengthen-wf-var-reverse-n WFBase = WFBase + strengthen-wf-var-reverse-n WFHole = WFHole + strengthen-wf-var-reverse-n {n = n} (WFArr wf wf₁) = WFArr (strengthen-wf-var-reverse-n {n = n} wf) (strengthen-wf-var-reverse-n {n = n} wf₁) + strengthen-wf-var-reverse-n {n = n} (WFForall wf) = WFForall (strengthen-wf-var-reverse-n {n = 1+ n} wf) + + strengthen-wf-var-reverse : ∀{Γ τ τ'} → + (Γ ctx+ (τ' , ∅)) ⊢ τ wf → + Γ ⊢ τ wf + strengthen-wf-var-reverse wf = strengthen-wf-var-reverse-n {n = Z} wf + + weakening-wf-tvar : ∀{Γ τ} → + Γ ⊢ τ wf → + (TVar, Γ) ⊢ τ wf + weakening-wf-tvar (WFSkip {n = Z} wf) = WFVarZ + weakening-wf-tvar (WFSkip {x , Γ} {n = 1+ n} (WFSkip wf)) with weakening-wf-tvar wf + ... | WFVarS wf' = WFVarS (WFSkip (WFSkip wf')) + weakening-wf-tvar (WFSkip {TVar, Γ} {n = 1+ n} wf) with weakening-wf-tvar wf + ... | WFVarS wf' = WFVarS (WFSkip wf') + weakening-wf-tvar WFVarZ = WFVarZ + weakening-wf-tvar (WFVarS wf) = WFVarS (weakening-wf-tvar wf) + weakening-wf-tvar WFBase = WFBase + weakening-wf-tvar WFHole = WFHole + weakening-wf-tvar (WFArr wf wf₁) = WFArr (weakening-wf-tvar wf) (weakening-wf-tvar wf₁) + weakening-wf-tvar (WFForall wf) = WFForall (weakening-wf-tvar wf) + + wf-swap-tvar : ∀{Γ τ} → (Γ ctx+ (TVar, ∅)) ⊢ τ wf → (TVar, Γ) ⊢ τ wf + wf-swap-tvar {∅} WFVarZ = WFVarZ + wf-swap-tvar WFBase = WFBase + wf-swap-tvar WFHole = WFHole + wf-swap-tvar (WFArr wf wf₁) = WFArr (wf-swap-tvar wf) (wf-swap-tvar wf₁) + wf-swap-tvar (WFForall wf) = WFForall (wf-swap-tvar wf) + wf-swap-tvar {x , Γ} (WFSkip wf) with wf-swap-tvar wf + ... | wf' = weakening-wf-var-n wf' + wf-swap-tvar {TVar, Γ} WFVarZ = WFVarZ + wf-swap-tvar {TVar, Γ} (WFVarS wf) = WFVarS (wf-swap-tvar wf) + + weakening-wf : ∀{Γ1 Γ2 τ} → Γ1 ⊢ τ wf → (Γ1 ctx+ Γ2) ⊢ τ wf + weakening-wf (WFSkip wf) = WFSkip (weakening-wf wf) + weakening-wf WFVarZ = WFVarZ + weakening-wf (WFVarS wf) = WFVarS (weakening-wf wf) + weakening-wf WFBase = WFBase + weakening-wf WFHole = WFHole + weakening-wf (WFArr wf wf₁) = WFArr (weakening-wf wf) (weakening-wf wf₁) + weakening-wf (WFForall wf) = WFForall (weakening-wf wf) + + weakening-inctx : ∀{Γ1 Γ2 n τ} → n , τ ∈ Γ1 → n , τ ∈ (Γ1 ctx+ Γ2) + weakening-inctx (InCtxSkip inctx) = InCtxSkip (weakening-inctx inctx) + weakening-inctx InCtxZ = InCtxZ + weakening-inctx (InCtx1+ inctx) = InCtx1+ (weakening-inctx inctx) + + weakening-wt : ∀{Γ1 Γ2 d τ} → Γ1 ⊢ d :: τ → (Γ1 ctx+ Γ2) ⊢ d :: τ + weakening-wt TAConst = TAConst + weakening-wt (TAVar x) = TAVar (weakening-inctx x) + weakening-wt (TALam x wt) = TALam (weakening-wf x) (weakening-wt wt) + weakening-wt (TATLam wt) = TATLam (weakening-wt wt) + weakening-wt (TAAp wt wt₁) = TAAp (weakening-wt wt) (weakening-wt wt₁) + weakening-wt (TATAp x wt x₁) = TATAp (weakening-wf x) (weakening-wt wt) x₁ + weakening-wt TAEHole = TAEHole + weakening-wt (TANEHole wt) = TANEHole (weakening-wt wt) + weakening-wt (TACast wt x x₁) = TACast (weakening-wt wt) (weakening-wf x) x₁ + weakening-wt (TAFailedCast wt x x₁ x₂) = TAFailedCast (weakening-wt wt) x x₁ x₂ + + -- weakening-varwf : ∀{Γ n} → + -- Γ ⊢ n varwf → + -- (TVar, Γ) ⊢ n varwf + -- weakening-varwf (WFSkip varwf) = WFVarZ + -- weakening-varwf WFVarZ = WFVarZ + -- weakening-varwf (WFVarS varwf) = WFVarS (weakening-varwf varwf) + + -- weakening-wf-tvar : ∀{Γ τ} → + -- Γ ⊢ τ wf → + -- (TVar, Γ) ⊢ τ wf + -- weakening-wf-tvar (WFVar varwf) = WFVar (weakening-varwf varwf) + -- weakening-wf-tvar WFBase = WFBase + -- weakening-wf-tvar WFHole = WFHole + -- weakening-wf-tvar (WFArr wf wf₁) = WFArr (weakening-wf-tvar wf) (weakening-wf-tvar wf₁) + -- weakening-wf-tvar (WFForall wf) = WFForall (weakening-wf-tvar wf) + + -- weakening-n : ∀{Θ τ n} → + -- Θ ⊢ τ wf → + -- (n nat+ Θ) ⊢ τ wf + -- weakening-n {n = Z} wf = wf + -- weakening-n {n = 1+ n} wf = weakening (weakening-n wf) + + -- weakening-ctx : ∀{Θ Γ} → + -- ⊢ Γ ctxwf → + -- 1+ Θ ⊢ Γ ctxwf + -- weakening-ctx CtxWFEmpty = CtxWFEmpty + -- weakening-ctx (CtxWFExtend wf ctxwf) = CtxWFExtend (weakening wf) (weakening-ctx ctxwf) + + -- weakening-wt : ∀{Γ d τ} → + -- Γ ⊢ d :: τ → + -- (TVar, Γ) ⊢ d :: τ + -- weakening-wt TAConst = TAConst + -- weakening-wt (TAVar x) = TAVar (InCtxSkip x) + -- weakening-wt (TALam x wt) = TALam (weakening-wf-tvar x) {! !} + -- weakening-wt (TATLam wt) = TATLam (weakening-wt wt) + -- weakening-wt (TAAp wt wt₁) = TAAp (weakening-wt wt) (weakening-wt wt₁) + -- weakening-wt (TATAp x wt x₁) = TATAp (weakening-wf-tvar x) (weakening-wt wt) x₁ + -- weakening-wt (TAEHole x) = TAEHole (weakening-wf-tvar x) + -- weakening-wt (TANEHole x wt) = TANEHole (weakening-wf-tvar x) (weakening-wt wt) + -- weakening-wt (TACast wt x x₁) = TACast (weakening-wt wt) (weakening-wf-tvar x) x₁ + -- weakening-wt (TAFailedCast wt x x₁ x₂) = TAFailedCast (weakening-wt wt) x x₁ x₂ + + -- weakening-wt-n : ∀{Θ Γ d τ n} → + -- Θ , Γ ⊢ d :: τ → + -- (n nat+ Θ) , Γ ⊢ d :: τ + -- weakening-wt-n {n = Z} wt = wt + -- weakening-wt-n {n = 1+ n} wt = weakening-wt (weakening-wt-n wt) + + -- strengthen-var : ∀{Θ n} → + -- (Θ ≠ 1+ n) → + -- (Θ ⊢ T n wf) → + -- Θ ⊢ T (1+ n) wf + -- strengthen-var {Θ = 1+ Z} neq WFVarZ = abort (neq refl) + -- strengthen-var {Θ = 1+ (1+ Θ)} neq WFVarZ = WFVarS WFVarZ + -- strengthen-var {Θ = 1+ Z} neq (WFVarS ()) + -- strengthen-var {Θ = 1+ (1+ Θ)} neq (WFVarS {n = n} wf) = WFVarS (strengthen-var h1 wf) + -- where + -- h1 : 1+ Θ ≠ 1+ n + -- h1 eq with (sym eq) + -- ... | refl = neq refl + \ No newline at end of file