├── .gitignore ├── Dockerfile ├── LICENSE.txt ├── Nat.agda ├── Prelude.agda ├── README.md ├── ae-reviews.txt ├── all.agda ├── binders-disjoint-checks.agda ├── canonical-boxed-forms.agda ├── canonical-indeterminate-forms.agda ├── canonical-value-forms.agda ├── cast-inert.agda ├── check.sh ├── complete-elaboration.agda ├── complete-preservation.agda ├── complete-progress.agda ├── contexts.agda ├── continuity.agda ├── contraction.agda ├── core.agda ├── disjointness.agda ├── dom-eq.agda ├── elaborability.agda ├── elaboration-generality.agda ├── elaboration-unicity.agda ├── exchange.agda ├── finality.agda ├── focus-formation.agda ├── ground-decidable.agda ├── grounding.agda ├── holes-disjoint-checks.agda ├── htype-decidable.agda ├── lemmas-complete.agda ├── lemmas-consistency.agda ├── lemmas-disjointness.agda ├── lemmas-freshness.agda ├── lemmas-gcomplete.agda ├── lemmas-ground.agda ├── lemmas-matching.agda ├── lemmas-progress-checks.agda ├── lemmas-subst-ta.agda ├── postulates.sh ├── preservation.agda ├── progress-checks.agda ├── progress.agda ├── status.sh ├── synth-unicity.agda ├── type-assignment-unicity.agda ├── typed-elaboration.agda └── weakening.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | from haskell:8.4.3 2 | run cabal update 3 | run cabal install alex 4 | run cabal install happy 5 | run cabal install Agda-2.5.4.2 6 | copy . . 7 | cmd ["agda" , "-v", "2" , "all.agda"] 8 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Ian Voysey 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Nat.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | 3 | module Nat where 4 | data Nat : Set where 5 | Z : Nat 6 | 1+ : Nat → Nat 7 | 8 | {-# BUILTIN NATURAL Nat #-} 9 | 10 | -- the succ operation is injective 11 | 1+inj : (x y : Nat) → (1+ x == 1+ y) → x == y 12 | 1+inj Z .0 refl = refl 13 | 1+inj (1+ x) .(1+ x) refl = refl 14 | 15 | -- equality of naturals is decidable. we represent this as computing a 16 | -- choice of units, with inl <> meaning that the naturals are indeed the 17 | -- same and inr <> that they are not. 18 | natEQ : (x y : Nat) → ((x == y) + ((x == y) → ⊥)) 19 | natEQ Z Z = Inl refl 20 | natEQ Z (1+ y) = Inr (λ ()) 21 | natEQ (1+ x) Z = Inr (λ ()) 22 | natEQ (1+ x) (1+ y) with natEQ x y 23 | natEQ (1+ x) (1+ .x) | Inl refl = Inl refl 24 | ... | Inr b = Inr (λ x₁ → b (1+inj x y x₁)) 25 | -------------------------------------------------------------------------------- /Prelude.agda: -------------------------------------------------------------------------------- 1 | module Prelude where 2 | open import Agda.Primitive using (Level; lzero; lsuc) renaming (_⊔_ to lmax) 3 | 4 | -- empty type 5 | data ⊥ : Set where 6 | 7 | -- from false, derive whatever 8 | abort : ∀ {C : Set} → ⊥ → C 9 | abort () 10 | 11 | -- unit 12 | data ⊤ : Set where 13 | <> : ⊤ 14 | 15 | -- sums 16 | data _+_ (A B : Set) : Set where 17 | Inl : A → A + B 18 | Inr : B → A + B 19 | 20 | -- pairs 21 | infixr 1 _,_ 22 | record Σ {l1 l2 : Level} (A : Set l1) (B : A → Set l2) : Set (lmax l1 l2) where 23 | constructor _,_ 24 | field 25 | π1 : A 26 | π2 : B π1 27 | open Σ public 28 | 29 | -- Sigma types, or dependent pairs, with nice notation. 30 | syntax Σ A (\ x -> B) = Σ[ x ∈ A ] B 31 | 32 | _×_ : {l1 : Level} {l2 : Level} → (Set l1) → (Set l2) → Set (lmax l1 l2) 33 | A × B = Σ A λ _ → B 34 | 35 | infixr 1 _×_ 36 | infixr 1 _+_ 37 | 38 | -- equality 39 | data _==_ {l : Level} {A : Set l} (M : A) : A → Set l where 40 | refl : M == M 41 | 42 | infixr 9 _==_ 43 | 44 | -- disequality 45 | _≠_ : {l : Level} {A : Set l} → (a b : A) → Set l 46 | a ≠ b = (a == b) → ⊥ 47 | 48 | {-# BUILTIN EQUALITY _==_ #-} 49 | 50 | -- transitivity of equality 51 | _·_ : {l : Level} {α : Set l} {x y z : α} → x == y → y == z → x == z 52 | refl · refl = refl 53 | 54 | -- symmetry of equality 55 | ! : {l : Level} {α : Set l} {x y : α} → x == y → y == x 56 | ! refl = refl 57 | 58 | -- ap, in the sense of HoTT, that all functions respect equality in their 59 | -- arguments. named in a slightly non-standard way to avoid naming 60 | -- clashes with hazelnut constructors. 61 | ap1 : {l1 l2 : Level} {α : Set l1} {β : Set l2} {x y : α} (F : α → β) 62 | → x == y → F x == F y 63 | ap1 F refl = refl 64 | 65 | -- transport, in the sense of HoTT, that fibrations respect equality 66 | tr : {l1 l2 : Level} {α : Set l1} {x y : α} 67 | (B : α → Set l2) 68 | → x == y 69 | → B x 70 | → B y 71 | tr B refl x₁ = x₁ 72 | 73 | -- options 74 | data Maybe (A : Set) : Set where 75 | Some : A → Maybe A 76 | None : Maybe A 77 | 78 | -- the some constructor is injective. perhaps unsurprisingly. 79 | someinj : {A : Set} {x y : A} → Some x == Some y → x == y 80 | someinj refl = refl 81 | 82 | -- some isn't none. 83 | somenotnone : {A : Set} {x : A} → Some x == None → ⊥ 84 | somenotnone () 85 | 86 | -- function extensionality, used to reason about contexts as finite 87 | -- functions. 88 | postulate 89 | funext : {A : Set} {B : A → Set} {f g : (x : A) → (B x)} → ((x : A) → f x == g x) → f == g 90 | 91 | -- non-equality is commutative 92 | flip : {A : Set} {x y : A} → (x == y → ⊥) → (y == x → ⊥) 93 | flip neq eq = neq (! eq) 94 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hazelnut-dynamics-agda 2 | This repository is the mechanization of the work described in our 3 | [POPL19 paper](https://arxiv.org/pdf/1805.00155). It includes all of the 4 | definitions and proofs from Section 3, as claimed in Sec. 3.4 (Agda 5 | Mechanization). 6 | 7 | # How To Check These Proofs 8 | 9 | These proofs are known to check under `Agda 2.6.2`. The most direct, if 10 | not the easiest, option to check the proofs is to install that version of 11 | Agda or one compatible with it, download the code in this repo, and run 12 | `agda all.agda` at the command line. 13 | 14 | Alternatively, we have provided a [Docker file](Dockerfile) to make it 15 | easier to build that environment and check the proofs. To use it, first 16 | install [Docker](https://www.docker.com/products/docker-desktop), make sure 17 | the Docker daemon is running, and clone this repository to your local 18 | machine. Then, at a command line inside that clone, run 19 | 20 | ``` 21 | docker build -t hazel-popl19 . 22 | ``` 23 | 24 | This may take a fair amount of time. When it finishes, run 25 | 26 | ``` 27 | docker run hazel-popl19 28 | ``` 29 | 30 | This should take less than a minute, produce a lot of output as Agda checks 31 | each module and function, and end with either the line `Finished all.` or 32 | `Loading all (/all.agdai).` to indicate success, depending on Docker-level 33 | caching. 34 | 35 | Most text editors that support Agda can be configured to use the version 36 | instead a Docker container instead of your host machine, so you can 37 | experiment with or evolve this code without making too much of a mess. For 38 | some example instructions, see [the docker-agda 39 | repo](https://github.com/banacorn/docker-agda). 40 | 41 | # Where To Find Each Theorem 42 | 43 | All of the judgements defined in the paper are given in 44 | [core.agda](core.agda). The syntax is meant to mirror the on-paper notation 45 | as closely as possible, with some small variations because of the 46 | limitations of Agda syntax. 47 | 48 | For easy reference, the proofs for the theorems in order of appearance in 49 | the paper text can be found as follows: 50 | 51 | - Theorem 3.1, _Typed Elaboration_, is in 52 | [typed-elaboration.agda](typed-elaboration.agda). 53 | - Theorem 3.2, _Type Assignment Unicity_, is in 54 | [type-assignment-unicity.agda](type-assignment-unicity.agda). 55 | - Theorem 3.3, _Elaborability_, is in 56 | [elaborability.agda](elaborability.agda). 57 | - Theorem 3.4, _Elaboration Generality_, is in 58 | [elaboration-generality.agda](elaboration-generality.agda). 59 | - Theorem 3.5, _Elaboration Unicity_, is in 60 | [elaboration-unicity.agda](elaboration-unicity.agda). 61 | - Definition 3.6, _Identity Substitution_, is in [core.agda](core.agda) on 62 | line 31. 63 | - Definition 3.7, _Substitution Typing_, is in [core.agda](core.agda) on 64 | line 252. 65 | - Theorem 3.8, _Finality_, is in [finality.agda](finality.agda). 66 | - Lemma 3.9, _Grounding_, is in [grounding.agda](grounding.agda). 67 | - Theorem 3.10, _Preservation_, is in 68 | [preservation.agda](preservation.agda). 69 | - Theorem 3.11, _Progress_, is in [progress.agda](progress.agda). 70 | - Theorem 3.12, _Complete Elaboration_, is in 71 | [complete-elaboration.agda](complete-elaboration.agda). 72 | - Theorem 3.13, _Complete Preservation_, is in 73 | [complete-preservation.agda](complete-preservation.agda). 74 | - Theorem 3.14, _Complete Progress_, is in 75 | [complete-progress.agda](complete-progress.agda). 76 | - Proposition 3.15, _Sensibility_, is taken as a postulate in 77 | [continuity.agda](continuity.agda). Sensibility for a slightly different 78 | and richer language is proven in the mechanization of our 79 | [POPL17](https://arxiv.org/pdf/1607.04180) work. 80 | - Corollary 3.16, _Continuity_, is in 81 | [continuity.agda](continuity.agda). Though we did not explicitly claim a 82 | mechanization of this claim, we give a proof is given in terms of a few 83 | postulates encoding the results from Omar et al., POPL 2017. 84 | 85 | The extended paper with an appendix goes into more detail for some lemmas 86 | and definitions omitted from the main paper, some of which have been 87 | mechanized as well. Those can be found as follows: 88 | 89 | - A.1, _Substitution_, is defined in [core.agda](core.agda) at line 294, as 90 | `[_/_]_` for terms and `apply-env` for substitutions `σ`. 91 | - Lemma A.1, _Substitution_ is in 92 | [lemmas-subst-ta.agda](lemmas-subst-ta.agda). 93 | - Lemma A.2, _Canonical Value Forms_, is in 94 | [canonical-value-forms.agda](canonical-value-forms.agda). 95 | - Lemma A.3, _Canonical Boxed Forms_, is in 96 | [canonical-boxed-forms.agda](canonical-value-forms.agda). 97 | - Lemma A.4, _Canonical Indeterminate Forms_, is in 98 | [canonical-indeterminate-forms.agda](canonical-value-forms.agda). 99 | - A.3, _Complete Programs_, is defined in [core.agda](core.agda) at line 100 | 160. 101 | - Definition A.5, _Typing Context Completeness_, is defined in 102 | [core.agda](core.agda) at line 183. 103 | - Lemma A.6, _Complete Consistency_, is in 104 | [lemmas-complete.agda](lemmas-complete.agda) as `complete-consistency` on 105 | line 19. 106 | - Lemma A.7, _Complete Casts_, is in [cast-inert.agda](cast-inert.agda) as 107 | `complete-casts` on line 31. 108 | - A.4, _Multiple Steps_, is defined in [core.agda](core.agda) on line 470. 109 | 110 | # Description of Agda Files 111 | 112 | The theorem statements rely on a variety of lemmas and smaller claims or 113 | observations that aren't explicitly mentioned in the paper text. What 114 | follows is a rough description of what to expect from each source file; 115 | more detail is provided in the comments inside each. 116 | 117 | On paper, we typically take it for granted that we can silently α-rename 118 | terms to equivalent terms whenever a collision of bound names is 119 | inconvenient. In a mechanization, we do not have that luxury and instead 120 | must be explicit in our treatment of binders in one way or another. In our 121 | development here, we assume that all terms are in an α-normal form where 122 | binders are globally not reused. 123 | 124 | That manifests in this development where we have chosen to add premises 125 | that binders are unique within a term or disjoint between terms when 126 | needed. These premises are fairly benign, since α-equivalence tells us they 127 | can always be satisfied without changing the meaning of the term in 128 | question. Other standard approaches include using de Bruijn indices, 129 | Abstract Binding Trees, HOAS, or PHOAS to actually rewrite the terms when 130 | needed. We have chosen not to use these techniques because _almost all_ of 131 | the theory we're interested in does not need them and their overhead 132 | quickly becomes pervasive, obfuscating the actual points of interest. 133 | 134 | Similarly, we make explicit some premises about disjointness of contexts or 135 | variables being apart from contexts in some of the premises of some rules 136 | that would typically be taken as read in an on-paper presentation. This is 137 | a slightly generalized version of Barendrecht's convention (Barendregt, 138 | 1984), which we also used in our [POPL17 139 | mechanization](https://github.com/hazelgrove/agda-popl17) for the same 140 | reason. 141 | 142 | Since the type system for external terms is bidirectional, the judgments 143 | defining it are mutually recursive. That means that anything type-directed 144 | is very likely to also be mutually recursive. The grammar of internal 145 | expressions is also mutually recursive with the definition of substitution 146 | environments. All told, a fair number of theorems are mutually recursive as 147 | this percolates through. We try to name things in a suggestive way, using 148 | `x-synth` and `x-ana` for the two halves of a theorem named `x`. 149 | 150 | Both hole and type contexts are encoded as Agda functions from natural 151 | numbers to optional contents. In practice these mappings are always 152 | finite. We represent finite substitutions and substitution environments 153 | explicitly as inductive datatypes, `_,_⊢_:s:_`and `env` from 154 | [core.agda](core.agda) respectively, taking advantage of the fact that the 155 | base case in our semantics is always the identity substitution. This allows 156 | us to reason about substitutions in a well-founded way that passes the Agda 157 | termination checker. 158 | 159 | ## Postulates 160 | 161 | We have benign postulates in two places: 162 | 163 | - First, we postulate function extensionality in 164 | [Prelude.agda](Prelude.agda), because it is known to be independent from 165 | Agda and we use it to reason about contexts. 166 | 167 | - Second, in [continuity.agda](continuity.agda), we postulate some 168 | judgemental forms and theorems from our POPL17 mechanization in order to 169 | demonstrate the connections to it described in the paper. We also 170 | postulate some glue code that allows us to use those theorems in this 171 | work. 172 | 173 | There are no other postulates in this development. 174 | 175 | ## Meta 176 | - [all.agda](all.agda) is morally a make file: it includes every module in 177 | every other file, so running `$ agda all.agda` on a clean clone of this 178 | repository will recheck every proof from scratch. It is known to load 179 | cleanly with `Agda version 2.6.2`; we have not tested it on any other 180 | version. 181 | 182 | ## Prelude and Datatypes 183 | 184 | These files give definitions and syntactic sugar for common elements of 185 | type theory (sum types, products, sigmas, etc.) and natural numbers that 186 | are used pervasively throughout the rest of the development. 187 | 188 | - [Nat.agda](Nat.agda) 189 | - [Prelude.agda](Prelude.agda) 190 | 191 | ## Core Definitions 192 | 193 | - [contexts.agda](contexts.agda) defines contexts as functions from natural 194 | numbers to possible contents and proves a collection of lemmas that makes 195 | this definition practical. 196 | - [core.agda](core.agda) gives the definitions of all the grammars and 197 | judgements in the order presented in the paper as types and metafunctions 198 | in Agda. It also includes the definition of the judgements that are used 199 | implicitly on paper but need to be made explicit in a mechanization. 200 | 201 | ## Structural Properties 202 | 203 | - [contraction.agda](contraction.agda) argues that contexts are the same up 204 | to contraction, and therefore that every judgement that uses them enjoys 205 | the contraction property. Note that this proof is given for any sort of 206 | context, so it establishes contraction in both the type and hole contexts 207 | for those judgements that have both. 208 | - [exchange.agda](exchange.agda) argues that contexts are the same up to 209 | exchange, and therefore that every judgement that uses the enjoys the 210 | exchange property. As above, this proof establishes exchange in both the 211 | type and hole contexts for those jugements that have both. 212 | - [weakening.agda](weakening.agda) argues the weakening properties for 213 | those judgements where we needed it in the other proofs. This is not 214 | every weakening property for every judgement, and indeed some of them _do 215 | not_ enjoy weakening in every argument. 216 | 217 | For example, the elaborations do not support weakening in the typing 218 | context because the rule for substitution typing requires that the lowest 219 | substitution be exactly the identity, not something that can be weakened 220 | to the identity. (See the definition of `STAId` on line 254 of 221 | [core.agda](core.agda).) In practice, this is not a problem because you 222 | wouldn't want to add anything there just to weaken it away, and allowing 223 | imprecision here would break the [unicity of 224 | elaboration](elaboration-unicity.agda). 225 | 226 | ## Theorems 227 | 228 | ### Canonical Forms 229 | 230 | Together, these files give the canonical forms lemma for the language. 231 | 232 | - [canonical-boxed-forms.agda](canonical-boxed-forms.agda) 233 | - [canonical-indeterminate-forms.agda](canonical-indeterminate-forms.agda) 234 | - [canonical-value-forms.agda](canonical-value-forms.agda) 235 | 236 | ### Metatheory of Type Assignment 237 | 238 | - [type-assignment-unicity.agda](type-assignment-unicity.agda) argues that 239 | the type assignment system assigns at most one type to any term. 240 | 241 | ### Metatheory of Elaboration 242 | 243 | - [elaboration-generality.agda](elaboration-generality.agda) argues that 244 | the elaboration judgements respect the bidirectional typing system. 245 | - [elaborability.agda](elaborability.agda) argues that any well typed 246 | external term can be elaborated to a internal term. 247 | - [elaboration-unicity.agda](elaboration-unicity.agda) argues that 248 | elaboration produces at most one result. 249 | - [typed-elaboration.agda](typed-elaboration.agda) argues that the 250 | elaboration respects the type assignment system. 251 | 252 | ### Type Safety 253 | 254 | These files contain proofs of type safety for the internal language. Note 255 | that we only give a dynamic semantics for the internal language, which is 256 | related to the external language through elaboration. 257 | 258 | - [progress.agda](progress.agda) argues that any well typed internal 259 | expression either steps, is a boxed value, or is indeterminate. 260 | - [progress-checks.agda](progress-checks.agda) argues that the clauses in 261 | the conclusion of progress are pairwise disjoint---i.e. that no 262 | expression both steps and is a boxed value, and so on. 263 | - [preservation.agda](preservation.agda) argues that stepping preserves 264 | type assignment. 265 | 266 | This is the main place that our assumption about α-normal terms appears: 267 | the statement of preservation makes explicit the standard on-paper 268 | convention that binders not be reused in its argument. 269 | 270 | We also argue that our dynamics is a conservative extension in the sense 271 | that if you use it to evaluate terms that happen to have no holes in them, 272 | you get the standard type safety theorems you might expect for the 273 | restricted fragment without holes. 274 | 275 | - [complete-elaboration.agda](complete-elaboration.agda) argues that the 276 | elaboration of a complete external term produces a complete internal 277 | term. 278 | - [complete-preservation.agda](complete-preservation.agda) argues that 279 | stepping a complete term produces a complete term that is assigned the 280 | same type, again with an explicit assumption about binder uniqueness. 281 | - [complete-progress.agda](complete-progress.agda) argues that complete 282 | terms are either a value or step. 283 | 284 | ### Metatheory of Continuity 285 | 286 | - [continuity.agda](continuity.agda) includes a sketch of a proof of 287 | continuity. This is built on postulates of a result from our POPL17 work 288 | and a few properties that would need to be proven about the expression 289 | forms from that work and the α-normal requirement we have in this work. 290 | 291 | ## Lemmas and Smaller Claims 292 | 293 | 294 | These files each establish smaller claims that are either not mentioned in 295 | the paper or mentioned only in passing. In terms of complexity and 296 | importance, they're somewhere between a lemma and a theorem. 297 | 298 | - [binders-disjoint-checks.agda](binders-disjoint-checks.agda) contains 299 | some proofs that demonstrate that `binders-disjoint` acts as 300 | expected. That judgement is defined inductively only on its left 301 | argument; since Agda datatypes do not define functions, explicit lemmas 302 | are needed to get the expected reduction behaivour in the right argument. 303 | - [cast-inert.agda](cast-inert.agda) gives a judgemental removal of 304 | identity casts and argues that doing so does not change the type of the 305 | expression. It would also be possible to argue that removing the identity 306 | casts produces a term that evaluates in the same way---but identity cast 307 | removal is a syntactic operation that goes under binders while our 308 | evaluation semantics does not. To establish that result, we'd need to 309 | also give an equational theory of evaluation compatible with the given 310 | one. 311 | - [disjointness.agda](disjointness.agda) characterizes the output hole 312 | contexts produced in elaboration, including disjointness guarantees 313 | needed in the proofs of [Elaborability](elaborability.agda) and 314 | [Elaboration Generality](elaboration-generality.agda). 315 | - [dom-eq.agda](dom-eq.agda) defines when two contexts have the same 316 | domain, regardless of the range type or contents, and some operations 317 | that preserve that property. This is used in the proofs in 318 | [disjointness.agda](disjointness.agda). 319 | - [finality.agda](finality.agda) argues that a final expression doesn't 320 | step, and only multi-steps to itself. More properties of this nature are 321 | proven in [progress-checks.agda](progress-checks.agda) but not called out 322 | explicitly in the paper. 323 | - [focus-formation.agda](focus-formation.agda) argues that every `ε` is an 324 | evaluation context. As noted in [core.agda](core.agda), because we elide 325 | the boxed-in-red finality premises from the stepping rules, every `ε` is 326 | trivially an evaluation context, so this proof is extremely immediate; it 327 | would be slightly more involved if those premises were in place. 328 | - [ground-decidable.agda](ground-decidable.agda) argues that every type is 329 | either ground or not. 330 | - [grounding.agda](grounding.agda) argues the grounding property. 331 | - [holes-disjoint-checks.agda](holes-disjoint-checks.agda) contains some 332 | checks on and lemmas for using the `holes-disjoint` judgement. Like 333 | `binders-disjoint`, `holes-disjoint` is defined inductively on only its 334 | left argument, so there's similar overhead. 335 | - [htype-decidable.agda](htype-decidable.agda) argues that every pair of 336 | types are either equal or not. 337 | - [synth-unicity.agda](synth-unicity.agda) argues that the synthesis 338 | judgement produces at most one type for a term. 339 | 340 | These files contain technical lemmas for the corresponding judgement or 341 | theorem. They are generally not surprising once stated, although it's 342 | perhaps not immediate why they're needed, and they tend to obfuscate the 343 | actual proof text. They are corralled into their own modules in an effort 344 | to aid readability. 345 | 346 | - [lemmas-complete.agda](lemmas-complete.agda) 347 | - [lemmas-consistency.agda](lemmas-consistency.agda) 348 | - [lemmas-disjointness.agda](lemmas-disjointness.agda) 349 | - [lemmas-freshness.agda](lemmas-freshness.agda) 350 | - [lemmas-gcomplete.agda](lemmas-gcomplete.agda) 351 | - [lemmas-ground.agda](lemmas-ground.agda) 352 | - [lemmas-matching.agda](lemmas-matching.agda) 353 | - [lemmas-progress-checks.agda](lemmas-progress-checks.agda) 354 | - [lemmas-subst-ta.agda](lemmas-subst-ta.agda) 355 | -------------------------------------------------------------------------------- /ae-reviews.txt: -------------------------------------------------------------------------------- 1 | POPL'19 AEC Paper #36 Reviews and Comments 2 | =========================================================================== 3 | Paper #36 Live Functional Programming with Typed Holes 4 | 5 | 6 | Review #36A 7 | =========================================================================== 8 | * Updated: 29 Oct 2018 5:55:37am EDT 9 | 10 | Overall merit 11 | ------------- 12 | 3. Weak accept 13 | 14 | Reviewer expertise 15 | ------------------ 16 | 2. Some familiarity 17 | 18 | Artifact summary 19 | ---------------- 20 | The paper develops dynamic semantics for incomplete functional programs with the 21 | goal of enhancing live program editing experience in an IDE. The artefact 22 | supplied by the authors is: 23 | 24 | 1. an Agda mechanization of metatheory presented in Section 3 of the paper. 25 | 26 | 2. an OCaml implementation of system described in the paper (there's a small 27 | fragment of code written in Coq) 28 | 29 | Both artefacts are available as online GitHub repositories with the source code. 30 | Authors have also provided a Docker file to install a container with all the 31 | software required to build the Agda formalization. Prototype implementation is 32 | also freely accessible online at www.hazel.org. 33 | 34 | General assesment 35 | ----------------- 36 | # Artefact 1 - Agda mechanization 37 | 38 | The main strength of the artefact is that it provides formal proofs of theorems 39 | formulated by the authors, thus proving correctness of the proposed metatheory. 40 | Authors have provided a good table of contents that lists where exactly in the 41 | source code are the proofs of theorems from Section 3 of the paper. The source 42 | code itself is well written - clean and with enough comments. 43 | 44 | One minor complaint would be the fact that the artefact relies on an old (2.5 45 | year) version of Agda, and thus building the artefact from source is 46 | burdensome (requires installing an old version of GHC). However, with Agda's lack of guarantees on backward compatibility, 47 | it probably makes little sense to update to the latest version anyway. A docker 48 | file provided by the authors mitigates the problem. 49 | 50 | In my opinion this artefact meets the expectations set by the paper and deserves 51 | an "accept". 52 | 53 | # Artefact 2 - OCaml implementation 54 | 55 | The main strength of this artefact is that it allows interactive experimentation 56 | with the proposed system. However, I feel that there is a significant mismatch 57 | between what the paper promises and what the artefact actually delivers. 58 | Concretely, the paper suggest that the implementation provides various syntactic 59 | sugar constructs (tuples, recursive data types), but the only way to have these 60 | is using Church encodings. Importantly, this does *NOT* invalidate findings of the paper. 61 | The implemented system is expressive enough to support the claims that authors 62 | make. However, given the introduction to and mock-ups shown in Section 2, a 63 | reader will most likely expect more from the implementation. Moreover, I found 64 | the source code lacking comments. Implementation of semantics in Coq has some, 65 | but not too many. This makes reading the source code difficult. 66 | 67 | I feel that this artefact falls short of the expectations set by the paper. At 68 | this point I rate it as a "weak reject", but if authors make changes discussed 69 | in the comments (and summarized below) my rating will go up. 70 | 71 | Suggestions for improvement 72 | --------------------------- 73 | Regarding the first artefact, please provide additional instructions how to run 74 | Agda installation from a Docker container with agda-mode in Emacs. 75 | 76 | Regarding the second artefact, please update the paper to give reader an 77 | accurate expectation of what the artefact actually implements. Most 78 | importantly, please point out that reproducing examples in the paper requires 79 | Church encodings. This is not obvious from the text and figures. 80 | Perhaps prepare an extended version of the paper that contains an appendix with 81 | the actual code of the examples? 82 | 83 | 84 | 85 | Comment @A1 by Cyrus Omar 86 | --------------------------------------------------------------------------- 87 | Thank you for your feedback. 88 | 89 | 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. 90 | 91 | 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. 92 | 93 | 94 | Comment @A2 by Reviewer A 95 | --------------------------------------------------------------------------- 96 | 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. 97 | 98 | 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. 99 | 100 | 101 | Comment @A3 by Cyrus Omar 102 | --------------------------------------------------------------------------- 103 | 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: 104 | 105 | https://github.com/hazelgrove/hazel/releases/tag/popl19aec-final 106 | 107 | 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`. 108 | 109 | We will include this in the final artifact as requested. 110 | 111 | 112 | Comment @A4 by Reviewer A 113 | --------------------------------------------------------------------------- 114 | Thank you. Please give me some time to play with the implementation and update my review. 115 | 116 | 117 | Comment @A5 by Reviewer A 118 | --------------------------------------------------------------------------- 119 | 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: 120 | 121 | 1. construct tuples? 122 | 2. construct lists? 123 | 3. use a map? 124 | 125 | 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. 126 | 127 | 128 | Comment @A6 by Cyrus Omar 129 | --------------------------------------------------------------------------- 130 | 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. 131 | 132 | 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. 133 | 134 | 135 | Comment @A7 by Reviewer A 136 | --------------------------------------------------------------------------- 137 | > The easiest way to implement the examples from Sec. 2 are by using Church encodings. 138 | 139 | Allow me to quote from introduction to Section 2: 140 | "some 'syntactic and semantic sugar' (...) was not available in Hazel as of this writing, e.g. 141 | [A] pattern matching in function arguments, 142 | [B] list notation 143 | [C] and record labels (currently there are only tuples). [A, B, and C added by me]" 144 | 145 | 1. [C] suggests that I can use tuples (not Church encodings of tuples) 146 | 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))`. 147 | 3. [A] suggests that I can take apart these data types - lists, tuples - with pattern matching, except that I can't say: 148 | ``` 149 | map f nil = _ 150 | map f (cons x xs) = _ 151 | ``` 152 | and have to do this instead: 153 | ``` 154 | map f xs = case xs of { nil -> _; cons x xs' -> _ } 155 | ``` 156 | 157 | So the paper gives an impression that the system is more powerful that it actually seems to be. Is that correct? 158 | 159 | 160 | Comment @A8 by Cyrus Omar 161 | --------------------------------------------------------------------------- 162 | 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. 163 | 164 | 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. 165 | 166 | 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. 167 | 168 | 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. 169 | 170 | 171 | 172 | Review #36B 173 | =========================================================================== 174 | * Updated: 28 Oct 2018 1:32:54pm EDT 175 | 176 | Overall merit 177 | ------------- 178 | 5. Strong accept 179 | 180 | Reviewer expertise 181 | ------------------ 182 | 4. Expert 183 | 184 | Artifact summary 185 | ---------------- 186 | 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. 187 | 188 | 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. 189 | 190 | General assesment 191 | ----------------- 192 | 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! 193 | 194 | 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. 195 | 196 | 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. 197 | 198 | There are two minor questions I had that I'd like to see addressed either in the code or the paper: 199 | - Why is there a separate constructor for the identity substitution instead of it being defined as in the paper? 200 | - 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. 201 | 202 | --------------------------------------------------- 203 | 204 | Below are some questions that I had while reading the paper but are not related directly to the artefact: 205 | 206 | 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. 207 | 208 | 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? 209 | 210 | 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. 211 | 212 | Suggestions for improvement 213 | --------------------------- 214 | - 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. 215 | 216 | - A minor inconsistency between the paper and the Agda code: the rule FBoxedVal in the paper is called FBoxed in the Agda code. 217 | -------------------------------------------------------------------------------- /all.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | 4 | open import contexts 5 | open import core 6 | 7 | open import lemmas-gcomplete 8 | 9 | open import disjointness 10 | open import dom-eq 11 | open import holes-disjoint-checks 12 | open import lemmas-disjointness 13 | open import lemmas-freshness 14 | 15 | open import finality 16 | open import focus-formation 17 | open import ground-decidable 18 | open import grounding 19 | 20 | open import lemmas-subst-ta 21 | open import htype-decidable 22 | open import lemmas-consistency 23 | open import lemmas-ground 24 | open import lemmas-matching 25 | open import synth-unicity 26 | 27 | open import elaborability 28 | open import elaboration-generality 29 | open import elaboration-unicity 30 | open import type-assignment-unicity 31 | open import typed-elaboration 32 | 33 | open import canonical-boxed-forms 34 | open import canonical-indeterminate-forms 35 | open import canonical-value-forms 36 | 37 | open import lemmas-progress-checks 38 | open import preservation 39 | open import progress 40 | open import progress-checks 41 | 42 | open import cast-inert 43 | open import complete-elaboration 44 | open import complete-preservation 45 | open import complete-progress 46 | open import lemmas-complete 47 | 48 | open import contraction 49 | open import exchange 50 | open import weakening 51 | 52 | open import binders-disjoint-checks 53 | open import continuity 54 | -------------------------------------------------------------------------------- /binders-disjoint-checks.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | 5 | 6 | module binders-disjoint-checks where 7 | -- these are fairly mechanical lemmas that show that the 8 | -- judgementally-defined binders-disjoint is really a type-directed 9 | -- function 10 | mutual 11 | lem-bdσ-lam : ∀{σ x τ d} → binders-disjoint-σ σ (·λ_[_]_ x τ d) → binders-disjoint-σ σ d 12 | lem-bdσ-lam BDσId = BDσId 13 | lem-bdσ-lam (BDσSubst x₁ bd) = BDσSubst (lem-bd-lam x₁) (lem-bdσ-lam bd) 14 | 15 | lem-bd-lam : ∀{ d1 x τ1 d} → binders-disjoint d1 (·λ_[_]_ x τ1 d) → binders-disjoint d1 d 16 | lem-bd-lam BDConst = BDConst 17 | lem-bd-lam BDVar = BDVar 18 | lem-bd-lam (BDLam bd (UBLam2 x₂ x₃)) = BDLam (lem-bd-lam bd) x₃ 19 | lem-bd-lam (BDHole x₁) = BDHole (lem-bdσ-lam x₁) 20 | lem-bd-lam (BDNEHole x₁ bd) = BDNEHole (lem-bdσ-lam x₁) (lem-bd-lam bd) 21 | lem-bd-lam (BDAp bd bd₁) = BDAp (lem-bd-lam bd) (lem-bd-lam bd₁) 22 | lem-bd-lam (BDCast bd) = BDCast (lem-bd-lam bd) 23 | lem-bd-lam (BDFailedCast bd) = BDFailedCast (lem-bd-lam bd) 24 | 25 | mutual 26 | lem-bdσ-hole : ∀{d u σ σ'} → binders-disjoint-σ σ ⦇⌜ d ⌟⦈⟨ u , σ' ⟩ → binders-disjoint-σ σ d 27 | lem-bdσ-hole BDσId = BDσId 28 | lem-bdσ-hole (BDσSubst x bd) = BDσSubst (lem-bd-hole x) (lem-bdσ-hole bd) 29 | 30 | lem-bd-hole : ∀{d1 d u σ} → binders-disjoint d1 ⦇⌜ d ⌟⦈⟨ u , σ ⟩ → binders-disjoint d1 d 31 | lem-bd-hole BDConst = BDConst 32 | lem-bd-hole BDVar = BDVar 33 | lem-bd-hole (BDLam bd (UBNEHole x₁ x₂)) = BDLam (lem-bd-hole bd) x₂ 34 | lem-bd-hole (BDHole x) = BDHole (lem-bdσ-hole x) 35 | lem-bd-hole (BDNEHole x bd) = BDNEHole (lem-bdσ-hole x) (lem-bd-hole bd) 36 | lem-bd-hole (BDAp bd bd₁) = BDAp (lem-bd-hole bd) (lem-bd-hole bd₁) 37 | lem-bd-hole (BDCast bd) = BDCast (lem-bd-hole bd) 38 | lem-bd-hole (BDFailedCast bd) = BDFailedCast (lem-bd-hole bd) 39 | 40 | mutual 41 | lem-bdσ-cast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ (d ⟨ τ1 ⇒ τ2 ⟩) → binders-disjoint-σ σ d 42 | lem-bdσ-cast BDσId = BDσId 43 | lem-bdσ-cast (BDσSubst x bd) = BDσSubst (lem-bd-cast x) (lem-bdσ-cast bd) 44 | 45 | lem-bd-cast : ∀{d1 d τ1 τ2} → binders-disjoint d1 (d ⟨ τ1 ⇒ τ2 ⟩) → binders-disjoint d1 d 46 | lem-bd-cast BDConst = BDConst 47 | lem-bd-cast BDVar = BDVar 48 | lem-bd-cast (BDLam bd (UBCast x₁)) = BDLam (lem-bd-cast bd) x₁ 49 | lem-bd-cast (BDHole x) = BDHole (lem-bdσ-cast x) 50 | lem-bd-cast (BDNEHole x bd) = BDNEHole (lem-bdσ-cast x) (lem-bd-cast bd) 51 | lem-bd-cast (BDAp bd bd₁) = BDAp (lem-bd-cast bd) (lem-bd-cast bd₁) 52 | lem-bd-cast (BDCast bd) = BDCast (lem-bd-cast bd) 53 | lem-bd-cast (BDFailedCast bd) = BDFailedCast (lem-bd-cast bd) 54 | 55 | mutual 56 | lem-bdσ-failedcast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) → binders-disjoint-σ σ d 57 | lem-bdσ-failedcast BDσId = BDσId 58 | lem-bdσ-failedcast (BDσSubst x bd) = BDσSubst (lem-bd-failedcast x) (lem-bdσ-failedcast bd) 59 | 60 | lem-bd-failedcast : ∀{d1 d τ1 τ2} → binders-disjoint d1 (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) → binders-disjoint d1 d 61 | lem-bd-failedcast BDConst = BDConst 62 | lem-bd-failedcast BDVar = BDVar 63 | lem-bd-failedcast (BDLam bd (UBFailedCast x₁)) = BDLam (lem-bd-failedcast bd) x₁ 64 | lem-bd-failedcast (BDHole x) = BDHole (lem-bdσ-failedcast x) 65 | lem-bd-failedcast (BDNEHole x bd) = BDNEHole (lem-bdσ-failedcast x) (lem-bd-failedcast bd) 66 | lem-bd-failedcast (BDAp bd bd₁) = BDAp (lem-bd-failedcast bd) (lem-bd-failedcast bd₁) 67 | lem-bd-failedcast (BDCast bd) = BDCast (lem-bd-failedcast bd) 68 | lem-bd-failedcast (BDFailedCast bd) = BDFailedCast (lem-bd-failedcast bd) 69 | 70 | mutual 71 | lem-bdσ-into-cast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ d → binders-disjoint-σ σ (d ⟨ τ1 ⇒ τ2 ⟩) 72 | lem-bdσ-into-cast BDσId = BDσId 73 | lem-bdσ-into-cast (BDσSubst x bd) = BDσSubst (lem-bd-into-cast x) (lem-bdσ-into-cast bd) 74 | 75 | lem-bd-into-cast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint d1 (d2 ⟨ τ1 ⇒ τ2 ⟩) 76 | lem-bd-into-cast BDConst = BDConst 77 | lem-bd-into-cast BDVar = BDVar 78 | lem-bd-into-cast (BDLam bd x₁) = BDLam (lem-bd-into-cast bd) (UBCast x₁) 79 | lem-bd-into-cast (BDHole x) = BDHole (lem-bdσ-into-cast x) 80 | lem-bd-into-cast (BDNEHole x bd) = BDNEHole (lem-bdσ-into-cast x) (lem-bd-into-cast bd) 81 | lem-bd-into-cast (BDAp bd bd₁) = BDAp (lem-bd-into-cast bd) (lem-bd-into-cast bd₁) 82 | lem-bd-into-cast (BDCast bd) = BDCast (lem-bd-into-cast bd) 83 | lem-bd-into-cast (BDFailedCast bd) = BDFailedCast (lem-bd-into-cast bd) 84 | -------------------------------------------------------------------------------- /canonical-boxed-forms.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import contexts 4 | open import core 5 | 6 | open import canonical-value-forms 7 | 8 | module canonical-boxed-forms where 9 | canonical-boxed-forms-b : ∀{Δ d} → 10 | Δ , ∅ ⊢ d :: b → 11 | d boxedval → 12 | d == c 13 | canonical-boxed-forms-b (TAVar _) (BVVal ()) 14 | canonical-boxed-forms-b wt (BVVal v) = canonical-value-forms-b wt v 15 | 16 | -- this type gives somewhat nicer syntax for the output of the canonical 17 | -- forms lemma for boxed values at arrow type 18 | data cbf-arr : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where 19 | CBFLam : ∀{Δ d τ1 τ2} → 20 | (Σ[ x ∈ Nat ] Σ[ d' ∈ ihexp ] 21 | (d == (·λ x [ τ1 ] d') × Δ , ■ (x , τ1) ⊢ d' :: τ2)) 22 | → cbf-arr Δ d τ1 τ2 23 | CBFCastArr : ∀{Δ d τ1 τ2} → 24 | (Σ[ d' ∈ ihexp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ] 25 | (d == (d' ⟨ τ1' ==> τ2' ⇒ τ1 ==> τ2 ⟩) × 26 | (τ1' ==> τ2' ≠ τ1 ==> τ2) × 27 | (Δ , ∅ ⊢ d' :: τ1' ==> τ2'))) 28 | → cbf-arr Δ d τ1 τ2 29 | 30 | canonical-boxed-forms-arr : ∀{Δ d τ1 τ2 } → 31 | Δ , ∅ ⊢ d :: (τ1 ==> τ2) → 32 | d boxedval → 33 | cbf-arr Δ d τ1 τ2 34 | canonical-boxed-forms-arr (TAVar x₁) (BVVal ()) 35 | canonical-boxed-forms-arr (TALam f wt) (BVVal v) = CBFLam (canonical-value-forms-arr (TALam f wt) v) 36 | canonical-boxed-forms-arr (TAAp wt wt₁) (BVVal ()) 37 | canonical-boxed-forms-arr (TAEHole x x₁) (BVVal ()) 38 | canonical-boxed-forms-arr (TANEHole x wt x₁) (BVVal ()) 39 | canonical-boxed-forms-arr (TACast wt x) (BVVal ()) 40 | canonical-boxed-forms-arr (TACast wt x) (BVArrCast x₁ bv) = CBFCastArr (_ , _ , _ , refl , x₁ , wt) 41 | canonical-boxed-forms-arr (TAFailedCast x x₁ x₂ x₃) (BVVal ()) 42 | 43 | canonical-boxed-forms-hole : ∀{Δ d} → 44 | Δ , ∅ ⊢ d :: ⦇-⦈ → 45 | d boxedval → 46 | Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] 47 | ((d == d' ⟨ τ' ⇒ ⦇-⦈ ⟩) × 48 | (τ' ground) × 49 | (Δ , ∅ ⊢ d' :: τ')) 50 | canonical-boxed-forms-hole (TAVar x₁) (BVVal ()) 51 | canonical-boxed-forms-hole (TAAp wt wt₁) (BVVal ()) 52 | canonical-boxed-forms-hole (TAEHole x x₁) (BVVal ()) 53 | canonical-boxed-forms-hole (TANEHole x wt x₁) (BVVal ()) 54 | canonical-boxed-forms-hole (TACast wt x) (BVVal ()) 55 | canonical-boxed-forms-hole (TACast wt x) (BVHoleCast x₁ bv) = _ , _ , refl , x₁ , wt 56 | canonical-boxed-forms-hole (TAFailedCast x x₁ x₂ x₃) (BVVal ()) 57 | 58 | canonical-boxed-forms-coverage : ∀{Δ d τ} → 59 | Δ , ∅ ⊢ d :: τ → 60 | d boxedval → 61 | τ ≠ b → 62 | ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) → 63 | τ ≠ ⦇-⦈ → 64 | ⊥ 65 | canonical-boxed-forms-coverage TAConst (BVVal x) nb na nh = nb refl 66 | canonical-boxed-forms-coverage (TAVar x₁) (BVVal ()) nb na nh 67 | canonical-boxed-forms-coverage (TALam _ wt) (BVVal x₁) nb na nh = na _ _ refl 68 | canonical-boxed-forms-coverage (TAAp wt wt₁) (BVVal ()) nb na nh 69 | canonical-boxed-forms-coverage (TAEHole x x₁) (BVVal ()) nb na nh 70 | canonical-boxed-forms-coverage (TANEHole x wt x₁) (BVVal ()) nb na nh 71 | canonical-boxed-forms-coverage (TACast wt x) (BVVal ()) nb na nh 72 | canonical-boxed-forms-coverage (TACast wt x) (BVArrCast x₁ bv) nb na nh = na _ _ refl 73 | canonical-boxed-forms-coverage (TACast wt x) (BVHoleCast x₁ bv) nb na nh = nh refl 74 | canonical-boxed-forms-coverage (TAFailedCast x x₁ x₂ x₃) (BVVal ()) 75 | -------------------------------------------------------------------------------- /canonical-indeterminate-forms.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import contexts 4 | open import core 5 | open import type-assignment-unicity 6 | 7 | module canonical-indeterminate-forms where 8 | 9 | -- this type gives somewhat nicer syntax for the output of the canonical 10 | -- forms lemma for indeterminates at base type 11 | data cif-base : (Δ : hctx) (d : ihexp) → Set where 12 | CIFBEHole : ∀ {Δ d} → 13 | Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] 14 | ((d == ⦇-⦈⟨ u , σ ⟩) × 15 | ((u :: b [ Γ ]) ∈ Δ) × 16 | (Δ , ∅ ⊢ σ :s: Γ) 17 | ) 18 | → cif-base Δ d 19 | CIFBNEHole : ∀ {Δ d} → 20 | Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] 21 | ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) × 22 | (Δ , ∅ ⊢ d' :: τ') × 23 | (d' final) × 24 | ((u :: b [ Γ ]) ∈ Δ) × 25 | (Δ , ∅ ⊢ σ :s: Γ) 26 | ) 27 | → cif-base Δ d 28 | CIFBAp : ∀ {Δ d} → 29 | Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ] 30 | ((d == d1 ∘ d2) × 31 | (Δ , ∅ ⊢ d1 :: τ2 ==> b) × 32 | (Δ , ∅ ⊢ d2 :: τ2) × 33 | (d1 indet) × 34 | (d2 final) × 35 | ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩)) 36 | ) 37 | → cif-base Δ d 38 | CIFBCast : ∀ {Δ d} → 39 | Σ[ d' ∈ ihexp ] 40 | ((d == d' ⟨ ⦇-⦈ ⇒ b ⟩) × 41 | (Δ , ∅ ⊢ d' :: ⦇-⦈) × 42 | (d' indet) × 43 | ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩)) 44 | ) 45 | → cif-base Δ d 46 | CIFBFailedCast : ∀ {Δ d} → 47 | Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] 48 | ((d == d' ⟨ τ' ⇒⦇-⦈⇏ b ⟩) × 49 | (Δ , ∅ ⊢ d' :: τ') × 50 | (τ' ground) × 51 | (τ' ≠ b) 52 | ) 53 | → cif-base Δ d 54 | 55 | canonical-indeterminate-forms-base : ∀{Δ d} → 56 | Δ , ∅ ⊢ d :: b → 57 | d indet → 58 | cif-base Δ d 59 | canonical-indeterminate-forms-base TAConst () 60 | canonical-indeterminate-forms-base (TAVar x₁) () 61 | canonical-indeterminate-forms-base (TAAp wt wt₁) (IAp x ind x₁) = CIFBAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x) 62 | canonical-indeterminate-forms-base (TAEHole x x₁) IEHole = CIFBEHole (_ , _ , _ , refl , x , x₁) 63 | canonical-indeterminate-forms-base (TANEHole x wt x₁) (INEHole x₂) = CIFBNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁) 64 | canonical-indeterminate-forms-base (TACast wt x) (ICastHoleGround x₁ ind x₂) = CIFBCast (_ , refl , wt , ind , x₁) 65 | canonical-indeterminate-forms-base (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = CIFBFailedCast (_ , _ , refl , x , x₅ , x₇) 66 | 67 | -- this type gives somewhat nicer syntax for the output of the canonical 68 | -- forms lemma for indeterminates at arrow type 69 | data cif-arr : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where 70 | CIFAEHole : ∀{d Δ τ1 τ2} → 71 | Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] 72 | ((d == ⦇-⦈⟨ u , σ ⟩) × 73 | ((u :: (τ1 ==> τ2) [ Γ ]) ∈ Δ) × 74 | (Δ , ∅ ⊢ σ :s: Γ) 75 | ) 76 | → cif-arr Δ d τ1 τ2 77 | CIFANEHole : ∀{d Δ τ1 τ2} → 78 | Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ] 79 | ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) × 80 | (Δ , ∅ ⊢ d' :: τ') × 81 | (d' final) × 82 | ((u :: (τ1 ==> τ2) [ Γ ]) ∈ Δ) × 83 | (Δ , ∅ ⊢ σ :s: Γ) 84 | ) 85 | → cif-arr Δ d τ1 τ2 86 | CIFAAp : ∀{d Δ τ1 τ2} → 87 | Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2' ∈ htyp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] 88 | ((d == d1 ∘ d2) × 89 | (Δ , ∅ ⊢ d1 :: τ2' ==> (τ1 ==> τ2)) × 90 | (Δ , ∅ ⊢ d2 :: τ2') × 91 | (d1 indet) × 92 | (d2 final) × 93 | ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩)) 94 | ) 95 | → cif-arr Δ d τ1 τ2 96 | CIFACast : ∀{d Δ τ1 τ2} → 97 | Σ[ d' ∈ ihexp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ] 98 | ((d == d' ⟨ (τ1' ==> τ2') ⇒ (τ1 ==> τ2) ⟩) × 99 | (Δ , ∅ ⊢ d' :: τ1' ==> τ2') × 100 | (d' indet) × 101 | ((τ1' ==> τ2') ≠ (τ1 ==> τ2)) 102 | ) 103 | → cif-arr Δ d τ1 τ2 104 | CIFACastHole : ∀{d Δ τ1 τ2} → 105 | Σ[ d' ∈ ihexp ] 106 | ((d == (d' ⟨ ⦇-⦈ ⇒ ⦇-⦈ ==> ⦇-⦈ ⟩)) × 107 | (τ1 == ⦇-⦈) × 108 | (τ2 == ⦇-⦈) × 109 | (Δ , ∅ ⊢ d' :: ⦇-⦈) × 110 | (d' indet) × 111 | ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩)) 112 | ) 113 | → cif-arr Δ d τ1 τ2 114 | CIFAFailedCast : ∀{d Δ τ1 τ2} → 115 | Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] 116 | ((d == (d' ⟨ τ' ⇒⦇-⦈⇏ ⦇-⦈ ==> ⦇-⦈ ⟩) ) × 117 | (τ1 == ⦇-⦈) × 118 | (τ2 == ⦇-⦈) × 119 | (Δ , ∅ ⊢ d' :: τ') × 120 | (τ' ground) × 121 | (τ' ≠ (⦇-⦈ ==> ⦇-⦈)) 122 | ) 123 | → cif-arr Δ d τ1 τ2 124 | 125 | canonical-indeterminate-forms-arr : ∀{Δ d τ1 τ2 } → 126 | Δ , ∅ ⊢ d :: (τ1 ==> τ2) → 127 | d indet → 128 | cif-arr Δ d τ1 τ2 129 | canonical-indeterminate-forms-arr (TAVar x₁) () 130 | canonical-indeterminate-forms-arr (TALam _ wt) () 131 | canonical-indeterminate-forms-arr (TAAp wt wt₁) (IAp x ind x₁) = CIFAAp (_ , _ , _ , _ , _ , refl , wt , wt₁ , ind , x₁ , x) 132 | canonical-indeterminate-forms-arr (TAEHole x x₁) IEHole = CIFAEHole (_ , _ , _ , refl , x , x₁) 133 | canonical-indeterminate-forms-arr (TANEHole x wt x₁) (INEHole x₂) = CIFANEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁) 134 | canonical-indeterminate-forms-arr (TACast wt x) (ICastArr x₁ ind) = CIFACast (_ , _ , _ , _ , _ , refl , wt , ind , x₁) 135 | canonical-indeterminate-forms-arr (TACast wt TCHole2) (ICastHoleGround x₁ ind GHole) = CIFACastHole (_ , refl , refl , refl , wt , ind , x₁) 136 | canonical-indeterminate-forms-arr (TAFailedCast x x₁ GHole x₃) (IFailedCast x₄ x₅ GHole x₇) = CIFAFailedCast (_ , _ , refl , refl , refl , x , x₅ , x₇) 137 | 138 | 139 | -- this type gives somewhat nicer syntax for the output of the canonical 140 | -- forms lemma for indeterminates at hole type 141 | data cif-hole : (Δ : hctx) (d : ihexp) → Set where 142 | CIFHEHole : ∀ {Δ d} → 143 | Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] 144 | ((d == ⦇-⦈⟨ u , σ ⟩) × 145 | ((u :: ⦇-⦈ [ Γ ]) ∈ Δ) × 146 | (Δ , ∅ ⊢ σ :s: Γ) 147 | ) 148 | → cif-hole Δ d 149 | CIFHNEHole : ∀ {Δ d} → 150 | Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ] 151 | ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) × 152 | (Δ , ∅ ⊢ d' :: τ') × 153 | (d' final) × 154 | ((u :: ⦇-⦈ [ Γ ]) ∈ Δ) × 155 | (Δ , ∅ ⊢ σ :s: Γ) 156 | ) 157 | → cif-hole Δ d 158 | CIFHAp : ∀ {Δ d} → 159 | Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ] 160 | ((d == d1 ∘ d2) × 161 | (Δ , ∅ ⊢ d1 :: (τ2 ==> ⦇-⦈)) × 162 | (Δ , ∅ ⊢ d2 :: τ2) × 163 | (d1 indet) × 164 | (d2 final) × 165 | ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩)) 166 | ) 167 | → cif-hole Δ d 168 | CIFHCast : ∀ {Δ d} → 169 | Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] 170 | ((d == d' ⟨ τ' ⇒ ⦇-⦈ ⟩) × 171 | (Δ , ∅ ⊢ d' :: τ') × 172 | (τ' ground) × 173 | (d' indet) 174 | ) 175 | → cif-hole Δ d 176 | 177 | canonical-indeterminate-forms-hole : ∀{Δ d} → 178 | Δ , ∅ ⊢ d :: ⦇-⦈ → 179 | d indet → 180 | cif-hole Δ d 181 | canonical-indeterminate-forms-hole (TAVar x₁) () 182 | canonical-indeterminate-forms-hole (TAAp wt wt₁) (IAp x ind x₁) = CIFHAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x) 183 | canonical-indeterminate-forms-hole (TAEHole x x₁) IEHole = CIFHEHole (_ , _ , _ , refl , x , x₁) 184 | canonical-indeterminate-forms-hole (TANEHole x wt x₁) (INEHole x₂) = CIFHNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁) 185 | canonical-indeterminate-forms-hole (TACast wt x) (ICastGroundHole x₁ ind) = CIFHCast (_ , _ , refl , wt , x₁ , ind) 186 | canonical-indeterminate-forms-hole (TACast wt x) (ICastHoleGround x₁ ind ()) 187 | canonical-indeterminate-forms-hole (TAFailedCast x x₁ () x₃) (IFailedCast x₄ x₅ x₆ x₇) 188 | 189 | canonical-indeterminate-forms-coverage : ∀{Δ d τ} → 190 | Δ , ∅ ⊢ d :: τ → 191 | d indet → 192 | τ ≠ b → 193 | ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) → 194 | τ ≠ ⦇-⦈ → 195 | ⊥ 196 | canonical-indeterminate-forms-coverage TAConst () nb na nh 197 | canonical-indeterminate-forms-coverage (TAVar x₁) () nb na nh 198 | canonical-indeterminate-forms-coverage (TALam _ wt) () nb na nh 199 | canonical-indeterminate-forms-coverage {τ = b} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = nb refl 200 | canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = nh refl 201 | canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = na τ τ₁ refl 202 | canonical-indeterminate-forms-coverage {τ = b} (TAEHole x x₁) IEHole nb na nh = nb refl 203 | canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAEHole x x₁) IEHole nb na nh = nh refl 204 | canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAEHole x x₁) IEHole nb na nh = na τ τ₁ refl 205 | canonical-indeterminate-forms-coverage {τ = b} (TANEHole x wt x₁) (INEHole x₂) nb na nh = nb refl 206 | canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TANEHole x wt x₁) (INEHole x₂) nb na nh = nh refl 207 | canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TANEHole x wt x₁) (INEHole x₂) nb na nh = na τ τ₁ refl 208 | canonical-indeterminate-forms-coverage (TACast wt x) (ICastArr x₁ ind) nb na nh = na _ _ refl 209 | canonical-indeterminate-forms-coverage (TACast wt x) (ICastGroundHole x₁ ind) nb na nh = nh refl 210 | canonical-indeterminate-forms-coverage {τ = b} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = nb refl 211 | canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = nh refl 212 | canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = na τ τ₁ refl 213 | canonical-indeterminate-forms-coverage {τ = b} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ z _ _₁ → z refl 214 | canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ _ _₁ z → z refl 215 | canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ _ z _₁ → z τ τ₁ refl 216 | -------------------------------------------------------------------------------- /canonical-value-forms.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import contexts 4 | open import core 5 | 6 | module canonical-value-forms where 7 | canonical-value-forms-b : ∀{Δ d} → 8 | Δ , ∅ ⊢ d :: b → 9 | d val → 10 | d == c 11 | canonical-value-forms-b TAConst VConst = refl 12 | canonical-value-forms-b (TAVar x₁) () 13 | canonical-value-forms-b (TAAp wt wt₁) () 14 | canonical-value-forms-b (TAEHole x x₁) () 15 | canonical-value-forms-b (TANEHole x wt x₁) () 16 | canonical-value-forms-b (TACast wt x) () 17 | canonical-value-forms-b (TAFailedCast wt x x₁ x₂) () 18 | 19 | canonical-value-forms-arr : ∀{Δ d τ1 τ2} → 20 | Δ , ∅ ⊢ d :: (τ1 ==> τ2) → 21 | d val → 22 | Σ[ x ∈ Nat ] Σ[ d' ∈ ihexp ] 23 | ((d == (·λ x [ τ1 ] d')) × 24 | (Δ , ■ (x , τ1) ⊢ d' :: τ2)) 25 | canonical-value-forms-arr (TAVar x₁) () 26 | canonical-value-forms-arr (TALam _ wt) VLam = _ , _ , refl , wt 27 | canonical-value-forms-arr (TAAp wt wt₁) () 28 | canonical-value-forms-arr (TAEHole x x₁) () 29 | canonical-value-forms-arr (TANEHole x wt x₁) () 30 | canonical-value-forms-arr (TACast wt x) () 31 | canonical-value-forms-arr (TAFailedCast x x₁ x₂ x₃) () 32 | 33 | -- this argues (somewhat informally, because you still have to inspect 34 | -- the types of the theorems above and manually verify this property) 35 | -- that we didn't miss any cases above; this intentionally will make this 36 | -- file fail to typecheck if we added more types, hopefully forcing us to 37 | -- remember to add canonical forms lemmas as appropriate 38 | canonical-value-forms-coverage1 : ∀{Δ d τ} → 39 | Δ , ∅ ⊢ d :: τ → 40 | d val → 41 | τ ≠ b → 42 | ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) → 43 | ⊥ 44 | canonical-value-forms-coverage1 TAConst VConst = λ z _ → z refl 45 | canonical-value-forms-coverage1 (TAVar x₁) () 46 | canonical-value-forms-coverage1 (TALam _ wt) VLam = λ _ z → z _ _ refl 47 | canonical-value-forms-coverage1 (TAAp wt wt₁) () 48 | canonical-value-forms-coverage1 (TAEHole x x₁) () 49 | canonical-value-forms-coverage1 (TANEHole x wt x₁) () 50 | canonical-value-forms-coverage1 (TACast wt x) () 51 | canonical-value-forms-coverage1 (TAFailedCast wt x x₁ x₂) () 52 | 53 | canonical-value-forms-coverage2 : ∀{Δ d} → 54 | Δ , ∅ ⊢ d :: ⦇-⦈ → 55 | d val → 56 | ⊥ 57 | canonical-value-forms-coverage2 (TAVar x₁) () 58 | canonical-value-forms-coverage2 (TAAp wt wt₁) () 59 | canonical-value-forms-coverage2 (TAEHole x x₁) () 60 | canonical-value-forms-coverage2 (TANEHole x wt x₁) () 61 | canonical-value-forms-coverage2 (TACast wt x) () 62 | canonical-value-forms-coverage2 (TAFailedCast wt x x₁ x₂) () 63 | -------------------------------------------------------------------------------- /cast-inert.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import typed-elaboration 6 | open import lemmas-gcomplete 7 | open import lemmas-complete 8 | open import progress-checks 9 | open import finality 10 | 11 | module cast-inert where 12 | -- if a term is compelete and well typed, then the casts inside are all 13 | -- identity casts and there are no failed casts 14 | cast-inert : ∀{Δ Γ d τ} → 15 | d dcomplete → 16 | Δ , Γ ⊢ d :: τ → 17 | cast-id d 18 | cast-inert dc TAConst = CIConst 19 | cast-inert dc (TAVar x₁) = CIVar 20 | cast-inert (DCLam dc x₁) (TALam x₂ wt) = CILam (cast-inert dc wt) 21 | cast-inert (DCAp dc dc₁) (TAAp wt wt₁) = CIAp (cast-inert dc wt) (cast-inert dc₁ wt₁) 22 | cast-inert () (TAEHole x x₁) 23 | cast-inert () (TANEHole x wt x₁) 24 | cast-inert (DCCast dc x x₁) (TACast wt x₂) 25 | with complete-consistency x₂ x x₁ 26 | ... | refl = CICast (cast-inert dc wt) 27 | cast-inert () (TAFailedCast wt x x₁ x₂) 28 | 29 | -- in a well typed complete internal expression, every cast is the 30 | -- identity cast. 31 | complete-casts : ∀{Γ Δ d τ1 τ2} → 32 | Γ , Δ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 → 33 | d ⟨ τ1 ⇒ τ2 ⟩ dcomplete → 34 | τ1 == τ2 35 | complete-casts wt comp with cast-inert comp wt 36 | complete-casts wt comp | CICast qq = refl 37 | 38 | -- relates expressions to the same thing with all identity casts 39 | -- removed. note that this is a syntactic rewrite and it goes under 40 | -- binders. 41 | data no-id-casts : ihexp → ihexp → Set where 42 | NICConst : no-id-casts c c 43 | NICVar : ∀{x} → no-id-casts (X x) (X x) 44 | NICLam : ∀{x τ d d'} → no-id-casts d d' → no-id-casts (·λ x [ τ ] d) (·λ x [ τ ] d') 45 | NICHole : ∀{u} → no-id-casts (⦇-⦈⟨ u ⟩) (⦇-⦈⟨ u ⟩) 46 | NICNEHole : ∀{d d' u} → no-id-casts d d' → no-id-casts (⦇⌜ d ⌟⦈⟨ u ⟩) (⦇⌜ d' ⌟⦈⟨ u ⟩) 47 | NICAp : ∀{d1 d2 d1' d2'} → no-id-casts d1 d1' → no-id-casts d2 d2' → no-id-casts (d1 ∘ d2) (d1' ∘ d2') 48 | NICCast : ∀{d d' τ} → no-id-casts d d' → no-id-casts (d ⟨ τ ⇒ τ ⟩) d' 49 | NICFailed : ∀{d d' τ1 τ2} → no-id-casts d d' → no-id-casts (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) (d' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) 50 | 51 | -- removing identity casts doesn't change the type 52 | no-id-casts-type : ∀{Γ Δ d τ d' } → Δ , Γ ⊢ d :: τ → 53 | no-id-casts d d' → 54 | Δ , Γ ⊢ d' :: τ 55 | no-id-casts-type TAConst NICConst = TAConst 56 | no-id-casts-type (TAVar x₁) NICVar = TAVar x₁ 57 | no-id-casts-type (TALam x₁ wt) (NICLam nic) = TALam x₁ (no-id-casts-type wt nic) 58 | no-id-casts-type (TAAp wt wt₁) (NICAp nic nic₁) = TAAp (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁) 59 | no-id-casts-type (TAEHole x x₁) NICHole = TAEHole x x₁ 60 | no-id-casts-type (TANEHole x wt x₁) (NICNEHole nic) = TANEHole x (no-id-casts-type wt nic) x₁ 61 | no-id-casts-type (TACast wt x) (NICCast nic) = no-id-casts-type wt nic 62 | no-id-casts-type (TAFailedCast wt x x₁ x₂) (NICFailed nic) = TAFailedCast (no-id-casts-type wt nic) x x₁ x₂ 63 | -------------------------------------------------------------------------------- /check.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ## display the difference between the sorted listing of all agda files in 4 | ## the directory and the names of modules imported (commented out or not) 5 | ## in all.agda 6 | 7 | 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) 8 | -------------------------------------------------------------------------------- /complete-elaboration.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import typed-elaboration 6 | open import lemmas-gcomplete 7 | open import lemmas-complete 8 | 9 | module complete-elaboration where 10 | mutual 11 | complete-elaboration-synth : ∀{e τ Γ Δ d} → 12 | Γ gcomplete → 13 | e ecomplete → 14 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 15 | (d dcomplete × τ tcomplete × Δ == ∅) 16 | complete-elaboration-synth gc ec ESConst = DCConst , TCBase , refl 17 | complete-elaboration-synth gc ec (ESVar x₁) = DCVar , gc _ _ x₁ , refl 18 | complete-elaboration-synth gc (ECLam2 ec x₁) (ESLam x₂ exp) 19 | with complete-elaboration-synth (gcomp-extend gc x₁ x₂) ec exp 20 | ... | ih1 , ih2 , ih3 = DCLam ih1 x₁ , TCArr x₁ ih2 , ih3 21 | complete-elaboration-synth gc (ECAp ec ec₁) (ESAp _ _ x MAHole x₂ x₃) 22 | with comp-synth gc ec x 23 | ... | () 24 | complete-elaboration-synth gc (ECAp ec ec₁) (ESAp {Δ1 = Δ1} {Δ2 = Δ2} _ _ x MAArr x₂ x₃) 25 | with comp-synth gc ec x 26 | ... | TCArr t1 t2 27 | with complete-elaboration-ana gc ec (TCArr t1 t2) x₂ | complete-elaboration-ana gc ec₁ t1 x₃ 28 | ... | ih1 , _ , ih4 | ih2 , _ , ih3 = DCAp (DCCast ih1 (comp-ana gc x₂ ih1) (TCArr t1 t2)) (DCCast ih2 (comp-ana gc x₃ ih2) t1) , 29 | t2 , 30 | tr (λ qq → (qq ∪ Δ2) == ∅) (! ih4) (tr (λ qq → (∅ ∪ qq) == ∅) (! ih3) refl) 31 | complete-elaboration-synth gc () ESEHole 32 | complete-elaboration-synth gc () (ESNEHole _ exp) 33 | complete-elaboration-synth gc (ECAsc x ec) (ESAsc x₁) 34 | with complete-elaboration-ana gc ec x x₁ 35 | ... | ih1 , _ , ih2 = DCCast ih1 (comp-ana gc x₁ ih1) x , x , ih2 36 | 37 | complete-elaboration-ana : ∀{e τ τ' Γ Δ d} → 38 | Γ gcomplete → 39 | e ecomplete → 40 | τ tcomplete → 41 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 42 | (d dcomplete × τ' tcomplete × Δ == ∅) 43 | complete-elaboration-ana gc (ECLam1 ec) () (EALam x₁ MAHole exp) 44 | complete-elaboration-ana gc (ECLam1 ec) (TCArr t1 t2) (EALam x₁ MAArr exp) 45 | with complete-elaboration-ana (gcomp-extend gc t1 x₁) ec t2 exp 46 | ... | ih , ih3 , ih2 = DCLam ih t1 , TCArr t1 ih3 , ih2 47 | complete-elaboration-ana gc ec tc (EASubsume x x₁ x₂ x₃) 48 | with complete-elaboration-synth gc ec x₂ 49 | ... | ih1 , ih2 , ih3 = ih1 , ih2 , ih3 50 | 51 | -- this is just a convenience since it shows up a few times above 52 | comp-ana : ∀{Γ e τ d τ' Δ} → 53 | Γ gcomplete → 54 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 55 | d dcomplete → 56 | τ' tcomplete 57 | comp-ana gc ex dc = complete-ta gc (π2 (typed-elaboration-ana ex)) dc 58 | -------------------------------------------------------------------------------- /complete-preservation.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import preservation 6 | 7 | module complete-preservation where 8 | -- if you substitute a complete term into a complete term, the result is 9 | -- still complete. 10 | cp-subst : ∀ {x d1 d2} → 11 | d1 dcomplete → 12 | d2 dcomplete → 13 | ([ d2 / x ] d1) dcomplete 14 | cp-subst {x = y} (DCVar {x = x}) dc2 with natEQ x y 15 | cp-subst DCVar dc2 | Inl refl = dc2 16 | cp-subst DCVar dc2 | Inr x₂ = DCVar 17 | cp-subst DCConst dc2 = DCConst 18 | cp-subst {x = x} (DCLam {x = y} dc1 x₂) dc2 with natEQ y x 19 | cp-subst (DCLam dc1 x₃) dc2 | Inl refl = DCLam dc1 x₃ 20 | cp-subst (DCLam dc1 x₃) dc2 | Inr x₂ = DCLam (cp-subst dc1 dc2) x₃ 21 | cp-subst (DCAp dc1 dc2) dc3 = DCAp (cp-subst dc1 dc3) (cp-subst dc2 dc3) 22 | cp-subst (DCCast dc1 x₁ x₂) dc2 = DCCast (cp-subst dc1 dc2) x₁ x₂ 23 | 24 | -- this just lets me pull the particular x out of a derivation; it's not 25 | -- bound in any of the constructors explicitly since it's only in the 26 | -- lambda case; so below i have no idea how else to get a name for it, 27 | -- instead of leaving it dotted in the context 28 | lem-proj : {x : Nat} {d : ihexp} { τ : htyp} → (·λ_[_]_ x τ d) dcomplete → Σ[ y ∈ Nat ] (y == x) 29 | lem-proj {x} (DCLam dc x₁) = x , refl 30 | 31 | -- a complete well typed term steps to a complete term. 32 | cp-rhs : ∀{d τ d' Δ} → 33 | d dcomplete → 34 | Δ , ∅ ⊢ d :: τ → 35 | d ↦ d' → 36 | d' dcomplete 37 | cp-rhs dc TAConst (Step FHOuter () FHOuter) 38 | cp-rhs dc (TAVar x₁) stp = abort (somenotnone (! x₁)) 39 | cp-rhs dc (TALam _ wt) (Step FHOuter () FHOuter) 40 | -- this case is a little more complicated than it feels like it ought to 41 | -- be, just from horsing around with agda implicit variables. 42 | cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) with lem-proj dc 43 | cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl with cp-subst {x = x} dc dc₁ 44 | ... | qq with natEQ x x 45 | cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl | DCLam qq x₁ | Inl refl = cp-subst qq dc₁ 46 | cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl | qq | Inr x₁ = abort (x₁ refl) 47 | 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₃ 48 | cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step (FHAp1 x) x₁ (FHAp1 x₂)) = DCAp (cp-rhs dc wt (Step x x₁ x₂)) dc₁ 49 | cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step (FHAp2 x) x₁ (FHAp2 x₂)) = DCAp dc (cp-rhs dc₁ wt₁ (Step x x₁ x₂)) 50 | cp-rhs () (TAEHole x x₁) stp 51 | cp-rhs () (TANEHole x wt x₁) stp 52 | cp-rhs (DCCast dc x x₁) (TACast wt x₂) (Step FHOuter ITCastID FHOuter) = dc 53 | cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITCastSucceed x₃) FHOuter) 54 | cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITCastFail x₃ x₄ x₅) FHOuter) 55 | cp-rhs (DCCast dc x ()) (TACast wt x₂) (Step FHOuter (ITGround x₃) FHOuter) 56 | cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITExpand x₃) FHOuter) 57 | 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₁ 58 | cp-rhs () (TAFailedCast wt x x₁ x₂) stp 59 | 60 | -- this is the main result of this file. 61 | complete-preservation : ∀{d τ d' Δ} → 62 | binders-unique d → 63 | d dcomplete → 64 | Δ , ∅ ⊢ d :: τ → 65 | d ↦ d' → 66 | (Δ , ∅ ⊢ d' :: τ) × (d' dcomplete) 67 | complete-preservation bd dc wt stp = preservation bd wt stp , cp-rhs dc wt stp 68 | -------------------------------------------------------------------------------- /complete-progress.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | 6 | open import progress 7 | open import htype-decidable 8 | open import lemmas-complete 9 | 10 | module complete-progress where 11 | 12 | -- as in progress, we define a datatype for the possible outcomes of 13 | -- progress for readability. 14 | data okc : (d : ihexp) (Δ : hctx) → Set where 15 | V : ∀{d Δ} → d val → okc d Δ 16 | S : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → okc d Δ 17 | 18 | complete-progress : {Δ : hctx} {d : ihexp} {τ : htyp} → 19 | Δ , ∅ ⊢ d :: τ → 20 | d dcomplete → 21 | okc d Δ 22 | complete-progress wt comp with progress wt 23 | complete-progress wt comp | I x = abort (lem-ind-comp comp x) 24 | complete-progress wt comp | S x = S x 25 | complete-progress wt comp | BV (BVVal x) = V x 26 | complete-progress wt (DCCast comp x₂ ()) | BV (BVHoleCast x x₁) 27 | complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVArrCast x₁ x₂) = abort (x₁ (complete-consistency x x₃ x₄)) 28 | -------------------------------------------------------------------------------- /contexts.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | 4 | module contexts where 5 | -- variables are named with naturals in ė. therefore we represent 6 | -- contexts as functions from names for variables (nats) to possible 7 | -- bindings. 8 | _ctx : Set → Set 9 | A ctx = Nat → Maybe A 10 | 11 | -- convenient shorthand for the (unique up to fun. ext.) empty context 12 | ∅ : {A : Set} → A ctx 13 | ∅ _ = None 14 | 15 | infixr 100 ■_ 16 | 17 | -- the domain of a context is those naturals which cuase it to emit some τ 18 | dom : {A : Set} → A ctx → Nat → Set 19 | dom {A} Γ x = Σ[ τ ∈ A ] (Γ x == Some τ) 20 | 21 | -- membership, or presence, in a context 22 | _∈_ : {A : Set} (p : Nat × A) → (Γ : A ctx) → Set 23 | (x , y) ∈ Γ = (Γ x) == Some y 24 | 25 | -- this packages up an appeal to context memebership into a form that 26 | -- lets us retain more information 27 | ctxindirect : {A : Set} (Γ : A ctx) (n : Nat) → Σ[ a ∈ A ] (Γ n == Some a) + Γ n == None 28 | ctxindirect Γ n with Γ n 29 | ctxindirect Γ n | Some x = Inl (x , refl) 30 | ctxindirect Γ n | None = Inr refl 31 | 32 | -- apartness for contexts 33 | _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set 34 | x # Γ = (Γ x) == None 35 | 36 | -- disjoint contexts are those which share no mappings 37 | _##_ : {A : Set} → A ctx → A ctx → Set 38 | _##_ {A} Γ Γ' = ((n : Nat) → dom Γ n → n # Γ') × ((n : Nat) → dom Γ' n → n # Γ) 39 | 40 | -- contexts give at most one binding for each variable 41 | ctxunicity : {A : Set} → {Γ : A ctx} {n : Nat} {t t' : A} → 42 | (n , t) ∈ Γ → 43 | (n , t') ∈ Γ → 44 | t == t' 45 | ctxunicity {n = n} p q with natEQ n n 46 | ctxunicity p q | Inl refl = someinj (! p · q) 47 | ctxunicity _ _ | Inr x≠x = abort (x≠x refl) 48 | 49 | -- warning: this is union, but it assumes WITHOUT CHECKING that the 50 | -- domains are disjoint. this is inherently asymmetric, and that's 51 | -- reflected throughout the development that follows 52 | _∪_ : {A : Set} → A ctx → A ctx → A ctx 53 | (C1 ∪ C2) x with C1 x 54 | (C1 ∪ C2) x | Some x₁ = Some x₁ 55 | (C1 ∪ C2) x | None = C2 x 56 | 57 | -- the singleton context 58 | ■_ : {A : Set} → (Nat × A) → A ctx 59 | (■ (x , a)) y with natEQ x y 60 | (■ (x , a)) .x | Inl refl = Some a 61 | ... | Inr _ = None 62 | 63 | -- context extension 64 | _,,_ : {A : Set} → A ctx → (Nat × A) → A ctx 65 | (Γ ,, (x , t)) = Γ ∪ (■ (x , t)) 66 | 67 | infixl 10 _,,_ 68 | 69 | -- used below in proof of ∪ commutativity and associativity 70 | lem-dom-union1 : {A : Set} {C1 C2 : A ctx} {x : Nat} → 71 | C1 ## C2 → 72 | dom C1 x → 73 | (C1 ∪ C2) x == C1 x 74 | lem-dom-union1 {A} {C1} {C2} {x} (d1 , d2) D with C1 x 75 | lem-dom-union1 (d1 , d2) D | Some x₁ = refl 76 | lem-dom-union1 (d1 , d2) D | None = abort (somenotnone (! (π2 D))) 77 | 78 | lem-dom-union2 : {A : Set} {C1 C2 : A ctx} {x : Nat} → 79 | C1 ## C2 → 80 | dom C1 x → 81 | (C2 ∪ C1) x == C1 x 82 | lem-dom-union2 {A} {C1} {C2} {x} (d1 , d2) D with ctxindirect C2 x 83 | lem-dom-union2 {A} {C1} {C2} {x} (d1 , d2) D | Inl x₁ = abort (somenotnone (! (π2 x₁) · d1 x D )) 84 | lem-dom-union2 {A} {C1} {C2} {x} (d1 , d2) D | Inr x₁ with C2 x 85 | lem-dom-union2 (d1 , d2) D | Inr x₂ | Some x₁ = abort (somenotnone x₂) 86 | lem-dom-union2 (d1 , d2) D | Inr x₁ | None = refl 87 | 88 | -- if the contexts in question are disjoint, then union is commutative 89 | ∪comm : {A : Set} → (C1 C2 : A ctx) → C1 ## C2 → (C1 ∪ C2) == (C2 ∪ C1) 90 | ∪comm C1 C2 (d1 , d2)= funext guts 91 | where 92 | lem-apart-union1 : {A : Set} (C1 C2 : A ctx) (x : Nat) → x # C1 → x # C2 → x # (C1 ∪ C2) 93 | lem-apart-union1 C1 C2 x apt1 apt2 with C1 x 94 | lem-apart-union1 C1 C2 x apt1 apt2 | Some x₁ = abort (somenotnone apt1) 95 | lem-apart-union1 C1 C2 x apt1 apt2 | None = apt2 96 | 97 | lem-apart-union2 : {A : Set} (C1 C2 : A ctx) (x : Nat) → x # C1 → x # C2 → x # (C2 ∪ C1) 98 | lem-apart-union2 C1 C2 x apt1 apt2 with C2 x 99 | lem-apart-union2 C1 C2 x apt1 apt2 | Some x₁ = abort (somenotnone apt2) 100 | lem-apart-union2 C1 C2 x apt1 apt2 | None = apt1 101 | 102 | guts : (x : Nat) → (C1 ∪ C2) x == (C2 ∪ C1) x 103 | guts x with ctxindirect C1 x | ctxindirect C2 x 104 | guts x | Inl (π1 , π2) | Inl (π3 , π4) = abort (somenotnone (! π4 · d1 x (π1 , π2))) 105 | 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) 106 | 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) 107 | 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) 108 | 109 | 110 | -- an element in the left of a union is in the union 111 | x∈∪l : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ → (n , x) ∈ (Γ ∪ Γ') 112 | x∈∪l Γ Γ' n x xin with Γ n 113 | x∈∪l Γ Γ' n x₁ xin | Some x = xin 114 | x∈∪l Γ Γ' n x () | None 115 | 116 | -- an element in the right of a union is in the union as long as the 117 | -- contexts are disjoint; this asymmetry reflects the asymmetry in the 118 | -- definition of union 119 | x∈∪r : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → 120 | (n , x) ∈ Γ' → 121 | Γ' ## Γ → 122 | (n , x) ∈ (Γ ∪ Γ') 123 | x∈∪r Γ Γ' n x nx∈ disj = tr (λ qq → (n , x) ∈ qq) (∪comm _ _ disj) (x∈∪l Γ' Γ n x nx∈) 124 | 125 | -- an element is in the context formed with just itself 126 | x∈■ : {A : Set} (n : Nat) (a : A) → (n , a) ∈ (■ (n , a)) 127 | x∈■ n a with natEQ n n 128 | x∈■ n a | Inl refl = refl 129 | x∈■ n a | Inr x = abort (x refl) 130 | 131 | -- if an index is in the domain of a singleton context, it's the only 132 | -- index in the context 133 | lem-dom-eq : {A : Set} {y : A} {n m : Nat} → 134 | dom (■ (m , y)) n → 135 | n == m 136 | lem-dom-eq {n = n} {m = m} (π1 , π2) with natEQ m n 137 | lem-dom-eq (π1 , π2) | Inl refl = refl 138 | lem-dom-eq (π1 , π2) | Inr x = abort (somenotnone (! π2)) 139 | 140 | -- a singleton context formed with an index apart from a context is 141 | -- disjoint from that context 142 | lem-apart-sing-disj : {A : Set} {n : Nat} {a : A} {Γ : A ctx} → 143 | n # Γ → 144 | (■ (n , a)) ## Γ 145 | lem-apart-sing-disj {A} {n} {a} {Γ} apt = asd1 , asd2 146 | where 147 | asd1 : (n₁ : Nat) → dom (■ (n , a)) n₁ → n₁ # Γ 148 | asd1 m d with lem-dom-eq d 149 | asd1 .n d | refl = apt 150 | 151 | asd2 : (n₁ : Nat) → dom Γ n₁ → n₁ # (■ (n , a)) 152 | asd2 m (π1 , π2) with natEQ n m 153 | asd2 .n (π1 , π2) | Inl refl = abort (somenotnone (! π2 · apt )) 154 | asd2 m (π1 , π2) | Inr x = refl 155 | 156 | -- the only index of a singleton context is in its domain 157 | lem-domsingle : {A : Set} (p : Nat) (q : A) → dom (■ (p , q)) p 158 | lem-domsingle p q with natEQ p p 159 | lem-domsingle p q | Inl refl = q , refl 160 | lem-domsingle p q | Inr x₁ = abort (x₁ refl) 161 | 162 | 163 | -- dual of above 164 | lem-disj-sing-apart : {A : Set} {n : Nat} {a : A} {Γ : A ctx} → 165 | (■ (n , a)) ## Γ → 166 | n # Γ 167 | lem-disj-sing-apart {A} {n} {a} {Γ} (d1 , d2) = d1 n (lem-domsingle n a) 168 | 169 | -- the singleton context can only produce one non-none result 170 | lem-insingeq : {A : Set} {x x' : Nat} {τ τ' : A} → 171 | (■ (x , τ)) x' == Some τ' → 172 | τ == τ' 173 | lem-insingeq {A} {x} {x'} {τ} {τ'} eq with lem-dom-eq (τ' , eq) 174 | lem-insingeq {A} {x} {.x} {τ} {τ'} eq | refl with natEQ x x 175 | lem-insingeq refl | refl | Inl refl = refl 176 | lem-insingeq eq | refl | Inr x₁ = abort (somenotnone (! eq)) 177 | 178 | -- if an index doesn't appear in a context, and the union of that context 179 | -- with a singleton does produce a result, it must have come from the singleton 180 | lem-apart-union-eq : {A : Set} {Γ : A ctx} {x x' : Nat} {τ τ' : A} → 181 | x' # Γ → 182 | (Γ ∪ ■ (x , τ)) x' == Some τ' → 183 | τ == τ' 184 | lem-apart-union-eq {A} {Γ} {x} {x'} {τ} {τ'} apart eq with Γ x' 185 | lem-apart-union-eq apart eq | Some x = abort (somenotnone apart) 186 | lem-apart-union-eq apart eq | None = lem-insingeq eq 187 | 188 | -- if an index not in a singleton context produces a result from that 189 | -- singleton unioned with another context, the result must have come from 190 | -- the other context 191 | lem-neq-union-eq : {A : Set} {Γ : A ctx} {x x' : Nat} {τ τ' : A} → 192 | x' ≠ x → 193 | (Γ ∪ ■ (x , τ)) x' == Some τ' → 194 | Γ x' == Some τ' 195 | lem-neq-union-eq {A} {Γ} {x} {x'} {τ} {τ'} neq eq with Γ x' 196 | lem-neq-union-eq neq eq | Some x = eq 197 | lem-neq-union-eq {A} {Γ} {x} {x'} {τ} {τ'} neq eq | None with natEQ x x' 198 | lem-neq-union-eq neq eq | None | Inl x₁ = abort ((flip neq) x₁) 199 | lem-neq-union-eq neq eq | None | Inr x₁ = abort (somenotnone (! eq)) 200 | 201 | -- extending a context with a new index produces the result paired with 202 | -- that index. 203 | ctx-top : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → 204 | (n # Γ) → 205 | (n , a) ∈ (Γ ,, (n , a)) 206 | ctx-top Γ n a apt = x∈∪r Γ (■ (n , a)) n a (x∈■ n a) (lem-apart-sing-disj apt) 207 | 208 | -- if a union of a singleton and a ctx produces no result, the argument 209 | -- index must be apart from the ctx and disequal to the index of the 210 | -- singleton 211 | lem-union-none : {A : Set} {Γ : A ctx} {a : A} {x x' : Nat} 212 | → (Γ ∪ ■ (x , a)) x' == None 213 | → (x ≠ x') × (x' # Γ) 214 | lem-union-none {A} {Γ} {a} {x} {x'} emp with ctxindirect Γ x' 215 | lem-union-none {A} {Γ} {a} {x} {x'} emp | Inl (π1 , π2) with Γ x' 216 | lem-union-none emp | Inl (π1 , π2) | Some x = abort (somenotnone emp) 217 | lem-union-none {A} {Γ} {a} {x} {x'} emp | Inl (π1 , π2) | None with natEQ x x' 218 | lem-union-none emp | Inl (π1 , π2) | None | Inl x₁ = abort (somenotnone (! π2)) 219 | lem-union-none emp | Inl (π1 , π2) | None | Inr x₁ = x₁ , refl 220 | lem-union-none {A} {Γ} {a} {x} {x'} emp | Inr y with Γ x' 221 | lem-union-none emp | Inr y | Some x = abort (somenotnone emp) 222 | lem-union-none {A} {Γ} {a} {x} {x'} emp | Inr y | None with natEQ x x' 223 | lem-union-none emp | Inr y | None | Inl refl = abort (somenotnone emp) 224 | lem-union-none emp | Inr y | None | Inr x₁ = x₁ , refl 225 | 226 | 227 | --- lemmas building up to a proof of associativity of ∪ 228 | ctxignore1 : {A : Set} (x : Nat) (C1 C2 : A ctx) → x # C1 → (C1 ∪ C2) x == C2 x 229 | ctxignore1 x C1 C2 apt with ctxindirect C1 x 230 | ctxignore1 x C1 C2 apt | Inl x₁ = abort (somenotnone (! (π2 x₁) · apt)) 231 | ctxignore1 x C1 C2 apt | Inr x₁ with C1 x 232 | ctxignore1 x C1 C2 apt | Inr x₂ | Some x₁ = abort (somenotnone (x₂)) 233 | ctxignore1 x C1 C2 apt | Inr x₁ | None = refl 234 | 235 | ctxignore2 : {A : Set} (x : Nat) (C1 C2 : A ctx) → x # C2 → (C1 ∪ C2) x == C1 x 236 | ctxignore2 x C1 C2 apt with ctxindirect C2 x 237 | ctxignore2 x C1 C2 apt | Inl x₁ = abort (somenotnone (! (π2 x₁) · apt)) 238 | ctxignore2 x C1 C2 apt | Inr x₁ with C1 x 239 | ctxignore2 x C1 C2 apt | Inr x₂ | Some x₁ = refl 240 | ctxignore2 x C1 C2 apt | Inr x₁ | None = x₁ 241 | 242 | ctxcollapse1 : {A : Set} → (C1 C2 C3 : A ctx) (x : Nat) → 243 | (x # C3) → 244 | (C2 ∪ C3) x == C2 x → 245 | (C1 ∪ (C2 ∪ C3)) x == (C1 ∪ C2) x 246 | ctxcollapse1 C1 C2 C3 x apt eq with C2 x 247 | ctxcollapse1 C1 C2 C3 x apt eq | Some x₁ with C1 x 248 | ctxcollapse1 C1 C2 C3 x apt eq | Some x₂ | Some x₁ = refl 249 | ctxcollapse1 C1 C2 C3 x apt eq | Some x₁ | None with C2 x 250 | ctxcollapse1 C1 C2 C3 x apt eq | Some x₂ | None | Some x₁ = refl 251 | ctxcollapse1 C1 C2 C3 x apt eq | Some x₁ | None | None = apt 252 | ctxcollapse1 C1 C2 C3 x apt eq | None with C1 x 253 | ctxcollapse1 C1 C2 C3 x apt eq | None | Some x₁ = refl 254 | ctxcollapse1 C1 C2 C3 x apt eq | None | None with C2 x 255 | ctxcollapse1 C1 C2 C3 x apt eq | None | None | Some x₁ = refl 256 | ctxcollapse1 C1 C2 C3 x apt eq | None | None | None = eq 257 | 258 | ctxcollapse2 : {A : Set} → (C1 C2 C3 : A ctx) (x : Nat) → 259 | (x # C2) → 260 | (C2 ∪ C3) x == C3 x → 261 | (C1 ∪ (C2 ∪ C3)) x == (C1 ∪ C3) x 262 | ctxcollapse2 C1 C2 C3 x apt eq with C1 x 263 | ctxcollapse2 C1 C2 C3 x apt eq | Some x₁ = refl 264 | ctxcollapse2 C1 C2 C3 x apt eq | None with C2 x 265 | ctxcollapse2 C1 C2 C3 x apt eq | None | Some x₁ = eq 266 | ctxcollapse2 C1 C2 C3 x apt eq | None | None = refl 267 | 268 | ctxcollapse3 : {A : Set} → (C1 C2 C3 : A ctx) (x : Nat) → 269 | (x # C2) → 270 | ((C1 ∪ C2) ∪ C3) x == (C1 ∪ C3) x 271 | ctxcollapse3 C1 C2 C3 x apt with C1 x 272 | ctxcollapse3 C1 C2 C3 x apt | Some x₁ = refl 273 | ctxcollapse3 C1 C2 C3 x apt | None with C2 x 274 | ctxcollapse3 C1 C2 C3 x apt | None | Some x₁ = abort (somenotnone apt) 275 | ctxcollapse3 C1 C2 C3 x apt | None | None = refl 276 | 277 | ∪assoc : {A : Set} (C1 C2 C3 : A ctx) → (C2 ## C3) → (C1 ∪ C2) ∪ C3 == C1 ∪ (C2 ∪ C3) 278 | ∪assoc C1 C2 C3 (d1 , d2) = funext guts 279 | where 280 | case2 : (x : Nat) → x # C3 → dom C2 x → ((C1 ∪ C2) ∪ C3) x == (C1 ∪ (C2 ∪ C3)) x 281 | case2 x apt dom = (ctxignore2 x (C1 ∪ C2) C3 apt) · 282 | ! (ctxcollapse1 C1 C2 C3 x apt (lem-dom-union1 (d1 , d2) dom)) 283 | 284 | case34 : (x : Nat) → x # C2 → ((C1 ∪ C2) ∪ C3) x == (C1 ∪ (C2 ∪ C3)) x 285 | case34 x apt = ctxcollapse3 C1 C2 C3 x apt · 286 | ! (ctxcollapse2 C1 C2 C3 x apt (ctxignore1 x C2 C3 apt)) 287 | 288 | guts : (x : Nat) → ((C1 ∪ C2) ∪ C3) x == (C1 ∪ (C2 ∪ C3)) x 289 | guts x with ctxindirect C2 x | ctxindirect C3 x 290 | guts x | Inl (π1 , π2) | Inl (π3 , π4) = abort (somenotnone (! π4 · d1 x (π1 , π2))) 291 | guts x | Inl x₁ | Inr x₂ = case2 x x₂ x₁ 292 | guts x | Inr x₁ | Inl x₂ = case34 x x₁ 293 | guts x | Inr x₁ | Inr x₂ = case34 x x₁ 294 | 295 | -- if x is apart from either part of a union, the answer comes from the other one 296 | 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) 297 | lem-dom-union-apt1 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x 298 | lem-dom-union-apt1 apt xin | Some x₁ = abort (somenotnone apt) 299 | lem-dom-union-apt1 apt xin | None = xin 300 | 301 | 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) 302 | lem-dom-union-apt2 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x 303 | lem-dom-union-apt2 apt xin | Some x₁ = xin 304 | lem-dom-union-apt2 apt xin | None = abort (somenotnone (! xin · apt)) 305 | -------------------------------------------------------------------------------- /continuity.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | 6 | open import progress 7 | open import preservation 8 | open import elaborability 9 | open import typed-elaboration 10 | 11 | module continuity where 12 | -- we take the sensibilty theorem as a postulate; for a proof, refer to 13 | -- the POPL17 mechanization. we also postulate some glue that allows us 14 | -- to use our theorems here on the shape of results from that work. 15 | postulate 16 | action : Set 17 | zexp : Set 18 | _◆ : zexp → hexp 19 | _⊢_=>_~_~>_=>_ : (Γ : tctx) → (e1 : zexp) → (t1 : htyp) 20 | → (α : action) → (e2 : zexp) → (t2 : htyp) → Set 21 | sensibility : {Γ : tctx} {e e' : zexp} {τ τ' : htyp} {α : action} → 22 | Γ ⊢ (e ◆) => τ → 23 | Γ ⊢ e => τ ~ α ~> e' => τ' → 24 | Γ ⊢ (e' ◆) => τ' 25 | binders-unique-h : hexp → Set 26 | binders-unique-z : zexp → Set 27 | binders-unique-cursor1 : ∀{e} → binders-unique-z e → binders-unique-h (e ◆) 28 | binders-unique-cursor2 : ∀{e} → binders-unique-h (e ◆) → binders-unique-z e 29 | binders-unique-sensibility : {Γ : tctx} {e e' : zexp} {τ τ' : htyp} {α : action} → 30 | binders-unique-z e → 31 | Γ ⊢ e => τ ~ α ~> e' => τ' → 32 | binders-unique-z e' 33 | expansion-unique : ∀{Γ e τ d Δ} → 34 | binders-unique-h e → 35 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 36 | binders-unique d 37 | 38 | 39 | continuity : ∀{ e τ α e' τ' } 40 | → binders-unique-z e 41 | → ∅ ⊢ (e ◆) => τ 42 | → ∅ ⊢ e => τ ~ α ~> e' => τ' 43 | → Σ[ Δ ∈ hctx ] Σ[ d ∈ ihexp ] 44 | ( ∅ ⊢ (e' ◆) ⇒ τ' ~> d ⊣ Δ 45 | × Δ , ∅ ⊢ d :: τ' 46 | × ( (Σ[ d' ∈ ihexp ]( d ↦ d' × Δ , ∅ ⊢ d' :: τ' )) 47 | + d boxedval 48 | + d indet 49 | ) 50 | ) 51 | continuity bu wt action with sensibility wt action 52 | ... | sense with elaborability-synth sense 53 | ... | d , Δ , exp with typed-elaboration-synth exp 54 | ... | d::τ' with progress d::τ' 55 | ... | (S (d' , stp)) = Δ , d , exp , d::τ' , Inl (d' , stp , preservation (expansion-unique (binders-unique-cursor1 (binders-unique-sensibility bu action)) exp) d::τ' stp) 56 | ... | (I ind) = Δ , d , exp , d::τ' , Inr (Inr ind) 57 | ... | (BV boxed) = Δ , d , exp , d::τ' , Inr (Inl boxed) 58 | -------------------------------------------------------------------------------- /contraction.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import lemmas-disjointness 6 | 7 | module contraction where 8 | -- in the same style as the proofs of exchange, this argument along with 9 | -- trasnport allows you to prove contraction for all the hypothetical 10 | -- judgements uniformly. we never explicitly use contraction anywhere, so 11 | -- we omit any of the specific instances for concision; they are entirely 12 | -- mechanical, as are the specific instances of exchange. one is shown 13 | -- below as an example. 14 | contract : {A : Set} {x : Nat} {τ : A} (Γ : A ctx) → 15 | ((Γ ,, (x , τ)) ,, (x , τ)) == (Γ ,, (x , τ)) 16 | contract {A} {x} {τ} Γ = funext guts 17 | where 18 | guts : (y : Nat) → (Γ ,, (x , τ) ,, (x , τ)) y == (Γ ,, (x , τ)) y 19 | guts y with natEQ x y 20 | guts .x | Inl refl with Γ x 21 | guts .x | Inl refl | Some x₁ = refl 22 | guts .x | Inl refl | None with natEQ x x 23 | guts .x | Inl refl | None | Inl refl = refl 24 | guts .x | Inl refl | None | Inr x₁ = abort (x₁ refl) 25 | guts y | Inr x₁ with Γ y 26 | guts y | Inr x₂ | Some x₁ = refl 27 | guts y | Inr x₁ | None with natEQ x y 28 | guts .x | Inr x₂ | None | Inl refl = refl 29 | guts y | Inr x₂ | None | Inr x₁ with natEQ x y 30 | guts .x | Inr x₃ | None | Inr x₂ | Inl refl = abort (x₃ refl) 31 | guts y | Inr x₃ | None | Inr x₂ | Inr x₁ = refl 32 | 33 | contract-synth : ∀{ Γ x τ e τ'} 34 | → (Γ ,, (x , τ) ,, (x , τ)) ⊢ e => τ' 35 | → (Γ ,, (x , τ)) ⊢ e => τ' 36 | contract-synth {Γ = Γ} {e = e} {τ' = τ'} = 37 | tr (λ qq → qq ⊢ e => τ') (contract Γ) 38 | 39 | -- as an aside, this also establishes the other direction which is rarely 40 | -- mentioned, since equality is symmetric 41 | elab-synth : ∀{ Γ x τ e τ'} 42 | → (Γ ,, (x , τ)) ⊢ e => τ' 43 | → (Γ ,, (x , τ) ,, (x , τ)) ⊢ e => τ' 44 | elab-synth {Γ = Γ} {e = e} {τ' = τ'} = 45 | tr (λ qq → qq ⊢ e => τ') (! (contract Γ)) 46 | -------------------------------------------------------------------------------- /core.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import contexts 4 | 5 | module core where 6 | -- types 7 | data htyp : Set where 8 | b : htyp 9 | ⦇-⦈ : htyp 10 | _==>_ : htyp → htyp → htyp 11 | 12 | -- arrow type constructors bind very tightly 13 | infixr 25 _==>_ 14 | 15 | -- external expressions 16 | data hexp : Set where 17 | c : hexp 18 | _·:_ : hexp → htyp → hexp 19 | X : Nat → hexp 20 | ·λ : Nat → hexp → hexp 21 | ·λ_[_]_ : Nat → htyp → hexp → hexp 22 | ⦇-⦈[_] : Nat → hexp 23 | ⦇⌜_⌟⦈[_] : hexp → Nat → hexp 24 | _∘_ : hexp → hexp → hexp 25 | 26 | -- the type of type contexts, i.e. Γs in the judegments below 27 | tctx : Set 28 | tctx = htyp ctx 29 | 30 | mutual 31 | -- identity substitution, substitition environments 32 | data env : Set where 33 | Id : (Γ : tctx) → env 34 | Subst : (d : ihexp) → (y : Nat) → env → env 35 | 36 | -- internal expressions 37 | data ihexp : Set where 38 | c : ihexp 39 | X : Nat → ihexp 40 | ·λ_[_]_ : Nat → htyp → ihexp → ihexp 41 | ⦇-⦈⟨_⟩ : (Nat × env) → ihexp 42 | ⦇⌜_⌟⦈⟨_⟩ : ihexp → (Nat × env) → ihexp 43 | _∘_ : ihexp → ihexp → ihexp 44 | _⟨_⇒_⟩ : ihexp → htyp → htyp → ihexp 45 | _⟨_⇒⦇-⦈⇏_⟩ : ihexp → htyp → htyp → ihexp 46 | 47 | -- convenient notation for chaining together two agreeable casts 48 | _⟨_⇒_⇒_⟩ : ihexp → htyp → htyp → htyp → ihexp 49 | d ⟨ t1 ⇒ t2 ⇒ t3 ⟩ = d ⟨ t1 ⇒ t2 ⟩ ⟨ t2 ⇒ t3 ⟩ 50 | 51 | -- type consistency 52 | data _~_ : (t1 t2 : htyp) → Set where 53 | TCRefl : {τ : htyp} → τ ~ τ 54 | TCHole1 : {τ : htyp} → τ ~ ⦇-⦈ 55 | TCHole2 : {τ : htyp} → ⦇-⦈ ~ τ 56 | TCArr : {τ1 τ2 τ1' τ2' : htyp} → 57 | τ1 ~ τ1' → 58 | τ2 ~ τ2' → 59 | τ1 ==> τ2 ~ τ1' ==> τ2' 60 | 61 | -- type inconsistency 62 | data _~̸_ : (τ1 τ2 : htyp) → Set where 63 | ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2 64 | ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b 65 | ICArr1 : {τ1 τ2 τ3 τ4 : htyp} → 66 | τ1 ~̸ τ3 → 67 | τ1 ==> τ2 ~̸ τ3 ==> τ4 68 | ICArr2 : {τ1 τ2 τ3 τ4 : htyp} → 69 | τ2 ~̸ τ4 → 70 | τ1 ==> τ2 ~̸ τ3 ==> τ4 71 | 72 | --- matching for arrows 73 | data _▸arr_ : htyp → htyp → Set where 74 | MAHole : ⦇-⦈ ▸arr ⦇-⦈ ==> ⦇-⦈ 75 | MAArr : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2 76 | 77 | -- the type of hole contexts, i.e. Δs in the judgements 78 | hctx : Set 79 | hctx = (htyp ctx × htyp) ctx 80 | 81 | -- notation for a triple to match the CMTT syntax 82 | _::_[_] : Nat → htyp → tctx → (Nat × (tctx × htyp)) 83 | u :: τ [ Γ ] = u , (Γ , τ) 84 | 85 | -- the hole name u does not appear in the term e 86 | data hole-name-new : (e : hexp) (u : Nat) → Set where 87 | HNConst : ∀{u} → hole-name-new c u 88 | HNAsc : ∀{e τ u} → 89 | hole-name-new e u → 90 | hole-name-new (e ·: τ) u 91 | HNVar : ∀{x u} → hole-name-new (X x) u 92 | HNLam1 : ∀{x e u} → 93 | hole-name-new e u → 94 | hole-name-new (·λ x e) u 95 | HNLam2 : ∀{x e u τ} → 96 | hole-name-new e u → 97 | hole-name-new (·λ x [ τ ] e) u 98 | HNHole : ∀{u u'} → 99 | u' ≠ u → 100 | hole-name-new (⦇-⦈[ u' ]) u 101 | HNNEHole : ∀{u u' e} → 102 | u' ≠ u → 103 | hole-name-new e u → 104 | hole-name-new (⦇⌜ e ⌟⦈[ u' ]) u 105 | HNAp : ∀{ u e1 e2 } → 106 | hole-name-new e1 u → 107 | hole-name-new e2 u → 108 | hole-name-new (e1 ∘ e2) u 109 | 110 | -- two terms that do not share any hole names 111 | data holes-disjoint : (e1 : hexp) → (e2 : hexp) → Set where 112 | HDConst : ∀{e} → holes-disjoint c e 113 | HDAsc : ∀{e1 e2 τ} → holes-disjoint e1 e2 → holes-disjoint (e1 ·: τ) e2 114 | HDVar : ∀{x e} → holes-disjoint (X x) e 115 | HDLam1 : ∀{x e1 e2} → holes-disjoint e1 e2 → holes-disjoint (·λ x e1) e2 116 | HDLam2 : ∀{x e1 e2 τ} → holes-disjoint e1 e2 → holes-disjoint (·λ x [ τ ] e1) e2 117 | HDHole : ∀{u e2} → hole-name-new e2 u → holes-disjoint (⦇-⦈[ u ]) e2 118 | HDNEHole : ∀{u e1 e2} → hole-name-new e2 u → holes-disjoint e1 e2 → holes-disjoint (⦇⌜ e1 ⌟⦈[ u ]) e2 119 | HDAp : ∀{e1 e2 e3} → holes-disjoint e1 e3 → holes-disjoint e2 e3 → holes-disjoint (e1 ∘ e2) e3 120 | 121 | -- bidirectional type checking judgements for hexp 122 | mutual 123 | -- synthesis 124 | data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where 125 | SConst : {Γ : tctx} → Γ ⊢ c => b 126 | SAsc : {Γ : tctx} {e : hexp} {τ : htyp} → 127 | Γ ⊢ e <= τ → 128 | Γ ⊢ (e ·: τ) => τ 129 | SVar : {Γ : tctx} {τ : htyp} {x : Nat} → 130 | (x , τ) ∈ Γ → 131 | Γ ⊢ X x => τ 132 | SAp : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} → 133 | holes-disjoint e1 e2 → 134 | Γ ⊢ e1 => τ1 → 135 | τ1 ▸arr τ2 ==> τ → 136 | Γ ⊢ e2 <= τ2 → 137 | Γ ⊢ (e1 ∘ e2) => τ 138 | SEHole : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇-⦈[ u ] => ⦇-⦈ 139 | SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → 140 | hole-name-new e u → 141 | Γ ⊢ e => τ → 142 | Γ ⊢ ⦇⌜ e ⌟⦈[ u ] => ⦇-⦈ 143 | SLam : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} → 144 | x # Γ → 145 | (Γ ,, (x , τ1)) ⊢ e => τ2 → 146 | Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2 147 | 148 | -- analysis 149 | data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where 150 | ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} → 151 | Γ ⊢ e => τ' → 152 | τ ~ τ' → 153 | Γ ⊢ e <= τ 154 | ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} → 155 | x # Γ → 156 | τ ▸arr τ1 ==> τ2 → 157 | (Γ ,, (x , τ1)) ⊢ e <= τ2 → 158 | Γ ⊢ (·λ x e) <= τ 159 | 160 | -- those types without holes 161 | data _tcomplete : htyp → Set where 162 | TCBase : b tcomplete 163 | TCArr : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ==> τ2) tcomplete 164 | 165 | -- those external expressions without holes 166 | data _ecomplete : hexp → Set where 167 | ECConst : c ecomplete 168 | ECAsc : ∀{τ e} → τ tcomplete → e ecomplete → (e ·: τ) ecomplete 169 | ECVar : ∀{x} → (X x) ecomplete 170 | ECLam1 : ∀{x e} → e ecomplete → (·λ x e) ecomplete 171 | ECLam2 : ∀{x e τ} → e ecomplete → τ tcomplete → (·λ x [ τ ] e) ecomplete 172 | ECAp : ∀{e1 e2} → e1 ecomplete → e2 ecomplete → (e1 ∘ e2) ecomplete 173 | 174 | -- those internal expressions without holes 175 | data _dcomplete : ihexp → Set where 176 | DCVar : ∀{x} → (X x) dcomplete 177 | DCConst : c dcomplete 178 | DCLam : ∀{x τ d} → d dcomplete → τ tcomplete → (·λ x [ τ ] d) dcomplete 179 | DCAp : ∀{d1 d2} → d1 dcomplete → d2 dcomplete → (d1 ∘ d2) dcomplete 180 | DCCast : ∀{d τ1 τ2} → d dcomplete → τ1 tcomplete → τ2 tcomplete → (d ⟨ τ1 ⇒ τ2 ⟩) dcomplete 181 | 182 | -- contexts that only produce complete types 183 | _gcomplete : tctx → Set 184 | Γ gcomplete = (x : Nat) (τ : htyp) → (x , τ) ∈ Γ → τ tcomplete 185 | 186 | -- those internal expressions where every cast is the identity cast and 187 | -- there are no failed casts 188 | data cast-id : ihexp → Set where 189 | CIConst : cast-id c 190 | CIVar : ∀{x} → cast-id (X x) 191 | CILam : ∀{x τ d} → cast-id d → cast-id (·λ x [ τ ] d) 192 | CIHole : ∀{u} → cast-id (⦇-⦈⟨ u ⟩) 193 | CINEHole : ∀{d u} → cast-id d → cast-id (⦇⌜ d ⌟⦈⟨ u ⟩) 194 | CIAp : ∀{d1 d2} → cast-id d1 → cast-id d2 → cast-id (d1 ∘ d2) 195 | CICast : ∀{d τ} → cast-id d → cast-id (d ⟨ τ ⇒ τ ⟩) 196 | 197 | -- expansion 198 | mutual 199 | -- synthesis 200 | data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : ihexp) (Δ : hctx) → Set where 201 | ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅ 202 | ESVar : ∀{Γ x τ} → (x , τ) ∈ Γ → 203 | Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅ 204 | ESLam : ∀{Γ x τ1 τ2 e d Δ } → 205 | (x # Γ) → 206 | (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ → 207 | Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ 208 | ESAp : ∀{Γ e1 τ τ1 τ1' τ2 τ2' d1 Δ1 e2 d2 Δ2 } → 209 | holes-disjoint e1 e2 → 210 | Δ1 ## Δ2 → 211 | Γ ⊢ e1 => τ1 → 212 | τ1 ▸arr τ2 ==> τ → 213 | Γ ⊢ e1 ⇐ (τ2 ==> τ) ~> d1 :: τ1' ⊣ Δ1 → 214 | Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 → 215 | Γ ⊢ e1 ∘ e2 ⇒ τ ~> (d1 ⟨ τ1' ⇒ τ2 ==> τ ⟩) ∘ (d2 ⟨ τ2' ⇒ τ2 ⟩) ⊣ (Δ1 ∪ Δ2) 216 | ESEHole : ∀{ Γ u } → 217 | Γ ⊢ ⦇-⦈[ u ] ⇒ ⦇-⦈ ~> ⦇-⦈⟨ u , Id Γ ⟩ ⊣ ■ (u :: ⦇-⦈ [ Γ ]) 218 | ESNEHole : ∀{ Γ e τ d u Δ } → 219 | Δ ## (■ (u , Γ , ⦇-⦈)) → 220 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 221 | Γ ⊢ ⦇⌜ e ⌟⦈[ u ] ⇒ ⦇-⦈ ~> ⦇⌜ d ⌟⦈⟨ u , Id Γ ⟩ ⊣ (Δ ,, u :: ⦇-⦈ [ Γ ]) 222 | ESAsc : ∀ {Γ e τ d τ' Δ} → 223 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 224 | Γ ⊢ (e ·: τ) ⇒ τ ~> d ⟨ τ' ⇒ τ ⟩ ⊣ Δ 225 | 226 | -- analysis 227 | data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : ihexp) (τ' : htyp) (Δ : hctx) → Set where 228 | EALam : ∀{Γ x τ τ1 τ2 e d τ2' Δ } → 229 | (x # Γ) → 230 | τ ▸arr τ1 ==> τ2 → 231 | (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ → 232 | Γ ⊢ ·λ x e ⇐ τ ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ 233 | EASubsume : ∀{e Γ τ' d Δ τ} → 234 | ((u : Nat) → e ≠ ⦇-⦈[ u ]) → 235 | ((e' : hexp) (u : Nat) → e ≠ ⦇⌜ e' ⌟⦈[ u ]) → 236 | Γ ⊢ e ⇒ τ' ~> d ⊣ Δ → 237 | τ ~ τ' → 238 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ 239 | EAEHole : ∀{ Γ u τ } → 240 | Γ ⊢ ⦇-⦈[ u ] ⇐ τ ~> ⦇-⦈⟨ u , Id Γ ⟩ :: τ ⊣ ■ (u :: τ [ Γ ]) 241 | EANEHole : ∀{ Γ e u τ d τ' Δ } → 242 | Δ ## (■ (u , Γ , τ)) → 243 | Γ ⊢ e ⇒ τ' ~> d ⊣ Δ → 244 | Γ ⊢ ⦇⌜ e ⌟⦈[ u ] ⇐ τ ~> ⦇⌜ d ⌟⦈⟨ u , Id Γ ⟩ :: τ ⊣ (Δ ,, u :: τ [ Γ ]) 245 | 246 | -- ground types 247 | data _ground : (τ : htyp) → Set where 248 | GBase : b ground 249 | GHole : ⦇-⦈ ==> ⦇-⦈ ground 250 | 251 | mutual 252 | -- substitution typing 253 | data _,_⊢_:s:_ : hctx → tctx → env → tctx → Set where 254 | STAId : ∀{Γ Γ' Δ} → 255 | ((x : Nat) (τ : htyp) → (x , τ) ∈ Γ' → (x , τ) ∈ Γ) → 256 | Δ , Γ ⊢ Id Γ' :s: Γ' 257 | STASubst : ∀{Γ Δ σ y Γ' d τ } → 258 | Δ , Γ ,, (y , τ) ⊢ σ :s: Γ' → 259 | Δ , Γ ⊢ d :: τ → 260 | Δ , Γ ⊢ Subst d y σ :s: Γ' 261 | 262 | -- type assignment 263 | data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : ihexp) (τ : htyp) → Set where 264 | TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b 265 | TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ 266 | TALam : ∀{ Δ Γ x τ1 d τ2} → 267 | x # Γ → 268 | Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 → 269 | Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2) 270 | TAAp : ∀{ Δ Γ d1 d2 τ1 τ} → 271 | Δ , Γ ⊢ d1 :: τ1 ==> τ → 272 | Δ , Γ ⊢ d2 :: τ1 → 273 | Δ , Γ ⊢ d1 ∘ d2 :: τ 274 | TAEHole : ∀{ Δ Γ σ u Γ' τ} → 275 | (u , (Γ' , τ)) ∈ Δ → 276 | Δ , Γ ⊢ σ :s: Γ' → 277 | Δ , Γ ⊢ ⦇-⦈⟨ u , σ ⟩ :: τ 278 | TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } → 279 | (u , (Γ' , τ)) ∈ Δ → 280 | Δ , Γ ⊢ d :: τ' → 281 | Δ , Γ ⊢ σ :s: Γ' → 282 | Δ , Γ ⊢ ⦇⌜ d ⌟⦈⟨ u , σ ⟩ :: τ 283 | TACast : ∀{ Δ Γ d τ1 τ2} → 284 | Δ , Γ ⊢ d :: τ1 → 285 | τ1 ~ τ2 → 286 | Δ , Γ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 287 | TAFailedCast : ∀{Δ Γ d τ1 τ2} → 288 | Δ , Γ ⊢ d :: τ1 → 289 | τ1 ground → 290 | τ2 ground → 291 | τ1 ≠ τ2 → 292 | Δ , Γ ⊢ d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ :: τ2 293 | 294 | -- substitution 295 | [_/_]_ : ihexp → Nat → ihexp → ihexp 296 | [ d / y ] c = c 297 | [ d / y ] X x 298 | with natEQ x y 299 | [ d / y ] X .y | Inl refl = d 300 | [ d / y ] X x | Inr neq = X x 301 | [ d / y ] (·λ x [ x₁ ] d') 302 | with natEQ x y 303 | [ d / y ] (·λ .y [ τ ] d') | Inl refl = ·λ y [ τ ] d' 304 | [ d / y ] (·λ x [ τ ] d') | Inr x₁ = ·λ x [ τ ] ( [ d / y ] d') 305 | [ d / y ] ⦇-⦈⟨ u , σ ⟩ = ⦇-⦈⟨ u , Subst d y σ ⟩ 306 | [ d / y ] ⦇⌜ d' ⌟⦈⟨ u , σ ⟩ = ⦇⌜ [ d / y ] d' ⌟⦈⟨ u , Subst d y σ ⟩ 307 | [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2) 308 | [ d / y ] (d' ⟨ τ1 ⇒ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒ τ2 ⟩ 309 | [ d / y ] (d' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ 310 | 311 | -- applying an environment to an expression 312 | apply-env : env → ihexp → ihexp 313 | apply-env (Id Γ) d = d 314 | apply-env (Subst d y σ) d' = [ d / y ] ( apply-env σ d') 315 | 316 | -- values 317 | data _val : (d : ihexp) → Set where 318 | VConst : c val 319 | VLam : ∀{x τ d} → (·λ x [ τ ] d) val 320 | 321 | -- boxed values 322 | data _boxedval : (d : ihexp) → Set where 323 | BVVal : ∀{d} → d val → d boxedval 324 | BVArrCast : ∀{ d τ1 τ2 τ3 τ4 } → 325 | τ1 ==> τ2 ≠ τ3 ==> τ4 → 326 | d boxedval → 327 | d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ boxedval 328 | BVHoleCast : ∀{ τ d } → τ ground → d boxedval → d ⟨ τ ⇒ ⦇-⦈ ⟩ boxedval 329 | 330 | mutual 331 | -- indeterminate forms 332 | data _indet : (d : ihexp) → Set where 333 | IEHole : ∀{u σ} → ⦇-⦈⟨ u , σ ⟩ indet 334 | INEHole : ∀{d u σ} → d final → ⦇⌜ d ⌟⦈⟨ u , σ ⟩ indet 335 | IAp : ∀{d1 d2} → ((τ1 τ2 τ3 τ4 : htyp) (d1' : ihexp) → 336 | d1 ≠ (d1' ⟨(τ1 ==> τ2) ⇒ (τ3 ==> τ4)⟩)) → 337 | d1 indet → 338 | d2 final → 339 | (d1 ∘ d2) indet 340 | ICastArr : ∀{d τ1 τ2 τ3 τ4} → 341 | τ1 ==> τ2 ≠ τ3 ==> τ4 → 342 | d indet → 343 | d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ indet 344 | ICastGroundHole : ∀{ τ d } → 345 | τ ground → 346 | d indet → 347 | d ⟨ τ ⇒ ⦇-⦈ ⟩ indet 348 | ICastHoleGround : ∀ { d τ } → 349 | ((d' : ihexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇-⦈ ⟩)) → 350 | d indet → 351 | τ ground → 352 | d ⟨ ⦇-⦈ ⇒ τ ⟩ indet 353 | IFailedCast : ∀{ d τ1 τ2 } → 354 | d final → 355 | τ1 ground → 356 | τ2 ground → 357 | τ1 ≠ τ2 → 358 | d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ indet 359 | 360 | -- final expressions 361 | data _final : (d : ihexp) → Set where 362 | FBoxedVal : ∀{d} → d boxedval → d final 363 | FIndet : ∀{d} → d indet → d final 364 | 365 | 366 | -- contextual dynamics 367 | 368 | -- evaluation contexts 369 | data ectx : Set where 370 | ⊙ : ectx 371 | _∘₁_ : ectx → ihexp → ectx 372 | _∘₂_ : ihexp → ectx → ectx 373 | ⦇⌜_⌟⦈⟨_⟩ : ectx → (Nat × env ) → ectx 374 | _⟨_⇒_⟩ : ectx → htyp → htyp → ectx 375 | _⟨_⇒⦇-⦈⇏_⟩ : ectx → htyp → htyp → ectx 376 | 377 | -- note: this judgement is redundant: in the absence of the premises in 378 | -- the red brackets, all syntactically well formed ectxs are valid. with 379 | -- finality premises, that's not true, and that would propagate through 380 | -- additions to the calculus. so we leave it here for clarity but note 381 | -- that, as written, in any use case its either trival to prove or 382 | -- provides no additional information 383 | 384 | --ε is an evaluation context 385 | data _evalctx : (ε : ectx) → Set where 386 | ECDot : ⊙ evalctx 387 | ECAp1 : ∀{d ε} → 388 | ε evalctx → 389 | (ε ∘₁ d) evalctx 390 | ECAp2 : ∀{d ε} → 391 | -- d final → -- red brackets 392 | ε evalctx → 393 | (d ∘₂ ε) evalctx 394 | ECNEHole : ∀{ε u σ} → 395 | ε evalctx → 396 | ⦇⌜ ε ⌟⦈⟨ u , σ ⟩ evalctx 397 | ECCast : ∀{ ε τ1 τ2} → 398 | ε evalctx → 399 | (ε ⟨ τ1 ⇒ τ2 ⟩) evalctx 400 | ECFailedCast : ∀{ ε τ1 τ2 } → 401 | ε evalctx → 402 | ε ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩ evalctx 403 | 404 | -- d is the result of filling the hole in ε with d' 405 | data _==_⟦_⟧ : (d : ihexp) (ε : ectx) (d' : ihexp) → Set where 406 | FHOuter : ∀{d} → d == ⊙ ⟦ d ⟧ 407 | FHAp1 : ∀{d1 d1' d2 ε} → 408 | d1 == ε ⟦ d1' ⟧ → 409 | (d1 ∘ d2) == (ε ∘₁ d2) ⟦ d1' ⟧ 410 | FHAp2 : ∀{d1 d2 d2' ε} → 411 | -- d1 final → -- red brackets 412 | d2 == ε ⟦ d2' ⟧ → 413 | (d1 ∘ d2) == (d1 ∘₂ ε) ⟦ d2' ⟧ 414 | FHNEHole : ∀{ d d' ε u σ} → 415 | d == ε ⟦ d' ⟧ → 416 | ⦇⌜ d ⌟⦈⟨ (u , σ ) ⟩ == ⦇⌜ ε ⌟⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧ 417 | FHCast : ∀{ d d' ε τ1 τ2 } → 418 | d == ε ⟦ d' ⟧ → 419 | d ⟨ τ1 ⇒ τ2 ⟩ == ε ⟨ τ1 ⇒ τ2 ⟩ ⟦ d' ⟧ 420 | FHFailedCast : ∀{ d d' ε τ1 τ2} → 421 | d == ε ⟦ d' ⟧ → 422 | (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) == (ε ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) ⟦ d' ⟧ 423 | 424 | -- matched ground types 425 | data _▸gnd_ : htyp → htyp → Set where 426 | MGArr : ∀{τ1 τ2} → 427 | (τ1 ==> τ2) ≠ (⦇-⦈ ==> ⦇-⦈) → 428 | (τ1 ==> τ2) ▸gnd (⦇-⦈ ==> ⦇-⦈) 429 | 430 | -- instruction transition judgement 431 | data _→>_ : (d d' : ihexp) → Set where 432 | ITLam : ∀{ x τ d1 d2 } → 433 | -- d2 final → -- red brackets 434 | ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) 435 | ITCastID : ∀{d τ } → 436 | -- d final → -- red brackets 437 | (d ⟨ τ ⇒ τ ⟩) →> d 438 | ITCastSucceed : ∀{d τ } → 439 | -- d final → -- red brackets 440 | τ ground → 441 | (d ⟨ τ ⇒ ⦇-⦈ ⇒ τ ⟩) →> d 442 | ITCastFail : ∀{ d τ1 τ2} → 443 | -- d final → -- red brackets 444 | τ1 ground → 445 | τ2 ground → 446 | τ1 ≠ τ2 → 447 | (d ⟨ τ1 ⇒ ⦇-⦈ ⇒ τ2 ⟩) →> (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) 448 | ITApCast : ∀{d1 d2 τ1 τ2 τ1' τ2' } → 449 | -- d1 final → -- red brackets 450 | -- d2 final → -- red brackets 451 | ((d1 ⟨ (τ1 ==> τ2) ⇒ (τ1' ==> τ2')⟩) ∘ d2) →> ((d1 ∘ (d2 ⟨ τ1' ⇒ τ1 ⟩)) ⟨ τ2 ⇒ τ2' ⟩) 452 | ITGround : ∀{ d τ τ'} → 453 | -- d final → -- red brackets 454 | τ ▸gnd τ' → 455 | (d ⟨ τ ⇒ ⦇-⦈ ⟩) →> (d ⟨ τ ⇒ τ' ⇒ ⦇-⦈ ⟩) 456 | ITExpand : ∀{d τ τ' } → 457 | -- d final → -- red brackets 458 | τ ▸gnd τ' → 459 | (d ⟨ ⦇-⦈ ⇒ τ ⟩) →> (d ⟨ ⦇-⦈ ⇒ τ' ⇒ τ ⟩) 460 | 461 | -- single step (in contextual evaluation sense) 462 | data _↦_ : (d d' : ihexp) → Set where 463 | Step : ∀{ d d0 d' d0' ε} → 464 | d == ε ⟦ d0 ⟧ → 465 | d0 →> d0' → 466 | d' == ε ⟦ d0' ⟧ → 467 | d ↦ d' 468 | 469 | -- reflexive transitive closure of single steps into multi steps 470 | data _↦*_ : (d d' : ihexp) → Set where 471 | MSRefl : ∀{d} → d ↦* d 472 | MSStep : ∀{d d' d''} → 473 | d ↦ d' → 474 | d' ↦* d'' → 475 | d ↦* d'' 476 | 477 | -- freshness 478 | mutual 479 | -- ... with respect to a hole context 480 | data envfresh : Nat → env → Set where 481 | EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ) 482 | EFSubst : ∀{x d σ y} → fresh x d 483 | → envfresh x σ 484 | → x ≠ y 485 | → envfresh x (Subst d y σ) 486 | 487 | -- ... for inernal expressions 488 | data fresh : Nat → ihexp → Set where 489 | FConst : ∀{x} → fresh x c 490 | FVar : ∀{x y} → x ≠ y → fresh x (X y) 491 | FLam : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d) 492 | FHole : ∀{x u σ} → envfresh x σ → fresh x (⦇-⦈⟨ u , σ ⟩) 493 | FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇⌜ d ⌟⦈⟨ u , σ ⟩) 494 | FAp : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2) 495 | FCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩) 496 | FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) 497 | 498 | -- ... for external expressions 499 | data freshh : Nat → hexp → Set where 500 | FRHConst : ∀{x} → freshh x c 501 | FRHAsc : ∀{x e τ} → freshh x e → freshh x (e ·: τ) 502 | FRHVar : ∀{x y} → x ≠ y → freshh x (X y) 503 | FRHLam1 : ∀{x y e} → x ≠ y → freshh x e → freshh x (·λ y e) 504 | FRHLam2 : ∀{x τ e y} → x ≠ y → freshh x e → freshh x (·λ y [ τ ] e) 505 | FRHEHole : ∀{x u} → freshh x (⦇-⦈[ u ]) 506 | FRHNEHole : ∀{x u e} → freshh x e → freshh x (⦇⌜ e ⌟⦈[ u ]) 507 | FRHAp : ∀{x e1 e2} → freshh x e1 → freshh x e2 → freshh x (e1 ∘ e2) 508 | 509 | -- x is not used in a binding site in d 510 | mutual 511 | data unbound-in-σ : Nat → env → Set where 512 | UBσId : ∀{x Γ} → unbound-in-σ x (Id Γ) 513 | UBσSubst : ∀{x d y σ} → unbound-in x d 514 | → unbound-in-σ x σ 515 | → x ≠ y 516 | → unbound-in-σ x (Subst d y σ) 517 | 518 | data unbound-in : (x : Nat) (d : ihexp) → Set where 519 | UBConst : ∀{x} → unbound-in x c 520 | UBVar : ∀{x y} → unbound-in x (X y) 521 | UBLam2 : ∀{x d y τ} → x ≠ y 522 | → unbound-in x d 523 | → unbound-in x (·λ_[_]_ y τ d) 524 | UBHole : ∀{x u σ} → unbound-in-σ x σ 525 | → unbound-in x (⦇-⦈⟨ u , σ ⟩) 526 | UBNEHole : ∀{x u σ d } 527 | → unbound-in-σ x σ 528 | → unbound-in x d 529 | → unbound-in x (⦇⌜ d ⌟⦈⟨ u , σ ⟩) 530 | UBAp : ∀{ x d1 d2 } → 531 | unbound-in x d1 → 532 | unbound-in x d2 → 533 | unbound-in x (d1 ∘ d2) 534 | UBCast : ∀{x d τ1 τ2} → unbound-in x d → unbound-in x (d ⟨ τ1 ⇒ τ2 ⟩) 535 | UBFailedCast : ∀{x d τ1 τ2} → unbound-in x d → unbound-in x (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) 536 | 537 | 538 | mutual 539 | data binders-disjoint-σ : env → ihexp → Set where 540 | BDσId : ∀{Γ d} → binders-disjoint-σ (Id Γ) d 541 | BDσSubst : ∀{d1 d2 y σ} → binders-disjoint d1 d2 542 | → binders-disjoint-σ σ d2 543 | → binders-disjoint-σ (Subst d1 y σ) d2 544 | 545 | -- two terms that do not share any binders 546 | data binders-disjoint : (d1 : ihexp) → (d2 : ihexp) → Set where 547 | BDConst : ∀{d} → binders-disjoint c d 548 | BDVar : ∀{x d} → binders-disjoint (X x) d 549 | BDLam : ∀{x τ d1 d2} → binders-disjoint d1 d2 550 | → unbound-in x d2 551 | → binders-disjoint (·λ_[_]_ x τ d1) d2 552 | BDHole : ∀{u σ d2} → binders-disjoint-σ σ d2 553 | → binders-disjoint (⦇-⦈⟨ u , σ ⟩) d2 554 | BDNEHole : ∀{u σ d1 d2} → binders-disjoint-σ σ d2 555 | → binders-disjoint d1 d2 556 | → binders-disjoint (⦇⌜ d1 ⌟⦈⟨ u , σ ⟩) d2 557 | BDAp : ∀{d1 d2 d3} → binders-disjoint d1 d3 558 | → binders-disjoint d2 d3 559 | → binders-disjoint (d1 ∘ d2) d3 560 | BDCast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint (d1 ⟨ τ1 ⇒ τ2 ⟩) d2 561 | BDFailedCast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint (d1 ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) d2 562 | 563 | mutual 564 | -- each term has to be binders unique, and they have to be pairwise 565 | -- disjoint with the collection of bound vars 566 | data binders-unique-σ : env → Set where 567 | BUσId : ∀{Γ} → binders-unique-σ (Id Γ) 568 | BUσSubst : ∀{d y σ} → binders-unique d 569 | → binders-unique-σ σ 570 | → binders-disjoint-σ σ d 571 | → binders-unique-σ (Subst d y σ) 572 | 573 | -- all the variable names in the term are unique 574 | data binders-unique : ihexp → Set where 575 | BUHole : binders-unique c 576 | BUVar : ∀{x} → binders-unique (X x) 577 | BULam : {x : Nat} {τ : htyp} {d : ihexp} → binders-unique d 578 | → unbound-in x d 579 | → binders-unique (·λ_[_]_ x τ d) 580 | BUEHole : ∀{u σ} → binders-unique-σ σ 581 | → binders-unique (⦇-⦈⟨ u , σ ⟩) 582 | BUNEHole : ∀{u σ d} → binders-unique d 583 | → binders-unique-σ σ 584 | → binders-unique (⦇⌜ d ⌟⦈⟨ u , σ ⟩) 585 | BUAp : ∀{d1 d2} → binders-unique d1 586 | → binders-unique d2 587 | → binders-disjoint d1 d2 588 | → binders-unique (d1 ∘ d2) 589 | BUCast : ∀{d τ1 τ2} → binders-unique d 590 | → binders-unique (d ⟨ τ1 ⇒ τ2 ⟩) 591 | BUFailedCast : ∀{d τ1 τ2} → binders-unique d 592 | → binders-unique (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) 593 | -------------------------------------------------------------------------------- /disjointness.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import lemmas-disjointness 6 | open import dom-eq 7 | 8 | module disjointness where 9 | -- if a hole name is new in a term, then the resultant context is 10 | -- disjoint from any singleton context with that hole name 11 | mutual 12 | elab-new-disjoint-synth : ∀ { e u τ d Δ Γ Γ' τ'} → 13 | hole-name-new e u → 14 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 15 | Δ ## (■ (u , Γ' , τ')) 16 | elab-new-disjoint-synth HNConst ESConst = empty-disj (■ (_ , _ , _)) 17 | elab-new-disjoint-synth (HNAsc hn) (ESAsc x) = elab-new-disjoint-ana hn x 18 | elab-new-disjoint-synth HNVar (ESVar x₁) = empty-disj (■ (_ , _ , _)) 19 | elab-new-disjoint-synth (HNLam1 hn) () 20 | elab-new-disjoint-synth (HNLam2 hn) (ESLam x₁ exp) = elab-new-disjoint-synth hn exp 21 | elab-new-disjoint-synth (HNHole x) ESEHole = disjoint-singles x 22 | elab-new-disjoint-synth (HNNEHole x hn) (ESNEHole x₁ exp) = disjoint-parts (elab-new-disjoint-synth hn exp) (disjoint-singles x) 23 | elab-new-disjoint-synth (HNAp hn hn₁) (ESAp x x₁ x₂ x₃ x₄ x₅) = 24 | disjoint-parts (elab-new-disjoint-ana hn x₄) 25 | (elab-new-disjoint-ana hn₁ x₅) 26 | 27 | elab-new-disjoint-ana : ∀ { e u τ d Δ Γ Γ' τ' τ2} → 28 | hole-name-new e u → 29 | Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ → 30 | Δ ## (■ (u , Γ' , τ')) 31 | elab-new-disjoint-ana hn (EASubsume x x₁ x₂ x₃) = elab-new-disjoint-synth hn x₂ 32 | elab-new-disjoint-ana (HNLam1 hn) (EALam x₁ x₂ ex) = elab-new-disjoint-ana hn ex 33 | elab-new-disjoint-ana (HNHole x) EAEHole = disjoint-singles x 34 | elab-new-disjoint-ana (HNNEHole x hn) (EANEHole x₁ x₂) = disjoint-parts (elab-new-disjoint-synth hn x₂) (disjoint-singles x) 35 | 36 | -- dual of the above: if elaborating a term produces a context that's 37 | -- disjoint with a singleton context, it must be that the index is a new 38 | -- hole name in the original term 39 | mutual 40 | elab-disjoint-new-synth : ∀{ e τ d Δ u Γ Γ' τ'} → 41 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 42 | Δ ## (■ (u , Γ' , τ')) → 43 | hole-name-new e u 44 | elab-disjoint-new-synth ESConst disj = HNConst 45 | elab-disjoint-new-synth (ESVar x₁) disj = HNVar 46 | elab-disjoint-new-synth (ESLam x₁ ex) disj = HNLam2 (elab-disjoint-new-synth ex disj) 47 | elab-disjoint-new-synth (ESAp {Δ1 = Δ1} x x₁ x₂ x₃ x₄ x₅) disj 48 | with elab-disjoint-new-ana x₄ (disjoint-union1 disj) | elab-disjoint-new-ana x₅ (disjoint-union2 {Γ1 = Δ1} disj) 49 | ... | ih1 | ih2 = HNAp ih1 ih2 50 | elab-disjoint-new-synth {Γ = Γ} ESEHole disj = HNHole (singles-notequal disj) 51 | elab-disjoint-new-synth (ESNEHole {Δ = Δ} x ex) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj)) 52 | (elab-disjoint-new-synth ex (disjoint-union1 disj)) 53 | elab-disjoint-new-synth (ESAsc x) disj = HNAsc (elab-disjoint-new-ana x disj) 54 | 55 | elab-disjoint-new-ana : ∀{ e τ d Δ u Γ Γ' τ2 τ'} → 56 | Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ → 57 | Δ ## (■ (u , Γ' , τ')) → 58 | hole-name-new e u 59 | elab-disjoint-new-ana (EALam x₁ x₂ ex) disj = HNLam1 (elab-disjoint-new-ana ex disj) 60 | elab-disjoint-new-ana (EASubsume x x₁ x₂ x₃) disj = elab-disjoint-new-synth x₂ disj 61 | elab-disjoint-new-ana EAEHole disj = HNHole (singles-notequal disj) 62 | elab-disjoint-new-ana (EANEHole {Δ = Δ} x x₁) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj)) 63 | (elab-disjoint-new-synth x₁ (disjoint-union1 disj)) 64 | 65 | -- collect up the hole names of a term as the indices of a trivial contex 66 | data holes : (e : hexp) (H : ⊤ ctx) → Set where 67 | HConst : holes c ∅ 68 | HAsc : ∀{e τ H} → holes e H → holes (e ·: τ) H 69 | HVar : ∀{x} → holes (X x) ∅ 70 | HLam1 : ∀{x e H} → holes e H → holes (·λ x e) H 71 | HLam2 : ∀{x e τ H} → holes e H → holes (·λ x [ τ ] e) H 72 | HEHole : ∀{u} → holes (⦇-⦈[ u ]) (■ (u , <>)) 73 | HNEHole : ∀{e u H} → holes e H → holes (⦇⌜ e ⌟⦈[ u ]) (H ,, (u , <>)) 74 | HAp : ∀{e1 e2 H1 H2} → holes e1 H1 → holes e2 H2 → holes (e1 ∘ e2) (H1 ∪ H2) 75 | 76 | -- the above judgement has mode (∀,∃). this doesn't prove uniqueness; any 77 | -- contex that extends the one computed here will be indistinguishable 78 | -- but we'll treat this one as canonical 79 | find-holes : (e : hexp) → Σ[ H ∈ ⊤ ctx ](holes e H) 80 | find-holes c = ∅ , HConst 81 | find-holes (e ·: x) with find-holes e 82 | ... | (h , d)= h , (HAsc d) 83 | find-holes (X x) = ∅ , HVar 84 | find-holes (·λ x e) with find-holes e 85 | ... | (h , d) = h , HLam1 d 86 | find-holes (·λ x [ x₁ ] e) with find-holes e 87 | ... | (h , d) = h , HLam2 d 88 | find-holes ⦇-⦈[ x ] = (■ (x , <>)) , HEHole 89 | find-holes ⦇⌜ e ⌟⦈[ x ] with find-holes e 90 | ... | (h , d) = h ,, (x , <>) , HNEHole d 91 | find-holes (e1 ∘ e2) with find-holes e1 | find-holes e2 92 | ... | (h1 , d1) | (h2 , d2) = (h1 ∪ h2 ) , (HAp d1 d2) 93 | 94 | -- if a hole name is new then it's apart from the collection of hole 95 | -- names 96 | lem-apart-new : ∀{e H u} → holes e H → hole-name-new e u → u # H 97 | lem-apart-new HConst HNConst = refl 98 | lem-apart-new (HAsc h) (HNAsc hn) = lem-apart-new h hn 99 | lem-apart-new HVar HNVar = refl 100 | lem-apart-new (HLam1 h) (HNLam1 hn) = lem-apart-new h hn 101 | lem-apart-new (HLam2 h) (HNLam2 hn) = lem-apart-new h hn 102 | lem-apart-new HEHole (HNHole x) = apart-singleton (flip x) 103 | 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)) 104 | 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₁) 105 | 106 | -- if the holes of two expressions are disjoint, so are their collections 107 | -- of hole names 108 | holes-disjoint-disjoint : ∀{ e1 e2 H1 H2} → 109 | holes e1 H1 → 110 | holes e2 H2 → 111 | holes-disjoint e1 e2 → 112 | H1 ## H2 113 | holes-disjoint-disjoint HConst he2 HDConst = empty-disj _ 114 | holes-disjoint-disjoint (HAsc he1) he2 (HDAsc hd) = holes-disjoint-disjoint he1 he2 hd 115 | holes-disjoint-disjoint HVar he2 HDVar = empty-disj _ 116 | holes-disjoint-disjoint (HLam1 he1) he2 (HDLam1 hd) = holes-disjoint-disjoint he1 he2 hd 117 | holes-disjoint-disjoint (HLam2 he1) he2 (HDLam2 hd) = holes-disjoint-disjoint he1 he2 hd 118 | holes-disjoint-disjoint HEHole he2 (HDHole x) = lem-apart-sing-disj (lem-apart-new he2 x) 119 | 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)) 120 | holes-disjoint-disjoint (HAp he1 he2) he3 (HDAp hd hd₁) = disjoint-parts (holes-disjoint-disjoint he1 he3 hd) (holes-disjoint-disjoint he2 he3 hd₁) 121 | 122 | -- the holes of an expression have the same domain as the context 123 | -- produced during expansion; that is, we don't add anything we don't 124 | -- find in the term during expansion. 125 | mutual 126 | holes-delta-ana : ∀{Γ H e τ d τ' Δ} → 127 | holes e H → 128 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 129 | dom-eq Δ H 130 | holes-delta-ana (HLam1 h) (EALam x₁ x₂ exp) = holes-delta-ana h exp 131 | holes-delta-ana h (EASubsume x x₁ x₂ x₃) = holes-delta-synth h x₂ 132 | holes-delta-ana (HEHole {u = u}) EAEHole = dom-single u 133 | holes-delta-ana (HNEHole {u = u} h) (EANEHole x x₁) = 134 | dom-union (##-comm (lem-apart-sing-disj (lem-apart-new h (elab-disjoint-new-synth x₁ x)))) 135 | (holes-delta-synth h x₁) 136 | (dom-single u) 137 | 138 | holes-delta-synth : ∀{Γ H e τ d Δ} → 139 | holes e H → 140 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 141 | dom-eq Δ H 142 | holes-delta-synth HConst ESConst = dom-∅ 143 | holes-delta-synth (HAsc h) (ESAsc x) = holes-delta-ana h x 144 | holes-delta-synth HVar (ESVar x₁) = dom-∅ 145 | holes-delta-synth (HLam2 h) (ESLam x₁ exp) = holes-delta-synth h exp 146 | holes-delta-synth (HEHole {u = u}) ESEHole = dom-single u 147 | 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))))) 148 | (holes-delta-synth h exp) 149 | (dom-single u) 150 | 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₅) 151 | 152 | -- this is the main result of this file: 153 | -- 154 | -- if you elaborate two hole-disjoint expressions analytically, the Δs 155 | -- produced are disjoint. 156 | -- 157 | -- note that this is likely true for synthetic expansions in much the 158 | -- same way, but we only prove half of the usual pair here because that's 159 | -- all we need to establish expansion generality and elaborability. the 160 | -- proof technique here is explcitly *not* structurally inductive on the 161 | -- expansion judgement, because that approach relies on weakening of 162 | -- expansion, which is false because of the substitution contexts. giving 163 | -- expansion weakning would take away unicity, so we avoid the whole 164 | -- question. 165 | elab-ana-disjoint : ∀{ e1 e2 τ1 τ2 e1' e2' τ1' τ2' Γ Δ1 Δ2 } → 166 | holes-disjoint e1 e2 → 167 | Γ ⊢ e1 ⇐ τ1 ~> e1' :: τ1' ⊣ Δ1 → 168 | Γ ⊢ e2 ⇐ τ2 ~> e2' :: τ2' ⊣ Δ2 → 169 | Δ1 ## Δ2 170 | elab-ana-disjoint {e1} {e2} hd ana1 ana2 171 | with find-holes e1 | find-holes e2 172 | ... | (_ , he1) | (_ , he2) = dom-eq-disj (holes-disjoint-disjoint he1 he2 hd) 173 | (holes-delta-ana he1 ana1) 174 | (holes-delta-ana he2 ana2) 175 | -------------------------------------------------------------------------------- /dom-eq.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import lemmas-disjointness 6 | 7 | 8 | module dom-eq where 9 | -- main definition: two contexts are domain-equal when they produce (Some 10 | -- x) on the same indices. note that the context need not map indices to 11 | -- even the same type of contents; this is just a property about the 12 | -- domains. the proofs that follow establish that this property is 13 | -- respected in the appropriate ways by the context maniupulation 14 | -- operators we use in the other judgements. 15 | dom-eq : {A B : Set} → A ctx → B ctx → Set 16 | dom-eq {A} {B} C1 C2 = ((n : Nat) → Σ[ x ∈ A ]( C1 n == Some x) → (Σ[ y ∈ B ](C2 n == Some y)))× 17 | ((n : Nat) → Σ[ y ∈ B ]( C2 n == Some y) → (Σ[ x ∈ A ](C1 n == Some x))) 18 | 19 | -- the empty context has the same domain as itself 20 | dom-∅ : {A B : Set} → dom-eq (λ _ → None {A}) (λ _ → None {B}) 21 | dom-∅ {A} {B} = (λ n x → abort (somenotnone (! (π2 x)))) , (λ n x → abort (somenotnone (! (π2 x)))) 22 | 23 | -- the singleton contexts formed with any contents but the same index has 24 | -- the same domain 25 | dom-single : {A B : Set} (x : Nat) {a : A} {b : B} → dom-eq (■ (x , a)) (■ (x , b)) 26 | dom-single {A} {B} x {α} {β} = (λ n x₁ → β , (ap1 (λ qq → (■ (qq , β)) n) (! (lem-dom-eq x₁)) · x∈■ _ _)) , 27 | (λ n x₁ → α , (ap1 (λ qq → (■ (qq , α)) n) (! (lem-dom-eq x₁)) · x∈■ _ _)) 28 | 29 | -- if two disjoint contexts each share a domain with two others, those 30 | -- are also disjoint. 31 | dom-eq-disj : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} → 32 | H1 ## H2 → 33 | dom-eq Δ1 H1 → 34 | dom-eq Δ2 H2 → 35 | Δ1 ## Δ2 36 | dom-eq-disj {A} {B} {Δ1} {Δ2} {H1} {H2} (d1 , d2) (de1 , de2) (de3 , de4) = guts1 , guts2 37 | where 38 | guts1 : (n : Nat) → dom Δ1 n → n # Δ2 39 | guts1 n dom1 with ctxindirect H2 n 40 | guts1 n dom1 | Inl x = abort (somenotnone (! (π2 x) · d1 n (de1 n dom1))) 41 | guts1 n dom1 | Inr x with ctxindirect Δ2 n 42 | guts1 n dom1 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de3 n x)) · x₁)) 43 | guts1 n dom1 | Inr x₁ | Inr x = x 44 | 45 | guts2 : (n : Nat) → dom Δ2 n → n # Δ1 46 | guts2 n dom2 with ctxindirect H1 n 47 | guts2 n dom2 | Inl x = abort (somenotnone (! (π2 x) · d2 n (de3 n dom2))) 48 | guts2 n dom2 | Inr x with ctxindirect Δ1 n 49 | guts2 n dom2 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de1 n x)) · x₁)) 50 | guts2 n dom2 | Inr x₁ | Inr x = x 51 | 52 | -- if two sets share a domain with disjoint sets, then their union shares 53 | -- a domain with the union 54 | dom-union : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} → 55 | H1 ## H2 → 56 | dom-eq Δ1 H1 → 57 | dom-eq Δ2 H2 → 58 | dom-eq (Δ1 ∪ Δ2) (H1 ∪ H2) 59 | dom-union {A} {B} {Δ1} {Δ2} {H1} {H2} disj (p1 , p2) (p3 , p4) = guts1 , guts2 60 | where 61 | guts1 : (n : Nat) → 62 | Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x) → 63 | Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y) 64 | guts1 n (x , eq) with ctxindirect Δ1 n 65 | guts1 n (x₁ , eq) | Inl x with p1 n x 66 | ... | q1 , q2 = q1 , x∈∪l H1 H2 n q1 q2 67 | guts1 n (x₁ , eq) | Inr x with p3 n (_ , lem-dom-union-apt1 {Δ1 = Δ1} {Δ2 = Δ2} x eq) 68 | ... | q1 , q2 = q1 , x∈∪r H1 H2 n q1 q2 (##-comm disj) 69 | 70 | guts2 : (n : Nat) → 71 | Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y) → 72 | Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x) 73 | guts2 n (x , eq) with ctxindirect H1 n 74 | guts2 n (x₁ , eq) | Inl x with p2 n x 75 | ... | q1 , q2 = q1 , x∈∪l Δ1 Δ2 n q1 q2 76 | 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)) 77 | ... | q1 , q2 = q1 , x∈∪r Δ1 Δ2 n q1 q2 (##-comm (dom-eq-disj disj (p1 , p2) (p3 , p4))) 78 | -------------------------------------------------------------------------------- /elaborability.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import htype-decidable 6 | open import lemmas-matching 7 | open import disjointness 8 | 9 | module elaborability where 10 | mutual 11 | elaborability-synth : {Γ : tctx} {e : hexp} {τ : htyp} → 12 | Γ ⊢ e => τ → 13 | Σ[ d ∈ ihexp ] Σ[ Δ ∈ hctx ] 14 | (Γ ⊢ e ⇒ τ ~> d ⊣ Δ) 15 | elaborability-synth SConst = _ , _ , ESConst 16 | elaborability-synth (SAsc {τ = τ} wt) 17 | with elaborability-ana wt 18 | ... | _ , _ , τ' , D = _ , _ , ESAsc D 19 | elaborability-synth (SVar x) = _ , _ , ESVar x 20 | elaborability-synth (SAp dis wt1 m wt2) 21 | with elaborability-ana (ASubsume wt1 (match-consist m)) | elaborability-ana wt2 22 | ... | _ , _ , _ , D1 | _ , _ , _ , D2 = _ , _ , ESAp dis (elab-ana-disjoint dis D1 D2) wt1 m D1 D2 23 | elaborability-synth SEHole = _ , _ , ESEHole 24 | elaborability-synth (SNEHole new wt) 25 | with elaborability-synth wt 26 | ... | d' , Δ' , wt' = _ , _ , ESNEHole (elab-new-disjoint-synth new wt') wt' 27 | elaborability-synth (SLam x₁ wt) 28 | with elaborability-synth wt 29 | ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt' 30 | 31 | elaborability-ana : {Γ : tctx} {e : hexp} {τ : htyp} → 32 | Γ ⊢ e <= τ → 33 | Σ[ d ∈ ihexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ] 34 | (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ) 35 | elaborability-ana {e = e} (ASubsume D x₁) 36 | with elaborability-synth D 37 | -- these cases just pass through, but we need to pattern match so we can prove things aren't holes 38 | elaborability-ana {e = c} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ 39 | elaborability-ana {e = e ·: x} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ 40 | elaborability-ana {e = X x} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ 41 | elaborability-ana {e = ·λ x e} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ 42 | elaborability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂ 43 | elaborability-ana {e = e1 ∘ e2} (ASubsume D x₁) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁ 44 | -- the two holes are special-cased 45 | elaborability-ana {e = ⦇-⦈[ x ]} (ASubsume _ _ ) | _ , _ , _ = _ , _ , _ , EAEHole 46 | elaborability-ana {Γ} {⦇⌜ e ⌟⦈[ x ]} (ASubsume (SNEHole new wt) x₂) | _ , _ , ESNEHole x₁ D' with elaborability-synth wt 47 | ... | w , y , z = _ , _ , _ , EANEHole (elab-new-disjoint-synth new z) z 48 | -- the lambda cases 49 | elaborability-ana (ALam x₁ m wt) 50 | with elaborability-ana wt 51 | ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ m D' 52 | -------------------------------------------------------------------------------- /elaboration-generality.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import disjointness 5 | 6 | module elaboration-generality where 7 | mutual 8 | elaboration-generality-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} → 9 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 10 | Γ ⊢ e => τ 11 | elaboration-generality-synth ESConst = SConst 12 | elaboration-generality-synth (ESVar x₁) = SVar x₁ 13 | elaboration-generality-synth (ESLam apt ex) with elaboration-generality-synth ex 14 | ... | ih = SLam apt ih 15 | elaboration-generality-synth (ESAp dis _ a x₁ x₂ x₃) = SAp dis a x₁ (elaboration-generality-ana x₃) 16 | elaboration-generality-synth ESEHole = SEHole 17 | elaboration-generality-synth (ESNEHole dis ex) = SNEHole (elab-disjoint-new-synth ex dis) (elaboration-generality-synth ex) 18 | elaboration-generality-synth (ESAsc x) = SAsc (elaboration-generality-ana x) 19 | 20 | elaboration-generality-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} → 21 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 22 | Γ ⊢ e <= τ 23 | elaboration-generality-ana (EALam apt m ex) = ALam apt m (elaboration-generality-ana ex) 24 | elaboration-generality-ana (EASubsume x x₁ x₂ x₃) = ASubsume (elaboration-generality-synth x₂) x₃ 25 | elaboration-generality-ana EAEHole = ASubsume SEHole TCHole1 26 | elaboration-generality-ana (EANEHole dis x) = ASubsume (SNEHole (elab-disjoint-new-synth x dis) (elaboration-generality-synth x)) TCHole1 27 | -------------------------------------------------------------------------------- /elaboration-unicity.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import synth-unicity 6 | open import lemmas-matching 7 | 8 | module elaboration-unicity where 9 | mutual 10 | elaboration-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : ihexp} {Δ1 Δ2 : hctx} → 11 | Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 → 12 | Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 → 13 | τ1 == τ2 × d1 == d2 × Δ1 == Δ2 14 | elaboration-unicity-synth ESConst ESConst = refl , refl , refl 15 | elaboration-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl 16 | elaboration-unicity-synth (ESLam apt1 d1) (ESLam apt2 d2) 17 | with elaboration-unicity-synth d1 d2 18 | ... | ih1 , ih2 , ih3 = ap1 _ ih1 , ap1 _ ih2 , ih3 19 | elaboration-unicity-synth (ESAp _ _ x x₁ x₂ x₃) (ESAp _ _ x₄ x₅ x₆ x₇) 20 | with synthunicity x x₄ 21 | ... | refl with match-unicity x₁ x₅ 22 | ... | refl with elaboration-unicity-ana x₂ x₆ 23 | ... | refl , refl , refl with elaboration-unicity-ana x₃ x₇ 24 | ... | refl , refl , refl = refl , refl , refl 25 | elaboration-unicity-synth ESEHole ESEHole = refl , refl , refl 26 | elaboration-unicity-synth (ESNEHole _ d1) (ESNEHole _ d2) 27 | with elaboration-unicity-synth d1 d2 28 | ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3 29 | elaboration-unicity-synth (ESAsc x) (ESAsc x₁) 30 | with elaboration-unicity-ana x x₁ 31 | ... | refl , refl , refl = refl , refl , refl 32 | 33 | elaboration-unicity-ana : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {d1 d2 : ihexp} {Δ1 Δ2 : hctx} → 34 | Γ ⊢ e ⇐ τ ~> d1 :: τ1 ⊣ Δ1 → 35 | Γ ⊢ e ⇐ τ ~> d2 :: τ2 ⊣ Δ2 → 36 | d1 == d2 × τ1 == τ2 × Δ1 == Δ2 37 | elaboration-unicity-ana (EALam x₁ m D1) (EALam x₂ m2 D2) 38 | with match-unicity m m2 39 | ... | refl with elaboration-unicity-ana D1 D2 40 | ... | refl , refl , refl = refl , refl , refl 41 | elaboration-unicity-ana (EALam x₁ m D1) (EASubsume x₂ x₃ () x₅) 42 | elaboration-unicity-ana (EASubsume x₁ x₂ () x₄) (EALam x₅ m D2) 43 | elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇) 44 | with elaboration-unicity-synth x₂ x₆ 45 | ... | refl , refl , refl = refl , refl , refl 46 | elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = abort (x _ refl) 47 | elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole _ x₄) = abort (x₁ _ _ refl) 48 | elaboration-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = abort (x _ refl) 49 | elaboration-unicity-ana EAEHole EAEHole = refl , refl , refl 50 | elaboration-unicity-ana (EANEHole _ x) (EASubsume x₁ x₂ x₃ x₄) = abort (x₂ _ _ refl) 51 | elaboration-unicity-ana (EANEHole _ x) (EANEHole _ x₁) 52 | with elaboration-unicity-synth x x₁ 53 | ... | refl , refl , refl = refl , refl , refl 54 | -------------------------------------------------------------------------------- /exchange.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import lemmas-disjointness 6 | 7 | module exchange where 8 | -- exchanging just two disequal elements produces the same context 9 | swap-little : {A : Set} {x y : Nat} {τ1 τ2 : A} → (x ≠ y) → 10 | ((■ (x , τ1)) ,, (y , τ2)) == ((■ (y , τ2)) ,, (x , τ1)) 11 | swap-little {A} {x} {y} {τ1} {τ2} neq = ∪comm (■ (x , τ1)) 12 | (■ (y , τ2)) 13 | (disjoint-singles neq) 14 | 15 | -- really the core of all the exchange arguments: contexts with two 16 | -- disequal elements exchanged are the same. we reassociate the unions, 17 | -- swap as above, and then associate them back. 18 | -- 19 | -- note that this is generic in the contents of the context. the proofs 20 | -- below show the exchange properties that we actually need in the 21 | -- various other proofs; the remaning exchange properties for both Δ and 22 | -- Γ positions for all the other hypothetical judgements are exactly in 23 | -- this pattern. 24 | swap : {A : Set} {x y : Nat} {τ1 τ2 : A} (Γ : A ctx) (x≠y : x == y → ⊥) → 25 | ((Γ ,, (x , τ1)) ,, (y , τ2)) == ((Γ ,, (y , τ2)) ,, (x , τ1)) 26 | swap {A} {x} {y} {τ1} {τ2} Γ neq = 27 | (∪assoc Γ (■ (x , τ1)) (■ (y , τ2)) (disjoint-singles neq) ) · 28 | (ap1 (λ qq → Γ ∪ qq) (swap-little neq) · 29 | ! (∪assoc Γ (■ (y , τ2)) (■ (x , τ1)) (disjoint-singles (flip neq)))) 30 | 31 | -- the above exchange principle used via transport in the judgements we needed 32 | exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} → 33 | x ≠ y → 34 | Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' → 35 | Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ' 36 | exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y = 37 | tr (λ qq → Δ , qq ⊢ σ :s: Γ') (swap Γ x≠y) 38 | 39 | exchange-synth : ∀{Γ x y τ τ1 τ2 e} 40 | → x ≠ y 41 | → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e => τ 42 | → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e => τ 43 | exchange-synth {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq = 44 | tr (λ qq → qq ⊢ e => τ) (swap Γ neq) 45 | 46 | exchange-ana : ∀{Γ x y τ τ1 τ2 e} 47 | → x ≠ y 48 | → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e <= τ 49 | → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e <= τ 50 | exchange-ana {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq = 51 | tr (λ qq → qq ⊢ e <= τ) (swap Γ neq) 52 | 53 | exchange-elab-synth : ∀{Γ x y τ1 τ2 e τ d Δ} → 54 | x ≠ y → 55 | (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e ⇒ τ ~> d ⊣ Δ → 56 | (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e ⇒ τ ~> d ⊣ Δ 57 | exchange-elab-synth {Γ = Γ} {e = e} {τ = τ} {d = d } {Δ = Δ} neq = 58 | tr (λ qq → qq ⊢ e ⇒ τ ~> d ⊣ Δ) (swap Γ neq) 59 | 60 | exchange-elab-ana : ∀ {Γ x y τ1 τ2 τ τ' d e Δ} → 61 | x ≠ y → 62 | (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 63 | (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ 64 | exchange-elab-ana {Γ = Γ} {τ = τ} {τ' = τ'} {d = d} {e = e} {Δ = Δ} neq = 65 | tr (λ qq → qq ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ) (swap Γ neq) 66 | 67 | exchange-ta-Γ : ∀{Γ x y τ1 τ2 d τ Δ } → 68 | x ≠ y → 69 | Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ d :: τ → 70 | Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ d :: τ 71 | exchange-ta-Γ {Γ = Γ} {d = d} {τ = τ} {Δ = Δ} neq = 72 | tr (λ qq → Δ , qq ⊢ d :: τ) (swap Γ neq) 73 | -------------------------------------------------------------------------------- /finality.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | 4 | open import progress-checks 5 | 6 | module finality where 7 | finality : Σ[ d ∈ ihexp ] (d final × (Σ[ d' ∈ ihexp ] (d ↦ d'))) → ⊥ 8 | finality (π1 , π2 , π3 , π4) = final-not-step π2 (π3 , π4) 9 | 10 | -- a slight restatement of the above, generalizing it to the 11 | -- multistep judgement 12 | finality* : ∀{d d'} → d final → d ↦* d' → d == d' 13 | finality* fin MSRefl = refl 14 | finality* fin (MSStep x ms) = abort (final-not-step fin (_ , x)) 15 | -------------------------------------------------------------------------------- /focus-formation.agda: -------------------------------------------------------------------------------- 1 | open import core 2 | 3 | module focus-formation where 4 | -- every ε is an evaluation context -- trivially, here, since we don't 5 | -- include any of the premises in red brackets about finality 6 | focus-formation : ∀{d d' ε} → d == ε ⟦ d' ⟧ → ε evalctx 7 | focus-formation FHOuter = ECDot 8 | focus-formation (FHAp1 sub) = ECAp1 (focus-formation sub) 9 | focus-formation (FHAp2 sub) = ECAp2 (focus-formation sub) 10 | focus-formation (FHNEHole sub) = ECNEHole (focus-formation sub) 11 | focus-formation (FHCast sub) = ECCast (focus-formation sub) 12 | focus-formation (FHFailedCast x) = ECFailedCast (focus-formation x) 13 | -------------------------------------------------------------------------------- /ground-decidable.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | 4 | module ground-decidable where 5 | ground-decidable : (τ : htyp) → (τ ground) + ((τ ground) → ⊥) 6 | ground-decidable b = Inl GBase 7 | ground-decidable ⦇-⦈ = Inr (λ ()) 8 | ground-decidable (b ==> b) = Inr (λ ()) 9 | ground-decidable (b ==> ⦇-⦈) = Inr (λ ()) 10 | ground-decidable (b ==> τ' ==> τ'') = Inr (λ ()) 11 | ground-decidable (⦇-⦈ ==> b) = Inr (λ ()) 12 | ground-decidable (⦇-⦈ ==> ⦇-⦈) = Inl GHole 13 | ground-decidable (⦇-⦈ ==> τ' ==> τ'') = Inr (λ ()) 14 | ground-decidable ((τ ==> τ₁) ==> b) = Inr (λ ()) 15 | ground-decidable ((τ ==> τ₁) ==> ⦇-⦈) = Inr (λ ()) 16 | ground-decidable ((τ ==> τ₁) ==> τ' ==> τ'') = Inr (λ ()) 17 | 18 | ground-arr-lem : (τ : htyp) → ((τ ground) → ⊥) → (τ ≠ ⦇-⦈) → Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] ((τ == (τ1 ==> τ2)) × ((τ1 ==> τ2) ≠ (⦇-⦈ ==> ⦇-⦈))) 19 | ground-arr-lem b ng nh = abort (ng GBase) 20 | ground-arr-lem ⦇-⦈ ng nh = abort (nh refl) 21 | ground-arr-lem (τ1 ==> τ2) ng nh = τ1 , τ2 , refl , (λ x → ng (lem' x)) 22 | where 23 | lem' : ∀{τ1 τ2} → τ1 ==> τ2 == ⦇-⦈ ==> ⦇-⦈ → (τ1 ==> τ2) ground 24 | lem' refl = GHole 25 | -------------------------------------------------------------------------------- /grounding.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | 4 | module grounding where 5 | grounding : ∀{ τ1 τ2} → 6 | τ1 ▸gnd τ2 → 7 | ((τ2 ground) × (τ1 ~ τ2) × (τ1 ≠ τ2)) 8 | grounding (MGArr x) = GHole , TCArr TCHole1 TCHole1 , x 9 | -------------------------------------------------------------------------------- /holes-disjoint-checks.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import disjointness 6 | 7 | 8 | -- this module contains lemmas and properties about the holes-disjoint 9 | -- judgement that double check that it acts as we would expect 10 | 11 | module holes-disjoint-checks where 12 | -- these lemmas are all structurally recursive and quite 13 | -- mechanical. morally, they establish the properties about reduction 14 | -- that would be obvious / baked into Agda if holes-disjoint was defined 15 | -- as a function rather than a judgement (datatype), or if we had defined 16 | -- all the O(n^2) cases rather than relying on a little indirection to 17 | -- only have O(n) cases. that work has to go somewhwere, and we prefer 18 | -- that it goes here. 19 | ds-lem-asc : ∀{e1 e2 τ} → holes-disjoint e2 e1 → holes-disjoint e2 (e1 ·: τ) 20 | ds-lem-asc HDConst = HDConst 21 | ds-lem-asc (HDAsc hd) = HDAsc (ds-lem-asc hd) 22 | ds-lem-asc HDVar = HDVar 23 | ds-lem-asc (HDLam1 hd) = HDLam1 (ds-lem-asc hd) 24 | ds-lem-asc (HDLam2 hd) = HDLam2 (ds-lem-asc hd) 25 | ds-lem-asc (HDHole x) = HDHole (HNAsc x) 26 | ds-lem-asc (HDNEHole x hd) = HDNEHole (HNAsc x) (ds-lem-asc hd) 27 | ds-lem-asc (HDAp hd hd₁) = HDAp (ds-lem-asc hd) (ds-lem-asc hd₁) 28 | 29 | ds-lem-lam1 : ∀{e1 e2 x} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x e1) 30 | ds-lem-lam1 HDConst = HDConst 31 | ds-lem-lam1 (HDAsc hd) = HDAsc (ds-lem-lam1 hd) 32 | ds-lem-lam1 HDVar = HDVar 33 | ds-lem-lam1 (HDLam1 hd) = HDLam1 (ds-lem-lam1 hd) 34 | ds-lem-lam1 (HDLam2 hd) = HDLam2 (ds-lem-lam1 hd) 35 | ds-lem-lam1 (HDHole x₁) = HDHole (HNLam1 x₁) 36 | ds-lem-lam1 (HDNEHole x₁ hd) = HDNEHole (HNLam1 x₁) (ds-lem-lam1 hd) 37 | ds-lem-lam1 (HDAp hd hd₁) = HDAp (ds-lem-lam1 hd) (ds-lem-lam1 hd₁) 38 | 39 | ds-lem-lam2 : ∀{e1 e2 x τ} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x [ τ ] e1) 40 | ds-lem-lam2 HDConst = HDConst 41 | ds-lem-lam2 (HDAsc hd) = HDAsc (ds-lem-lam2 hd) 42 | ds-lem-lam2 HDVar = HDVar 43 | ds-lem-lam2 (HDLam1 hd) = HDLam1 (ds-lem-lam2 hd) 44 | ds-lem-lam2 (HDLam2 hd) = HDLam2 (ds-lem-lam2 hd) 45 | ds-lem-lam2 (HDHole x₁) = HDHole (HNLam2 x₁) 46 | ds-lem-lam2 (HDNEHole x₁ hd) = HDNEHole (HNLam2 x₁) (ds-lem-lam2 hd) 47 | ds-lem-lam2 (HDAp hd hd₁) = HDAp (ds-lem-lam2 hd) (ds-lem-lam2 hd₁) 48 | 49 | ds-lem-nehole : ∀{e e1 u} → holes-disjoint e e1 → hole-name-new e u → holes-disjoint e ⦇⌜ e1 ⌟⦈[ u ] 50 | ds-lem-nehole HDConst ν = HDConst 51 | ds-lem-nehole (HDAsc hd) (HNAsc ν) = HDAsc (ds-lem-nehole hd ν) 52 | ds-lem-nehole HDVar ν = HDVar 53 | ds-lem-nehole (HDLam1 hd) (HNLam1 ν) = HDLam1 (ds-lem-nehole hd ν) 54 | ds-lem-nehole (HDLam2 hd) (HNLam2 ν) = HDLam2 (ds-lem-nehole hd ν) 55 | ds-lem-nehole (HDHole x) (HNHole x₁) = HDHole (HNNEHole (flip x₁) x) 56 | ds-lem-nehole (HDNEHole x hd) (HNNEHole x₁ ν) = HDNEHole (HNNEHole (flip x₁) x) (ds-lem-nehole hd ν) 57 | ds-lem-nehole (HDAp hd hd₁) (HNAp ν ν₁) = HDAp (ds-lem-nehole hd ν) (ds-lem-nehole hd₁ ν₁) 58 | 59 | ds-lem-ap : ∀{e1 e2 e3} → holes-disjoint e3 e1 → holes-disjoint e3 e2 → holes-disjoint e3 (e1 ∘ e2) 60 | ds-lem-ap HDConst hd2 = HDConst 61 | ds-lem-ap (HDAsc hd1) (HDAsc hd2) = HDAsc (ds-lem-ap hd1 hd2) 62 | ds-lem-ap HDVar hd2 = HDVar 63 | ds-lem-ap (HDLam1 hd1) (HDLam1 hd2) = HDLam1 (ds-lem-ap hd1 hd2) 64 | ds-lem-ap (HDLam2 hd1) (HDLam2 hd2) = HDLam2 (ds-lem-ap hd1 hd2) 65 | ds-lem-ap (HDHole x) (HDHole x₁) = HDHole (HNAp x x₁) 66 | ds-lem-ap (HDNEHole x hd1) (HDNEHole x₁ hd2) = HDNEHole (HNAp x x₁) (ds-lem-ap hd1 hd2) 67 | ds-lem-ap (HDAp hd1 hd2) (HDAp hd3 hd4) = HDAp (ds-lem-ap hd1 hd3) (ds-lem-ap hd2 hd4) 68 | 69 | -- holes-disjoint is symmetric 70 | disjoint-sym : (e1 e2 : hexp) → holes-disjoint e1 e2 → holes-disjoint e2 e1 71 | disjoint-sym .c c HDConst = HDConst 72 | disjoint-sym .c (e2 ·: x) HDConst = HDAsc (disjoint-sym _ _ HDConst) 73 | disjoint-sym .c (X x) HDConst = HDVar 74 | disjoint-sym .c (·λ x e2) HDConst = HDLam1 (disjoint-sym c e2 HDConst) 75 | disjoint-sym .c (·λ x [ x₁ ] e2) HDConst = HDLam2 (disjoint-sym c e2 HDConst) 76 | disjoint-sym .c ⦇-⦈[ x ] HDConst = HDHole HNConst 77 | disjoint-sym .c ⦇⌜ e2 ⌟⦈[ x ] HDConst = HDNEHole HNConst (disjoint-sym c e2 HDConst) 78 | disjoint-sym .c (e2 ∘ e3) HDConst = HDAp (disjoint-sym c e2 HDConst) (disjoint-sym c e3 HDConst) 79 | 80 | disjoint-sym _ c (HDAsc hd) = HDConst 81 | disjoint-sym _ (e2 ·: x) (HDAsc hd) with disjoint-sym _ _ hd 82 | disjoint-sym _ (e2 ·: x) (HDAsc hd) | HDAsc ih = HDAsc (ds-lem-asc ih) 83 | disjoint-sym _ (X x) (HDAsc hd) = HDVar 84 | disjoint-sym _ (·λ x e2) (HDAsc hd) with disjoint-sym _ _ hd 85 | disjoint-sym _ (·λ x e2) (HDAsc hd) | HDLam1 ih = HDLam1 (ds-lem-asc ih) 86 | disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) with disjoint-sym _ _ hd 87 | disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) | HDLam2 ih = HDLam2 (ds-lem-asc ih) 88 | disjoint-sym _ ⦇-⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd 89 | disjoint-sym _ ⦇-⦈[ x ] (HDAsc hd) | HDHole x₁ = HDHole (HNAsc x₁) 90 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd 91 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDAsc hd) | HDNEHole x₁ ih = HDNEHole (HNAsc x₁) (ds-lem-asc ih) 92 | disjoint-sym _ (e2 ∘ e3) (HDAsc hd) with disjoint-sym _ _ hd 93 | disjoint-sym _ (e2 ∘ e3) (HDAsc hd) | HDAp ih ih₁ = HDAp (ds-lem-asc ih) (ds-lem-asc ih₁) 94 | 95 | disjoint-sym _ c HDVar = HDConst 96 | disjoint-sym _ (e2 ·: x₁) HDVar = HDAsc (disjoint-sym _ e2 HDVar) 97 | disjoint-sym _ (X x₁) HDVar = HDVar 98 | disjoint-sym _ (·λ x₁ e2) HDVar = HDLam1 (disjoint-sym _ e2 HDVar) 99 | disjoint-sym _ (·λ x₁ [ x₂ ] e2) HDVar = HDLam2 (disjoint-sym _ e2 HDVar) 100 | disjoint-sym _ ⦇-⦈[ x₁ ] HDVar = HDHole HNVar 101 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] HDVar = HDNEHole HNVar (disjoint-sym _ e2 HDVar) 102 | disjoint-sym _ (e2 ∘ e3) HDVar = HDAp (disjoint-sym _ e2 HDVar) (disjoint-sym _ e3 HDVar) 103 | 104 | disjoint-sym _ c (HDLam1 hd) = HDConst 105 | disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) with disjoint-sym _ _ hd 106 | disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) | HDAsc ih = HDAsc (ds-lem-lam1 ih) 107 | disjoint-sym _ (X x₁) (HDLam1 hd) = HDVar 108 | disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) with disjoint-sym _ _ hd 109 | disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) | HDLam1 ih = HDLam1 (ds-lem-lam1 ih) 110 | disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) with disjoint-sym _ _ hd 111 | disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) | HDLam2 ih = HDLam2 (ds-lem-lam1 ih) 112 | disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd 113 | disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam1 hd) | HDHole x = HDHole (HNLam1 x) 114 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd 115 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam1 hd) | HDNEHole x ih = HDNEHole (HNLam1 x) (ds-lem-lam1 ih) 116 | disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) with disjoint-sym _ _ hd 117 | disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam1 ih) (ds-lem-lam1 ih₁) 118 | 119 | disjoint-sym _ c (HDLam2 hd) = HDConst 120 | disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) with disjoint-sym _ _ hd 121 | disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) | HDAsc ih = HDAsc (ds-lem-lam2 ih) 122 | disjoint-sym _ (X x₁) (HDLam2 hd) = HDVar 123 | disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) with disjoint-sym _ _ hd 124 | disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) | HDLam1 ih = HDLam1 (ds-lem-lam2 ih) 125 | disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) with disjoint-sym _ _ hd 126 | disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) | HDLam2 ih = HDLam2 (ds-lem-lam2 ih) 127 | disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd 128 | disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam2 hd) | HDHole x = HDHole (HNLam2 x) 129 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd 130 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam2 hd) | HDNEHole x ih = HDNEHole (HNLam2 x) (ds-lem-lam2 ih) 131 | disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) with disjoint-sym _ _ hd 132 | disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam2 ih) (ds-lem-lam2 ih₁) 133 | 134 | disjoint-sym _ c (HDHole x) = HDConst 135 | disjoint-sym _ (e2 ·: x) (HDHole (HNAsc x₁)) = HDAsc (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁)) 136 | disjoint-sym _ (X x) (HDHole x₁) = HDVar 137 | disjoint-sym _ (·λ x e2) (HDHole (HNLam1 x₁)) = HDLam1 (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁)) 138 | disjoint-sym _ (·λ x [ x₁ ] e2) (HDHole (HNLam2 x₂)) = HDLam2 (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₂)) 139 | disjoint-sym _ ⦇-⦈[ x ] (HDHole (HNHole x₁)) = HDHole (HNHole (flip x₁)) 140 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ u' ] (HDHole (HNNEHole x x₁)) = HDNEHole (HNHole (flip x)) (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁)) 141 | disjoint-sym _ (e2 ∘ e3) (HDHole (HNAp x x₁)) = HDAp (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x)) 142 | (disjoint-sym ⦇-⦈[ _ ] e3 (HDHole x₁)) 143 | 144 | disjoint-sym _ c (HDNEHole x hd) = HDConst 145 | disjoint-sym _ (e2 ·: x) (HDNEHole x₁ hd) with disjoint-sym _ _ hd 146 | disjoint-sym _ (e ·: x) (HDNEHole (HNAsc x₁) hd) | HDAsc ih = HDAsc (ds-lem-nehole ih x₁) 147 | disjoint-sym _ (X x) (HDNEHole x₁ hd) = HDVar 148 | disjoint-sym _ (·λ x e2) (HDNEHole x₁ hd) with disjoint-sym _ _ hd 149 | disjoint-sym _ (·λ x e2) (HDNEHole (HNLam1 x₁) hd) | HDLam1 ih = HDLam1 (ds-lem-nehole ih x₁) 150 | disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole x₂ hd) with disjoint-sym _ _ hd 151 | disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole (HNLam2 x₂) hd) | HDLam2 ih = HDLam2 (ds-lem-nehole ih x₂) 152 | disjoint-sym _ ⦇-⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd 153 | disjoint-sym _ ⦇-⦈[ x ] (HDNEHole (HNHole x₂) hd) | HDHole x₁ = HDHole (HNNEHole (flip x₂) x₁) 154 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd 155 | disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDNEHole (HNNEHole x₂ x₃) hd) | HDNEHole x₁ ih = HDNEHole (HNNEHole (flip x₂) x₁) (ds-lem-nehole ih x₃) 156 | disjoint-sym _ (e2 ∘ e3) (HDNEHole x hd) with disjoint-sym _ _ hd 157 | disjoint-sym _ (e1 ∘ e3) (HDNEHole (HNAp x x₁) hd) | HDAp ih ih₁ = HDAp (ds-lem-nehole ih x) (ds-lem-nehole ih₁ x₁) 158 | 159 | disjoint-sym _ c (HDAp hd hd₁) = HDConst 160 | disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ 161 | disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) | HDAsc ih | HDAsc ih1 = HDAsc (ds-lem-ap ih ih1) 162 | disjoint-sym _ (X x) (HDAp hd hd₁) = HDVar 163 | disjoint-sym _ (·λ x e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ 164 | disjoint-sym _ (·λ x e3) (HDAp hd hd₁) | HDLam1 ih | HDLam1 ih1 = HDLam1 (ds-lem-ap ih ih1) 165 | disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ 166 | disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) | HDLam2 ih | HDLam2 ih1 = HDLam2 (ds-lem-ap ih ih1) 167 | disjoint-sym _ ⦇-⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ 168 | disjoint-sym _ ⦇-⦈[ x ] (HDAp hd hd₁) | HDHole x₁ | HDHole x₂ = HDHole (HNAp x₁ x₂) 169 | disjoint-sym _ ⦇⌜ e3 ⌟⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ 170 | disjoint-sym _ ⦇⌜ e3 ⌟⦈[ x ] (HDAp hd hd₁) | HDNEHole x₁ ih | HDNEHole x₂ ih1 = HDNEHole (HNAp x₁ x₂) (ds-lem-ap ih ih1) 171 | disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁ 172 | disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) | HDAp ih ih₁ | HDAp ih1 ih2 = HDAp (ds-lem-ap ih ih1) (ds-lem-ap ih₁ ih2) 173 | 174 | 175 | -- note that this is false, so holes-disjoint isn't transitive 176 | -- disjoint-new : ∀{e1 e2 u} → holes-disjoint e1 e2 → hole-name-new e1 u → hole-name-new e2 u 177 | 178 | -- it's also not reflexive, because ⦇-⦈[ u ] isn't hole-disjoint with 179 | -- itself since refl : u == u; it's also not anti-reflexive, because the 180 | -- expression c *is* hole-disjoint with itself (albeit vacuously) 181 | -------------------------------------------------------------------------------- /htype-decidable.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | 6 | module htype-decidable where 7 | lemma-l : ∀{t1 t2 t4} → t1 ==> t2 == t1 ==> t4 → t2 == t4 8 | lemma-l refl = refl 9 | 10 | lemma-r : ∀{t1 t2 t3} → t1 ==> t2 == t3 ==> t2 → t1 == t3 11 | lemma-r refl = refl 12 | 13 | lemma-b : ∀{t1 t2 t3 t4} → t1 ==> t2 == t3 ==> t4 → t1 == t3 14 | lemma-b refl = refl 15 | 16 | htype-dec : (t1 t2 : htyp) → t1 == t2 + (t1 == t2 → ⊥) 17 | htype-dec b b = Inl refl 18 | htype-dec b ⦇-⦈ = Inr (λ ()) 19 | htype-dec b (t2 ==> t3) = Inr (λ ()) 20 | htype-dec ⦇-⦈ b = Inr (λ ()) 21 | htype-dec ⦇-⦈ ⦇-⦈ = Inl refl 22 | htype-dec ⦇-⦈ (t2 ==> t3) = Inr (λ ()) 23 | htype-dec (t1 ==> t2) b = Inr (λ ()) 24 | htype-dec (t1 ==> t2) ⦇-⦈ = Inr (λ ()) 25 | htype-dec (t1 ==> t2) (t3 ==> t4) with htype-dec t1 t3 | htype-dec t2 t4 26 | htype-dec (t1 ==> t2) (.t1 ==> .t2) | Inl refl | Inl refl = Inl refl 27 | htype-dec (t1 ==> t2) (.t1 ==> t4) | Inl refl | Inr x₁ = Inr (λ x → x₁ (lemma-l x)) 28 | htype-dec (t1 ==> t2) (t3 ==> .t2) | Inr x | Inl refl = Inr (λ x₁ → x (lemma-r x₁)) 29 | htype-dec (t1 ==> t2) (t3 ==> t4) | Inr x | Inr x₁ = Inr (λ x₂ → x (lemma-b x₂)) 30 | 31 | -- if an arrow is disequal, it disagrees in the first or second argument 32 | ne-factor : ∀{τ1 τ2 τ3 τ4} → (τ1 ==> τ2) ≠ (τ3 ==> τ4) → (τ1 ≠ τ3) + (τ2 ≠ τ4) 33 | ne-factor {τ1} {τ2} {τ3} {τ4} ne with htype-dec τ1 τ3 | htype-dec τ2 τ4 34 | ne-factor ne | Inl refl | Inl refl = Inl (λ x → ne refl) 35 | ne-factor ne | Inl x | Inr x₁ = Inr x₁ 36 | ne-factor ne | Inr x | Inl x₁ = Inl x 37 | ne-factor ne | Inr x | Inr x₁ = Inl x 38 | -------------------------------------------------------------------------------- /lemmas-complete.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | 5 | open import lemmas-gcomplete 6 | 7 | module lemmas-complete where 8 | -- no term is both complete and indeterminate 9 | lem-ind-comp : ∀{d} → d dcomplete → d indet → ⊥ 10 | lem-ind-comp DCVar () 11 | lem-ind-comp DCConst () 12 | lem-ind-comp (DCLam comp x₁) () 13 | lem-ind-comp (DCAp comp comp₁) (IAp x ind x₁) = lem-ind-comp comp ind 14 | lem-ind-comp (DCCast comp x x₁) (ICastArr x₂ ind) = lem-ind-comp comp ind 15 | lem-ind-comp (DCCast comp x x₁) (ICastGroundHole x₂ ind) = lem-ind-comp comp ind 16 | lem-ind-comp (DCCast comp x x₁) (ICastHoleGround x₂ ind x₃) = lem-ind-comp comp ind 17 | 18 | -- complete types that are consistent are equal 19 | complete-consistency : ∀{τ1 τ2} → τ1 ~ τ2 → τ1 tcomplete → τ2 tcomplete → τ1 == τ2 20 | complete-consistency TCRefl TCBase comp2 = refl 21 | complete-consistency TCRefl (TCArr comp1 comp2) comp3 = refl 22 | complete-consistency TCHole1 comp1 () 23 | complete-consistency TCHole2 () comp2 24 | complete-consistency (TCArr consis consis₁) (TCArr comp1 comp2) (TCArr comp3 comp4) 25 | with complete-consistency consis comp1 comp3 | complete-consistency consis₁ comp2 comp4 26 | ... | refl | refl = refl 27 | 28 | -- a well typed complete term is assigned a complete type 29 | complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) → 30 | (Δ , Γ ⊢ d :: τ) → 31 | d dcomplete → 32 | τ tcomplete 33 | complete-ta gc TAConst comp = TCBase 34 | complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁ 35 | complete-ta gc (TALam a wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁ a ) wt comp) 36 | complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) with complete-ta gc wt comp 37 | complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) | TCArr qq qq₁ = qq₁ 38 | complete-ta gc (TAEHole x x₁) () 39 | complete-ta gc (TANEHole x wt x₁) () 40 | complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂ 41 | complete-ta gc (TAFailedCast wt x x₁ x₂) () 42 | 43 | -- a well typed term synthesizes a complete type 44 | comp-synth : ∀{Γ e τ} → 45 | Γ gcomplete → 46 | e ecomplete → 47 | Γ ⊢ e => τ → 48 | τ tcomplete 49 | comp-synth gc ec SConst = TCBase 50 | comp-synth gc (ECAsc x ec) (SAsc x₁) = x 51 | comp-synth gc ec (SVar x) = gc _ _ x 52 | comp-synth gc (ECAp ec ec₁) (SAp _ wt MAHole x₁) with comp-synth gc ec wt 53 | ... | () 54 | comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) with comp-synth gc ec wt 55 | comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) | TCArr qq qq₁ = qq₁ 56 | comp-synth gc () SEHole 57 | comp-synth gc () (SNEHole _ wt) 58 | comp-synth gc (ECLam2 ec x₁) (SLam x₂ wt) = TCArr x₁ (comp-synth (gcomp-extend gc x₁ x₂) ec wt) 59 | -------------------------------------------------------------------------------- /lemmas-consistency.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | 4 | module lemmas-consistency where 5 | -- type consistency is symmetric 6 | ~sym : {t1 t2 : htyp} → t1 ~ t2 → t2 ~ t1 7 | ~sym TCRefl = TCRefl 8 | ~sym TCHole1 = TCHole2 9 | ~sym TCHole2 = TCHole1 10 | ~sym (TCArr p1 p2) = TCArr (~sym p1) (~sym p2) 11 | 12 | -- type consistency isn't transitive 13 | not-trans : ((t1 t2 t3 : htyp) → t1 ~ t2 → t2 ~ t3 → t1 ~ t3) → ⊥ 14 | not-trans t with t (b ==> b) ⦇-⦈ b TCHole1 TCHole2 15 | ... | () 16 | 17 | -- every pair of types is either consistent or not consistent 18 | ~dec : (t1 t2 : htyp) → ((t1 ~ t2) + (t1 ~̸ t2)) 19 | -- this takes care of all hole cases, so we don't consider them below 20 | ~dec _ ⦇-⦈ = Inl TCHole1 21 | ~dec ⦇-⦈ _ = Inl TCHole2 22 | -- num cases 23 | ~dec b b = Inl TCRefl 24 | ~dec b (t2 ==> t3) = Inr ICBaseArr1 25 | -- arrow cases 26 | ~dec (t1 ==> t2) b = Inr ICBaseArr2 27 | ~dec (t1 ==> t2) (t3 ==> t4) with ~dec t1 t3 | ~dec t2 t4 28 | ... | Inl x | Inl y = Inl (TCArr x y) 29 | ... | Inl _ | Inr y = Inr (ICArr2 y) 30 | ... | Inr x | _ = Inr (ICArr1 x) 31 | 32 | -- no pair of types is both consistent and not consistent 33 | ~apart : {t1 t2 : htyp} → (t1 ~̸ t2) → (t1 ~ t2) → ⊥ 34 | ~apart ICBaseArr1 () 35 | ~apart ICBaseArr2 () 36 | ~apart (ICArr1 x) TCRefl = ~apart x TCRefl 37 | ~apart (ICArr1 x) (TCArr y y₁) = ~apart x y 38 | ~apart (ICArr2 x) TCRefl = ~apart x TCRefl 39 | ~apart (ICArr2 x) (TCArr y y₁) = ~apart x y₁ 40 | -------------------------------------------------------------------------------- /lemmas-disjointness.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | 6 | module lemmas-disjointness where 7 | -- disjointness is commutative 8 | ##-comm : {A : Set} {Δ1 Δ2 : A ctx} → Δ1 ## Δ2 → Δ2 ## Δ1 9 | ##-comm (π1 , π2) = π2 , π1 10 | 11 | -- the empty context is disjoint from any context 12 | empty-disj : {A : Set} (Γ : A ctx) → ∅ ## Γ 13 | empty-disj Γ = ed1 , ed2 14 | where 15 | ed1 : {A : Set} (n : Nat) → dom {A} ∅ n → n # Γ 16 | ed1 n (π1 , ()) 17 | 18 | ed2 : {A : Set} (n : Nat) → dom Γ n → _#_ {A} n ∅ 19 | ed2 _ _ = refl 20 | 21 | -- two singleton contexts with different indices are disjoint 22 | disjoint-singles : {A : Set} {x y : A} {u1 u2 : Nat} → 23 | u1 ≠ u2 → 24 | (■ (u1 , x)) ## (■ (u2 , y)) 25 | disjoint-singles {_} {x} {y} {u1} {u2} neq = ds1 , ds2 26 | where 27 | ds1 : (n : Nat) → dom (■ (u1 , x)) n → n # (■ (u2 , y)) 28 | ds1 n d with lem-dom-eq d 29 | ds1 .u1 d | refl with natEQ u2 u1 30 | ds1 .u1 d | refl | Inl xx = abort (neq (! xx)) 31 | ds1 .u1 d | refl | Inr x₁ = refl 32 | 33 | ds2 : (n : Nat) → dom (■ (u2 , y)) n → n # (■ (u1 , x)) 34 | ds2 n d with lem-dom-eq d 35 | ds2 .u2 d | refl with natEQ u1 u2 36 | ds2 .u2 d | refl | Inl x₁ = abort (neq x₁) 37 | ds2 .u2 d | refl | Inr x₁ = refl 38 | 39 | apart-noteq : {A : Set} (p r : Nat) (q : A) → p # (■ (r , q)) → p ≠ r 40 | apart-noteq p r q apt with natEQ r p 41 | apart-noteq p .p q apt | Inl refl = abort (somenotnone apt) 42 | apart-noteq p r q apt | Inr x₁ = flip x₁ 43 | 44 | -- if singleton contexts are disjoint, their indices must be disequal 45 | singles-notequal : {A : Set} {x y : A} {u1 u2 : Nat} → 46 | (■ (u1 , x)) ## (■ (u2 , y)) → 47 | u1 ≠ u2 48 | singles-notequal {A} {x} {y} {u1} {u2} (d1 , d2) = apart-noteq u1 u2 y (d1 u1 (lem-domsingle u1 x)) 49 | 50 | -- dual of lem2 above; if two indices are disequal, then either is apart 51 | -- from the singleton formed with the other 52 | apart-singleton : {A : Set} → ∀{x y} → {τ : A} → 53 | x ≠ y → 54 | x # (■ (y , τ)) 55 | apart-singleton {A} {x} {y} {τ} neq with natEQ y x 56 | apart-singleton neq | Inl x₁ = abort ((flip neq) x₁) 57 | apart-singleton neq | Inr x₁ = refl 58 | 59 | -- if an index is apart from two contexts, it's apart from their union as 60 | -- well. used below and in other files, so it's outside the local scope. 61 | apart-parts : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # Γ1 → n # Γ2 → n # (Γ1 ∪ Γ2) 62 | apart-parts Γ1 Γ2 n apt1 apt2 with Γ1 n 63 | apart-parts _ _ n refl apt2 | .None = apt2 64 | 65 | -- this is just for convenience; it shows up a lot. 66 | apart-extend1 : {A : Set} → ∀{ x y τ} → (Γ : A ctx) → x ≠ y → x # Γ → x # (Γ ,, (y , τ)) 67 | apart-extend1 {A} {x} {y} {τ} Γ neq apt = apart-parts Γ (■ (y , τ)) x apt (apart-singleton neq) 68 | 69 | -- if an index is in the domain of a union, it's in the domain of one or 70 | -- the other unand 71 | dom-split : {A : Set} → (Γ1 Γ2 : A ctx) (n : Nat) → dom (Γ1 ∪ Γ2) n → dom Γ1 n + dom Γ2 n 72 | dom-split Γ4 Γ5 n (π1 , π2) with Γ4 n 73 | dom-split Γ4 Γ5 n (π1 , π2) | Some x = Inl (x , refl) 74 | dom-split Γ4 Γ5 n (π1 , π2) | None = Inr (π1 , π2) 75 | 76 | -- if both parts of a union are disjoint with a target, so is the union 77 | disjoint-parts : {A : Set} {Γ1 Γ2 Γ3 : A ctx} → Γ1 ## Γ3 → Γ2 ## Γ3 → (Γ1 ∪ Γ2) ## Γ3 78 | disjoint-parts {_} {Γ1} {Γ2} {Γ3} D13 D23 = d31 , d32 79 | where 80 | d31 : (n : Nat) → dom (Γ1 ∪ Γ2) n → n # Γ3 81 | d31 n D with dom-split Γ1 Γ2 n D 82 | d31 n D | Inl x = π1 D13 n x 83 | d31 n D | Inr x = π1 D23 n x 84 | 85 | d32 : (n : Nat) → dom Γ3 n → n # (Γ1 ∪ Γ2) 86 | d32 n D = apart-parts Γ1 Γ2 n (π2 D13 n D) (π2 D23 n D) 87 | 88 | apart-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ1 89 | apart-union1 Γ1 Γ2 n aprt with Γ1 n 90 | apart-union1 Γ1 Γ2 n () | Some x 91 | apart-union1 Γ1 Γ2 n aprt | None = refl 92 | 93 | apart-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → n # (Γ1 ∪ Γ2) → n # Γ2 94 | apart-union2 Γ1 Γ2 n aprt with Γ1 n 95 | apart-union2 Γ3 Γ4 n () | Some x 96 | apart-union2 Γ3 Γ4 n aprt | None = aprt 97 | 98 | -- if a union is disjoint with a target, so is the left unand 99 | disjoint-union1 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ1 ## Δ 100 | disjoint-union1 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du11 , du12 101 | where 102 | dom-union1 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ1 n → dom (Γ1 ∪ Γ2) n 103 | dom-union1 Γ1 Γ2 n (π1 , π2) with Γ1 n 104 | dom-union1 Γ1 Γ2 n (π1 , π2) | Some x = x , refl 105 | dom-union1 Γ1 Γ2 n (π1 , ()) | None 106 | 107 | du11 : (n : Nat) → dom Γ1 n → n # Δ 108 | du11 n dom = ud1 n (dom-union1 Γ1 Γ2 n dom) 109 | 110 | du12 : (n : Nat) → dom Δ n → n # Γ1 111 | du12 n dom = apart-union1 Γ1 Γ2 n (ud2 n dom) 112 | 113 | -- if a union is disjoint with a target, so is the right unand 114 | disjoint-union2 : {A : Set} {Γ1 Γ2 Δ : A ctx} → (Γ1 ∪ Γ2) ## Δ → Γ2 ## Δ 115 | disjoint-union2 {Γ1 = Γ1} {Γ2 = Γ2} {Δ = Δ} (ud1 , ud2) = du21 , du22 116 | where 117 | dom-union2 : {A : Set} (Γ1 Γ2 : A ctx) (n : Nat) → dom Γ2 n → dom (Γ1 ∪ Γ2) n 118 | dom-union2 Γ1 Γ2 n (π1 , π2) with Γ1 n 119 | dom-union2 Γ3 Γ4 n (π1 , π2) | Some x = x , refl 120 | dom-union2 Γ3 Γ4 n (π1 , π2) | None = π1 , π2 121 | 122 | du21 : (n : Nat) → dom Γ2 n → n # Δ 123 | du21 n dom = ud1 n (dom-union2 Γ1 Γ2 n dom) 124 | 125 | du22 : (n : Nat) → dom Δ n → n # Γ2 126 | du22 n dom = apart-union2 Γ1 Γ2 n (ud2 n dom) 127 | 128 | -- if x isn't in a context and y is then they can't be equal 129 | lem-dom-apt : {A : Set} {G : A ctx} {x y : Nat} → x # G → dom G y → x ≠ y 130 | lem-dom-apt {x = x} {y = y} apt dom with natEQ x y 131 | lem-dom-apt apt dom | Inl refl = abort (somenotnone (! (π2 dom) · apt)) 132 | lem-dom-apt apt dom | Inr x₁ = x₁ 133 | -------------------------------------------------------------------------------- /lemmas-freshness.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import lemmas-disjointness 6 | 7 | module lemmas-freshness where 8 | -- if x is fresh in an hexp, it's fresh in its expansion 9 | mutual 10 | fresh-elab-synth1 : ∀{x e τ d Γ Δ} → 11 | x # Γ → 12 | freshh x e → 13 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 14 | fresh x d 15 | fresh-elab-synth1 _ FRHConst ESConst = FConst 16 | fresh-elab-synth1 apt (FRHAsc frsh) (ESAsc x₁) = FCast (fresh-elab-ana1 apt frsh x₁) 17 | fresh-elab-synth1 _ (FRHVar x₂) (ESVar x₃) = FVar x₂ 18 | fresh-elab-synth1 {Γ = Γ} apt (FRHLam2 x₂ frsh) (ESLam x₃ exp) = FLam x₂ (fresh-elab-synth1 (apart-extend1 Γ x₂ apt) frsh exp) 19 | fresh-elab-synth1 apt FRHEHole ESEHole = FHole (EFId apt) 20 | fresh-elab-synth1 apt (FRHNEHole frsh) (ESNEHole x₁ exp) = FNEHole (EFId apt) (fresh-elab-synth1 apt frsh exp) 21 | fresh-elab-synth1 apt (FRHAp frsh frsh₁) (ESAp x₁ x₂ x₃ x₄ x₅ x₆) = 22 | FAp (FCast (fresh-elab-ana1 apt frsh x₅)) 23 | (FCast (fresh-elab-ana1 apt frsh₁ x₆)) 24 | 25 | fresh-elab-ana1 : ∀{ x e τ d τ' Γ Δ} → 26 | x # Γ → 27 | freshh x e → 28 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 29 | fresh x d 30 | fresh-elab-ana1 {Γ = Γ} apt (FRHLam1 x₁ frsh) (EALam x₂ x₃ exp) = FLam x₁ (fresh-elab-ana1 (apart-extend1 Γ x₁ apt) frsh exp ) 31 | fresh-elab-ana1 apt frsh (EASubsume x₁ x₂ x₃ x₄) = fresh-elab-synth1 apt frsh x₃ 32 | fresh-elab-ana1 apt FRHEHole EAEHole = FHole (EFId apt) 33 | fresh-elab-ana1 apt (FRHNEHole frsh) (EANEHole x₁ x₂) = FNEHole (EFId apt) (fresh-elab-synth1 apt frsh x₂) 34 | 35 | -- if x is fresh in the expansion of an hexp, it's fresh in that hexp 36 | mutual 37 | fresh-elab-synth2 : ∀{x e τ d Γ Δ} → 38 | fresh x d → 39 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 40 | freshh x e 41 | fresh-elab-synth2 FConst ESConst = FRHConst 42 | fresh-elab-synth2 (FVar x₂) (ESVar x₃) = FRHVar x₂ 43 | fresh-elab-synth2 (FLam x₂ frsh) (ESLam x₃ exp) = FRHLam2 x₂ (fresh-elab-synth2 frsh exp) 44 | fresh-elab-synth2 (FHole x₁) ESEHole = FRHEHole 45 | fresh-elab-synth2 (FNEHole x₁ frsh) (ESNEHole x₂ exp) = FRHNEHole (fresh-elab-synth2 frsh exp) 46 | fresh-elab-synth2 (FAp (FCast frsh) (FCast frsh₁)) (ESAp x₁ x₂ x₃ x₄ x₅ x₆) = 47 | FRHAp (fresh-elab-ana2 frsh x₅) 48 | (fresh-elab-ana2 frsh₁ x₆) 49 | fresh-elab-synth2 (FCast frsh) (ESAsc x₁) = FRHAsc (fresh-elab-ana2 frsh x₁) 50 | 51 | fresh-elab-ana2 : ∀{ x e τ d τ' Γ Δ} → 52 | fresh x d → 53 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 54 | freshh x e 55 | fresh-elab-ana2 (FLam x₁ frsh) (EALam x₂ x₃ exp) = FRHLam1 x₁ (fresh-elab-ana2 frsh exp) 56 | fresh-elab-ana2 frsh (EASubsume x₁ x₂ x₃ x₄) = fresh-elab-synth2 frsh x₃ 57 | fresh-elab-ana2 (FHole x₁) EAEHole = FRHEHole 58 | fresh-elab-ana2 (FNEHole x₁ frsh) (EANEHole x₂ x₃) = FRHNEHole (fresh-elab-synth2 frsh x₃) 59 | -------------------------------------------------------------------------------- /lemmas-gcomplete.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | 6 | module lemmas-gcomplete where 7 | -- if you add a complete type to a complete context, the result is also a 8 | -- complete context 9 | gcomp-extend : ∀{Γ τ x} → Γ gcomplete → τ tcomplete → x # Γ → (Γ ,, (x , τ)) gcomplete 10 | gcomp-extend {Γ} {τ} {x} gc tc apart x_query τ_query x₁ with natEQ x x_query 11 | gcomp-extend {Γ} {τ} {x} gc tc apart .x τ_query x₂ | Inl refl = tr (λ qq → qq tcomplete) (lem-apart-union-eq {Γ = Γ} apart x₂) tc 12 | gcomp-extend {Γ} {τ} {x} gc tc apart x_query τ_query x₂ | Inr x₁ = gc x_query τ_query (lem-neq-union-eq {Γ = Γ} (flip x₁) x₂ ) 13 | -------------------------------------------------------------------------------- /lemmas-ground.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | 4 | module lemmas-ground where 5 | -- not ground types aren't hole to hole 6 | ground-arr-not-hole : ∀{τ} → 7 | (τ ground → ⊥) → 8 | (τ ≠ (⦇-⦈ ==> ⦇-⦈)) 9 | ground-arr-not-hole notg refl = notg GHole 10 | 11 | -- not ground types either have to be hole or an arrow 12 | notground : ∀{τ} → (τ ground → ⊥) → (τ == ⦇-⦈) + (Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] (τ == (τ1 ==> τ2))) 13 | notground {b} gnd = abort (gnd GBase) 14 | notground {⦇-⦈} gnd = Inl refl 15 | notground {b ==> b} gnd = Inr (b , b , refl) 16 | notground {b ==> ⦇-⦈} gnd = Inr (b , ⦇-⦈ , refl) 17 | notground {b ==> τ2 ==> τ3} gnd = Inr (b , τ2 ==> τ3 , refl) 18 | notground {⦇-⦈ ==> b} gnd = Inr (⦇-⦈ , b , refl) 19 | notground {⦇-⦈ ==> ⦇-⦈} gnd = abort (gnd GHole) 20 | notground {⦇-⦈ ==> τ2 ==> τ3} gnd = Inr (⦇-⦈ , τ2 ==> τ3 , refl) 21 | notground {(τ1 ==> τ2) ==> b} gnd = Inr (τ1 ==> τ2 , b , refl) 22 | notground {(τ1 ==> τ2) ==> ⦇-⦈} gnd = Inr (τ1 ==> τ2 , ⦇-⦈ , refl) 23 | notground {(τ1 ==> τ2) ==> τ3 ==> τ4} gnd = Inr (τ1 ==> τ2 , τ3 ==> τ4 , refl) 24 | -------------------------------------------------------------------------------- /lemmas-matching.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | 4 | module lemmas-matching where 5 | -- matching produces unique answers for arrows, sums, and products 6 | ▸arr-unicity : ∀{ t t2 t3 } → 7 | t ▸arr t2 → 8 | t ▸arr t3 → 9 | t2 == t3 10 | ▸arr-unicity MAHole MAHole = refl 11 | ▸arr-unicity MAArr MAArr = refl 12 | 13 | -- if an arrow matches, then it's consistent with the least restrictive 14 | -- function type 15 | matchconsisthole : ∀{t t'} → 16 | t ▸arr t' → 17 | t ~ (⦇-⦈ ==> ⦇-⦈) 18 | matchconsisthole MAHole = TCHole2 19 | matchconsisthole MAArr = TCArr TCHole1 TCHole1 20 | 21 | match-consist : ∀{τ1 τ2} → τ1 ▸arr τ2 → (τ2 ~ τ1) 22 | match-consist MAHole = TCHole1 23 | match-consist MAArr = TCRefl 24 | 25 | match-unicity : ∀{ τ τ1 τ2} → τ ▸arr τ1 → τ ▸arr τ2 → τ1 == τ2 26 | match-unicity MAHole MAHole = refl 27 | match-unicity MAArr MAArr = refl 28 | -------------------------------------------------------------------------------- /lemmas-progress-checks.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | 5 | module lemmas-progress-checks where 6 | -- boxed values don't have an instruction transition 7 | boxedval-not-trans : ∀{d d'} → d boxedval → d →> d' → ⊥ 8 | boxedval-not-trans (BVVal VConst) () 9 | boxedval-not-trans (BVVal VLam) () 10 | boxedval-not-trans (BVArrCast x bv) (ITCastID) = x refl 11 | boxedval-not-trans (BVHoleCast () bv) (ITCastID) 12 | boxedval-not-trans (BVHoleCast () bv) (ITCastSucceed x₁) 13 | boxedval-not-trans (BVHoleCast GHole bv) (ITGround (MGArr x)) = x refl 14 | boxedval-not-trans (BVHoleCast x a) (ITExpand ()) 15 | boxedval-not-trans (BVHoleCast x x₁) (ITCastFail x₂ () x₄) 16 | 17 | -- indets don't have an instruction transition 18 | indet-not-trans : ∀{d d'} → d indet → d →> d' → ⊥ 19 | indet-not-trans IEHole () 20 | indet-not-trans (INEHole x) () 21 | indet-not-trans (IAp x₁ () x₂) (ITLam) 22 | indet-not-trans (IAp x (ICastArr x₁ ind) x₂) (ITApCast ) = x _ _ _ _ _ refl 23 | indet-not-trans (ICastArr x ind) (ITCastID) = x refl 24 | indet-not-trans (ICastGroundHole () ind) (ITCastID) 25 | indet-not-trans (ICastGroundHole x ind) (ITCastSucceed ()) 26 | indet-not-trans (ICastGroundHole GHole ind) (ITGround (MGArr x)) = x refl 27 | indet-not-trans (ICastHoleGround x ind ()) (ITCastID) 28 | indet-not-trans (ICastHoleGround x ind x₁) (ITCastSucceed x₂) = x _ _ refl 29 | indet-not-trans (ICastHoleGround x ind GHole) (ITExpand (MGArr x₂)) = x₂ refl 30 | indet-not-trans (ICastGroundHole x a) (ITExpand ()) 31 | indet-not-trans (ICastHoleGround x a x₁) (ITGround ()) 32 | indet-not-trans (ICastGroundHole x x₁) (ITCastFail x₂ () x₄) 33 | indet-not-trans (ICastHoleGround x x₁ x₂) (ITCastFail x₃ x₄ x₅) = x _ _ refl 34 | indet-not-trans (IFailedCast x x₁ x₂ x₃) () 35 | 36 | -- finals don't have an instruction transition 37 | final-not-trans : ∀{d d'} → d final → d →> d' → ⊥ 38 | final-not-trans (FBoxedVal x) = boxedval-not-trans x 39 | final-not-trans (FIndet x) = indet-not-trans x 40 | 41 | -- finals cast from a ground are still final 42 | final-gnd-cast : ∀{ d τ } → d final → τ ground → (d ⟨ τ ⇒ ⦇-⦈ ⟩) final 43 | final-gnd-cast (FBoxedVal x) gnd = FBoxedVal (BVHoleCast gnd x) 44 | final-gnd-cast (FIndet x) gnd = FIndet (ICastGroundHole gnd x) 45 | 46 | -- if an expression results from filling a hole in an evaluation context, 47 | -- the hole-filler must have been final 48 | final-sub-final : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final 49 | final-sub-final x FHOuter = x 50 | final-sub-final (FBoxedVal (BVVal ())) (FHAp1 eps) 51 | final-sub-final (FBoxedVal (BVVal ())) (FHAp2 eps) 52 | final-sub-final (FBoxedVal (BVVal ())) (FHNEHole eps) 53 | final-sub-final (FBoxedVal (BVVal ())) (FHCast eps) 54 | final-sub-final (FBoxedVal (BVVal ())) (FHFailedCast y) 55 | final-sub-final (FBoxedVal (BVArrCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps 56 | final-sub-final (FBoxedVal (BVHoleCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps 57 | final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = final-sub-final (FIndet x₂) eps 58 | final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp2 eps) = final-sub-final x₃ eps 59 | final-sub-final (FIndet (INEHole x₁)) (FHNEHole eps) = final-sub-final x₁ eps 60 | final-sub-final (FIndet (ICastArr x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps 61 | final-sub-final (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps 62 | final-sub-final (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = final-sub-final (FIndet x₂) eps 63 | final-sub-final (FIndet (IFailedCast x₁ x₂ x₃ x₄)) (FHFailedCast y) = final-sub-final x₁ y 64 | 65 | final-sub-not-trans : ∀{d d' d'' ε} → d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥ 66 | final-sub-not-trans f sub step = final-not-trans (final-sub-final f sub) step 67 | -------------------------------------------------------------------------------- /lemmas-subst-ta.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import Nat 3 | open import core 4 | open import contexts 5 | open import weakening 6 | open import exchange 7 | open import lemmas-disjointness 8 | open import binders-disjoint-checks 9 | 10 | module lemmas-subst-ta where 11 | -- this is what makes the binders-unique assumption below good enough: it 12 | -- tells us that we can pick fresh variables 13 | mutual 14 | binders-envfresh : ∀{Δ Γ Γ' y σ} → Δ , Γ ⊢ σ :s: Γ' → y # Γ → unbound-in-σ y σ → binders-unique-σ σ → envfresh y σ 15 | binders-envfresh {Γ' = Γ'} {y = y} (STAId x) apt unbound unique with ctxindirect Γ' y 16 | binders-envfresh {Γ' = Γ'} {y = y} (STAId x₁) apt unbound unique | Inl x = abort (somenotnone (! (x₁ y (π1 x) (π2 x)) · apt)) 17 | binders-envfresh (STAId x₁) apt unbound unique | Inr x = EFId x 18 | binders-envfresh {Γ = Γ} {y = y} (STASubst {y = z} subst x₁) apt (UBσSubst x₂ unbound neq) (BUσSubst zz x₃ x₄) = 19 | EFSubst (binders-fresh {y = y} x₁ zz x₂ apt) 20 | (binders-envfresh subst (apart-extend1 Γ neq apt) unbound x₃) 21 | neq 22 | 23 | binders-fresh : ∀{ Δ Γ d2 τ y} → Δ , Γ ⊢ d2 :: τ 24 | → binders-unique d2 25 | → unbound-in y d2 26 | → Γ y == None 27 | → fresh y d2 28 | binders-fresh TAConst BUHole UBConst apt = FConst 29 | binders-fresh {y = y} (TAVar {x = x} x₁) BUVar UBVar apt with natEQ y x 30 | binders-fresh (TAVar x₂) BUVar UBVar apt | Inl refl = abort (somenotnone (! x₂ · apt)) 31 | binders-fresh (TAVar x₂) BUVar UBVar apt | Inr x₁ = FVar x₁ 32 | binders-fresh {y = y} (TALam {x = x} x₁ wt) bu2 ub apt with natEQ y x 33 | binders-fresh (TALam x₂ wt) bu2 (UBLam2 x₁ ub) apt | Inl refl = abort (x₁ refl) 34 | 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)) 35 | 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) 36 | binders-fresh (TAEHole x₁ x₂) (BUEHole x) (UBHole x₃) apt = FHole (binders-envfresh x₂ apt x₃ x ) 37 | 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) 38 | binders-fresh (TACast wt x₁) (BUCast bu2) (UBCast ub) apt = FCast (binders-fresh wt bu2 ub apt) 39 | binders-fresh (TAFailedCast wt x x₁ x₂) (BUFailedCast bu2) (UBFailedCast ub) apt = FFailedCast (binders-fresh wt bu2 ub apt) 40 | 41 | -- the substition lemma for preservation 42 | lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } → 43 | x # Γ → 44 | binders-disjoint d1 d2 → 45 | binders-unique d2 → 46 | Δ , Γ ,, (x , τ1) ⊢ d1 :: τ → 47 | Δ , Γ ⊢ d2 :: τ1 → 48 | Δ , Γ ⊢ [ d2 / x ] d1 :: τ 49 | lem-subst apt bd bu2 TAConst wt2 = TAConst 50 | lem-subst {x = x} apt bd bu2 (TAVar {x = x'} x₂) wt2 with natEQ x' x 51 | lem-subst {Γ = Γ} apt bd bu2 (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃ 52 | lem-subst apt bd bu2 (TAVar x₃) wt2 | Inl refl | refl = wt2 53 | lem-subst {Γ = Γ} apt bd bu2 (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃) 54 | lem-subst {Δ = Δ} {Γ = Γ} {x = x} {d2 = d2} x#Γ (BDLam bd bd') bu2 (TALam {x = y} {τ1 = τ1} {d = d} {τ2 = τ2} x₂ wt1) wt2 55 | with lem-union-none {Γ = Γ} x₂ 56 | ... | x≠y , y#Γ with natEQ y x 57 | ... | Inl eq = abort (x≠y (! eq)) 58 | ... | Inr _ = TALam y#Γ (lem-subst {Δ = Δ} {Γ = Γ ,, (y , τ1)} {x = x} {d1 = d} (apart-extend1 Γ x≠y x#Γ) bd bu2 (exchange-ta-Γ {Γ = Γ} x≠y wt1) 59 | (weaken-ta (binders-fresh wt2 bu2 bd' y#Γ) wt2)) 60 | 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) 61 | lem-subst apt bd bu2 (TAEHole inΔ sub) wt2 = TAEHole inΔ (STASubst sub wt2) 62 | lem-subst apt (BDNEHole x₁ bd) bu2 (TANEHole x₃ wt1 x₄) wt2 = TANEHole x₃ (lem-subst apt bd bu2 wt1 wt2) (STASubst x₄ wt2) 63 | lem-subst apt (BDCast bd) bu2 (TACast wt1 x₁) wt2 = TACast (lem-subst apt bd bu2 wt1 wt2) x₁ 64 | lem-subst apt (BDFailedCast bd) bu2 (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt bd bu2 wt1 wt2) x₁ x₂ x₃ 65 | -------------------------------------------------------------------------------- /postulates.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | grep --color=auto -A 1 'postulate' *.agda 4 | 5 | echo "---------------------------------------------------------------------------------------" 6 | echo "used in:" 7 | echo "---------------------------------------------------------------------------------------" 8 | 9 | grep --color=auto "open import structural-assumptions" *.agda | cut -d ':' -f 1,1 | sort | uniq 10 | -------------------------------------------------------------------------------- /preservation.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | 6 | open import lemmas-consistency 7 | open import type-assignment-unicity 8 | open import binders-disjoint-checks 9 | 10 | open import lemmas-subst-ta 11 | 12 | module preservation where 13 | -- if d and d' both result from filling the hole in ε with terms of the 14 | -- same type, they too have the same type. 15 | wt-different-fill : ∀{ Δ Γ d ε d1 d2 d' τ τ1 } → 16 | d == ε ⟦ d1 ⟧ → 17 | Δ , Γ ⊢ d :: τ → 18 | Δ , Γ ⊢ d1 :: τ1 → 19 | Δ , Γ ⊢ d2 :: τ1 → 20 | d' == ε ⟦ d2 ⟧ → 21 | Δ , Γ ⊢ d' :: τ 22 | wt-different-fill FHOuter D1 D2 D3 FHOuter 23 | with type-assignment-unicity D1 D2 24 | ... | refl = D3 25 | wt-different-fill (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (wt-different-fill eps D1 D3 D4 D5) D2 26 | wt-different-fill (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (wt-different-fill eps D2 D3 D4 D5) 27 | wt-different-fill (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (wt-different-fill eps D1 D2 D3 D4) x₁ 28 | wt-different-fill (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (wt-different-fill eps D1 D2 D3 D4) x 29 | 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₃ 30 | 31 | -- if a well typed term results from filling the hole in ε, then the term 32 | -- that filled the hole is also well typed 33 | wt-filling : ∀{ ε Δ Γ d τ d' } → 34 | Δ , Γ ⊢ d :: τ → 35 | d == ε ⟦ d' ⟧ → 36 | Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ') 37 | wt-filling TAConst FHOuter = _ , TAConst 38 | wt-filling (TAVar x₁) FHOuter = _ , TAVar x₁ 39 | wt-filling (TALam f ta) FHOuter = _ , TALam f ta 40 | 41 | wt-filling (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁ 42 | wt-filling (TAAp ta ta₁) (FHAp1 eps) = wt-filling ta eps 43 | wt-filling (TAAp ta ta₁) (FHAp2 eps) = wt-filling ta₁ eps 44 | 45 | wt-filling (TAEHole x x₁) FHOuter = _ , TAEHole x x₁ 46 | wt-filling (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁ 47 | wt-filling (TANEHole x ta x₁) (FHNEHole eps) = wt-filling ta eps 48 | wt-filling (TACast ta x) FHOuter = _ , TACast ta x 49 | wt-filling (TACast ta x) (FHCast eps) = wt-filling ta eps 50 | wt-filling (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w 51 | wt-filling (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = wt-filling x y 52 | 53 | -- instruction transitions preserve type 54 | preserve-trans : ∀{ Δ Γ d τ d' } → 55 | binders-unique d → 56 | Δ , Γ ⊢ d :: τ → 57 | d →> d' → 58 | Δ , Γ ⊢ d' :: τ 59 | preserve-trans bd TAConst () 60 | preserve-trans bd (TAVar x₁) () 61 | preserve-trans bd (TALam _ ta) () 62 | preserve-trans (BUAp (BULam bd x₁) bd₁ (BDLam x₂ x₃)) (TAAp (TALam apt ta) ta₁) ITLam = lem-subst apt x₂ bd₁ ta ta₁ 63 | preserve-trans bd (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl 64 | preserve-trans bd (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁ 65 | preserve-trans bd (TAEHole x x₁) () 66 | preserve-trans bd (TANEHole x ta x₁) () 67 | preserve-trans bd (TACast ta x) (ITCastID) = ta 68 | preserve-trans bd (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta 69 | preserve-trans bd (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1 70 | preserve-trans bd (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2) 71 | preserve-trans bd (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z 72 | preserve-trans bd (TAFailedCast x y z q) () 73 | 74 | lem-bd-ε1 : ∀{ d ε d0} → d == ε ⟦ d0 ⟧ → binders-unique d → binders-unique d0 75 | lem-bd-ε1 FHOuter bd = bd 76 | lem-bd-ε1 (FHAp1 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd 77 | lem-bd-ε1 (FHAp2 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd₁ 78 | lem-bd-ε1 (FHNEHole eps) (BUNEHole bd x) = lem-bd-ε1 eps bd 79 | lem-bd-ε1 (FHCast eps) (BUCast bd) = lem-bd-ε1 eps bd 80 | lem-bd-ε1 (FHFailedCast eps) (BUFailedCast bd) = lem-bd-ε1 eps bd 81 | 82 | -- this is the main preservation theorem, gluing together the above 83 | preservation : {Δ : hctx} {d d' : ihexp} {τ : htyp} {Γ : tctx} → 84 | binders-unique d → 85 | Δ , Γ ⊢ d :: τ → 86 | d ↦ d' → 87 | Δ , Γ ⊢ d' :: τ 88 | preservation bd D (Step x x₁ x₂) 89 | with wt-filling D x 90 | ... | (_ , wt) = wt-different-fill x D wt (preserve-trans (lem-bd-ε1 x bd) wt x₁) x₂ 91 | 92 | -- note that the exact statement of preservation in the paper, where Γ is 93 | -- empty indicating that the terms are closed, is an immediate corrolary 94 | -- of the slightly more general statement above. 95 | preservation' : {Δ : hctx} {d d' : ihexp} {τ : htyp} → 96 | binders-unique d → 97 | Δ , ∅ ⊢ d :: τ → 98 | d ↦ d' → 99 | Δ , ∅ ⊢ d' :: τ 100 | preservation' = preservation 101 | -------------------------------------------------------------------------------- /progress-checks.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import lemmas-consistency 6 | open import type-assignment-unicity 7 | open import lemmas-progress-checks 8 | 9 | -- taken together, the theorems in this file argue that for any expression 10 | -- d, at most one summand of the labeled sum that results from progress may 11 | -- be true at any time: that boxed values, indeterminates, and expressions 12 | -- that step are pairwise disjoint. 13 | -- 14 | -- note that as a consequence of currying and comutativity of products, 15 | -- this means that there are three theorems to prove. in addition to those, 16 | -- we also prove several convenince forms that combine theorems about 17 | -- indeterminate and boxed value forms into the same statement about final 18 | -- forms, which mirrors the mutual definition of indeterminate and final 19 | -- and saves some redundant argumentation. 20 | module progress-checks where 21 | -- boxed values are not indeterminates 22 | boxedval-not-indet : ∀{d} → d boxedval → d indet → ⊥ 23 | boxedval-not-indet (BVVal VConst) () 24 | boxedval-not-indet (BVVal VLam) () 25 | boxedval-not-indet (BVArrCast x bv) (ICastArr x₁ ind) = boxedval-not-indet bv ind 26 | boxedval-not-indet (BVHoleCast x bv) (ICastGroundHole x₁ ind) = boxedval-not-indet bv ind 27 | boxedval-not-indet (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = boxedval-not-indet bv ind 28 | 29 | -- boxed values don't step 30 | boxedval-not-step : ∀{d} → d boxedval → (Σ[ d' ∈ ihexp ] (d ↦ d')) → ⊥ 31 | boxedval-not-step (BVVal VConst) (d' , Step FHOuter () x₃) 32 | boxedval-not-step (BVVal VLam) (d' , Step FHOuter () x₃) 33 | boxedval-not-step (BVArrCast x bv) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl 34 | boxedval-not-step (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃) 35 | boxedval-not-step (BVHoleCast () bv) (d' , Step FHOuter (ITCastID) FHOuter) 36 | boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed ()) FHOuter) 37 | boxedval-not-step (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround (MGArr x)) FHOuter) = x refl 38 | boxedval-not-step (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃) 39 | boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter) 40 | boxedval-not-step (BVHoleCast x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter) 41 | 42 | mutual 43 | -- indeterminates don't step 44 | indet-not-step : ∀{d} → d indet → (Σ[ d' ∈ ihexp ] (d ↦ d')) → ⊥ 45 | indet-not-step IEHole (d' , Step FHOuter () FHOuter) 46 | indet-not-step (INEHole x) (d' , Step FHOuter () FHOuter) 47 | indet-not-step (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = final-sub-not-trans x x₁ x₂ 48 | indet-not-step (IAp x₁ () x₂) (_ , Step FHOuter (ITLam) FHOuter) 49 | indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast) FHOuter) = x _ _ _ _ _ refl 50 | indet-not-step (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄) 51 | indet-not-step (IAp x ind f) (_ , Step (FHAp2 x₃) x₄ (FHAp2 x₆)) = final-not-step f (_ , Step x₃ x₄ x₆) 52 | indet-not-step (ICastArr x ind) (d0' , Step FHOuter (ITCastID) FHOuter) = x refl 53 | indet-not-step (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) 54 | indet-not-step (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID) FHOuter) 55 | indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed ()) FHOuter) 56 | indet-not-step (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (MGArr x₁)) FHOuter) = x₁ refl 57 | indet-not-step (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) 58 | indet-not-step (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID ) FHOuter) 59 | indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₂) FHOuter) = x _ _ refl 60 | indet-not-step (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand (MGArr x₂)) FHOuter) = x₂ refl 61 | indet-not-step (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃) 62 | indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITExpand ()) FHOuter) 63 | indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITGround ()) FHOuter) 64 | indet-not-step (ICastGroundHole x x₁) (_ , Step FHOuter (ITCastFail x₂ () x₄) FHOuter) 65 | indet-not-step (ICastHoleGround x x₁ x₂) (_ , Step FHOuter (ITCastFail x₃ x₄ x₅) FHOuter) = x _ _ refl 66 | indet-not-step (IFailedCast x x₁ x₂ x₃) (d' , Step FHOuter () FHOuter) 67 | indet-not-step (IFailedCast x x₁ x₂ x₃) (_ , Step (FHFailedCast x₄) x₅ (FHFailedCast x₆)) = final-not-step x (_ , Step x₄ x₅ x₆) 68 | 69 | -- final expressions don't step 70 | final-not-step : ∀{d} → d final → Σ[ d' ∈ ihexp ] (d ↦ d') → ⊥ 71 | final-not-step (FBoxedVal x) stp = boxedval-not-step x stp 72 | final-not-step (FIndet x) stp = indet-not-step x stp 73 | -------------------------------------------------------------------------------- /progress.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import lemmas-consistency 6 | open import lemmas-ground 7 | 8 | open import progress-checks 9 | 10 | open import canonical-boxed-forms 11 | open import canonical-value-forms 12 | open import canonical-indeterminate-forms 13 | 14 | open import ground-decidable 15 | open import htype-decidable 16 | 17 | module progress where 18 | -- this is a little bit of syntactic sugar to avoid many layer nested Inl 19 | -- and Inrs that you would get from the more literal transcription of the 20 | -- consequent of progress 21 | data ok : (d : ihexp) (Δ : hctx) → Set where 22 | S : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → ok d Δ 23 | I : ∀{d Δ} → d indet → ok d Δ 24 | BV : ∀{d Δ} → d boxedval → ok d Δ 25 | 26 | progress : {Δ : hctx} {d : ihexp} {τ : htyp} → 27 | Δ , ∅ ⊢ d :: τ → 28 | ok d Δ 29 | -- constants 30 | progress TAConst = BV (BVVal VConst) 31 | 32 | -- variables 33 | progress (TAVar x₁) = abort (somenotnone (! x₁)) 34 | 35 | -- lambdas 36 | progress (TALam _ wt) = BV (BVVal VLam) 37 | 38 | -- applications 39 | progress (TAAp wt1 wt2) 40 | with progress wt1 | progress wt2 41 | -- if the left steps, the whole thing steps 42 | progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z)) 43 | -- if the left is indeterminate, step the right 44 | progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2 z)) 45 | -- if they're both indeterminate, step when the cast steps and indet otherwise 46 | progress (TAAp wt1 wt2) | I x | I x₁ 47 | with canonical-indeterminate-forms-arr wt1 x 48 | progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter) 49 | progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) 50 | progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) 51 | progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) 52 | progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) 53 | progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y)) 54 | -- similar if the left is indetermiante but the right is a boxed val 55 | progress (TAAp wt1 wt2) | I x | BV x₁ 56 | with canonical-indeterminate-forms-arr wt1 x 57 | progress (TAAp wt1 wt2) | I x | BV y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter) 58 | progress (TAAp wt1 wt2) | I x | BV y | CIFAEHole (_ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) 59 | progress (TAAp wt1 wt2) | I x | BV y | CIFANEHole (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) 60 | progress (TAAp wt1 wt2) | I x | BV y | CIFAAp (_ , _ , _ , _ , _ , refl , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) 61 | progress (TAAp wt1 wt2) | I x | BV y | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) 62 | progress (TAAp wt1 wt2) | I x | BV y | CIFAFailedCast (_ , _ , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y)) 63 | -- if the left is a boxed value, inspect the right 64 | progress (TAAp wt1 wt2) | BV v | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2 z)) 65 | progress (TAAp wt1 wt2) | BV v | I i 66 | with canonical-boxed-forms-arr wt1 v 67 | ... | CBFLam (_ , _ , refl , _) = S (_ , Step FHOuter ITLam FHOuter) 68 | ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter) 69 | progress (TAAp wt1 wt2) | BV v | BV v₂ 70 | with canonical-boxed-forms-arr wt1 v 71 | ... | CBFLam (_ , _ , refl , _) = S (_ , Step FHOuter ITLam FHOuter) 72 | ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter) 73 | 74 | -- empty holes are indeterminate 75 | progress (TAEHole _ _ ) = I IEHole 76 | 77 | -- nonempty holes step if the innards step, indet otherwise 78 | progress (TANEHole xin wt x₁) 79 | with progress wt 80 | ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z)) 81 | ... | I x = I (INEHole (FIndet x)) 82 | ... | BV x = I (INEHole (FBoxedVal x)) 83 | 84 | -- casts 85 | progress (TACast wt con) 86 | with progress wt 87 | -- step if the innards step 88 | progress (TACast wt con) | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z)) 89 | -- if indet, inspect how the types in the cast are realted by consistency: 90 | -- if they're the same, step by ID 91 | progress (TACast wt TCRefl) | I x = S (_ , Step FHOuter ITCastID FHOuter) 92 | -- if first type is hole 93 | progress (TACast {τ1 = τ1} wt TCHole1) | I x 94 | with τ1 95 | progress (TACast wt TCHole1) | I x | b = I (ICastGroundHole GBase x) 96 | progress (TACast wt TCHole1) | I x | ⦇-⦈ = S (_ , Step FHOuter ITCastID FHOuter) 97 | progress (TACast wt TCHole1) | I x | τ11 ==> τ12 98 | with ground-decidable (τ11 ==> τ12) 99 | progress (TACast wt TCHole1) | I x₁ | .⦇-⦈ ==> .⦇-⦈ | Inl GHole = I (ICastGroundHole GHole x₁) 100 | progress (TACast wt TCHole1) | I x₁ | τ11 ==> τ12 | Inr x = S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole x))) FHOuter) 101 | -- if second type is hole 102 | progress (TACast wt (TCHole2 {b})) | I x 103 | with canonical-indeterminate-forms-hole wt x 104 | progress (TACast wt (TCHole2 {b})) | I x | CIFHEHole (_ , _ , _ , refl , f) = I (ICastHoleGround (λ _ _ ()) x GBase) 105 | progress (TACast wt (TCHole2 {b})) | I x | CIFHNEHole (_ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase) 106 | progress (TACast wt (TCHole2 {b})) | I x | CIFHAp (_ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase) 107 | progress (TACast wt (TCHole2 {b})) | I x | CIFHCast (_ , τ , refl , _) 108 | with htype-dec τ b 109 | progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , .b , refl , _ , grn , _) | Inl refl = S (_ , Step FHOuter (ITCastSucceed grn ) FHOuter) 110 | progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , _ , refl , π2 , grn , _) | Inr x = S (_ , Step FHOuter (ITCastFail grn GBase x) FHOuter) 111 | progress (TACast wt (TCHole2 {⦇-⦈}))| I x = S (_ , Step FHOuter ITCastID FHOuter) 112 | progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x 113 | with ground-decidable (τ11 ==> τ12) 114 | progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x₁ | Inl GHole 115 | with canonical-indeterminate-forms-hole wt x₁ 116 | progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHEHole (_ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole) 117 | progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHNEHole (_ , _ , _ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole) 118 | progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHAp (_ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GHole) 119 | progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , _ , GBase , _) = S (_ , Step FHOuter (ITCastFail GBase GHole (λ ())) FHOuter ) 120 | progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , _ , GHole , _) = S (_ , Step FHOuter (ITCastSucceed GHole) FHOuter) 121 | progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x₁ | Inr x = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter) 122 | -- if both are arrows 123 | progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x 124 | with htype-dec (τ1 ==> τ2) (τ1' ==> τ2') 125 | progress (TACast wt (TCArr c1 c2)) | I x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) 126 | progress (TACast wt (TCArr c1 c2)) | I x₁ | Inr x = I (ICastArr x x₁) 127 | -- boxed value cases, inspect how the casts are realted by consistency 128 | -- step by ID if the casts are the same 129 | progress (TACast wt TCRefl) | BV x = S (_ , Step FHOuter ITCastID FHOuter) 130 | -- if left is hole 131 | progress (TACast wt (TCHole1 {τ = τ})) | BV x 132 | with ground-decidable τ 133 | progress (TACast wt TCHole1) | BV x₁ | Inl g = BV (BVHoleCast g x₁) 134 | progress (TACast wt (TCHole1 {b})) | BV x₁ | Inr x = abort (x GBase) 135 | progress (TACast wt (TCHole1 {⦇-⦈})) | BV x₁ | Inr x = S (_ , Step FHOuter ITCastID FHOuter) 136 | progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₁ | Inr x 137 | with (htype-dec (τ1 ==> τ2) (⦇-⦈ ==> ⦇-⦈)) 138 | progress (TACast wt (TCHole1 {.⦇-⦈ ==> .⦇-⦈})) | BV x₂ | Inr x₁ | Inl refl = BV (BVHoleCast GHole x₂) 139 | progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₂ | Inr x₁ | Inr x = S (_ , Step FHOuter (ITGround (MGArr x)) FHOuter) 140 | -- if right is hole 141 | progress {τ = τ} (TACast wt TCHole2) | BV x 142 | with canonical-boxed-forms-hole wt x 143 | progress {τ = τ} (TACast wt TCHole2) | BV x | d' , τ' , refl , gnd , wt' 144 | with htype-dec τ τ' 145 | progress (TACast wt TCHole2) | BV x₁ | d' , τ , refl , gnd , wt' | Inl refl = S (_ , Step FHOuter (ITCastSucceed gnd) FHOuter) 146 | progress {τ = τ} (TACast wt TCHole2) | BV x₁ | _ , _ , refl , _ , _ | Inr _ 147 | with ground-decidable τ 148 | progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , gnd , _ | Inr x₁ | Inl x = S(_ , Step FHOuter (ITCastFail gnd x (flip x₁)) FHOuter) 149 | progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , _ , _ | Inr x₁ | Inr x 150 | with notground x 151 | progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr _ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) 152 | progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr x | Inr (_ , _ , refl) = S(_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter ) 153 | -- if both arrows 154 | progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x 155 | with htype-dec (τ1 ==> τ2) (τ1' ==> τ2') 156 | progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter) 157 | progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inr x = BV (BVArrCast x x₁) 158 | 159 | -- failed casts 160 | progress (TAFailedCast wt y z w) 161 | with progress wt 162 | progress (TAFailedCast wt y z w) | S (d' , Step x a q) = S (_ , Step (FHFailedCast x) a (FHFailedCast q)) 163 | progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w) 164 | progress (TAFailedCast wt y z w) | BV x = I (IFailedCast (FBoxedVal x) y z w) 165 | -------------------------------------------------------------------------------- /status.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | echo 3 | echo "\`\`\`" 4 | echo "Status as of " `date` 5 | echo "todos: " `grep -i todo * | wc -l` 6 | echo "postulates: " `grep -i postulate *.agda | wc -l` 7 | echo "red brackets:" `grep -i 'red brackets' *.agda | wc -l` 8 | echo "\`\`\`" 9 | -------------------------------------------------------------------------------- /synth-unicity.agda: -------------------------------------------------------------------------------- 1 | open import Prelude 2 | open import core 3 | open import contexts 4 | 5 | module synth-unicity where 6 | -- synthesis only produces equal types. note that there is no need for an 7 | -- analagous theorem for analytic positions because we think of 8 | -- the type as an input 9 | synthunicity : {Γ : tctx} {e : hexp} {t t' : htyp} → 10 | (Γ ⊢ e => t) 11 | → (Γ ⊢ e => t') 12 | → t == t' 13 | synthunicity (SAsc _) (SAsc _) = refl 14 | synthunicity {Γ = G} (SVar in1) (SVar in2) = ctxunicity {Γ = G} in1 in2 15 | synthunicity (SAp _ D1 MAHole _) (SAp _ D2 MAHole y) = refl 16 | synthunicity (SAp _ D1 MAHole _) (SAp _ D2 MAArr y) with synthunicity D1 D2 17 | ... | () 18 | synthunicity (SAp _ D1 MAArr _) (SAp _ D2 MAHole y) with synthunicity D1 D2 19 | ... | () 20 | synthunicity (SAp _ D1 MAArr _) (SAp _ D2 MAArr y) with synthunicity D1 D2 21 | ... | refl = refl 22 | synthunicity SEHole SEHole = refl 23 | synthunicity (SNEHole _ _) (SNEHole _ _) = refl 24 | synthunicity SConst SConst = refl 25 | synthunicity (SLam _ D1) (SLam _ D2) with synthunicity D1 D2 26 | synthunicity (SLam x₁ D1) (SLam x₂ D2) | refl = refl 27 | -------------------------------------------------------------------------------- /type-assignment-unicity.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | 6 | module type-assignment-unicity where 7 | -- type assignment only assigns one type 8 | type-assignment-unicity : {Γ : tctx} {d : ihexp} {τ' τ : htyp} {Δ : hctx} → 9 | Δ , Γ ⊢ d :: τ → 10 | Δ , Γ ⊢ d :: τ' → 11 | τ == τ' 12 | type-assignment-unicity TAConst TAConst = refl 13 | type-assignment-unicity {Γ = Γ} (TAVar x₁) (TAVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ 14 | type-assignment-unicity (TALam _ d1) (TALam _ d2) 15 | with type-assignment-unicity d1 d2 16 | ... | refl = refl 17 | type-assignment-unicity (TAAp x x₁) (TAAp y y₁) 18 | with type-assignment-unicity x y 19 | ... | refl = refl 20 | type-assignment-unicity (TAEHole {Δ = Δ} x y) (TAEHole x₁ x₂) 21 | with ctxunicity {Γ = Δ} x x₁ 22 | ... | refl = refl 23 | type-assignment-unicity (TANEHole {Δ = Δ} x d1 y) (TANEHole x₁ d2 x₂) 24 | with ctxunicity {Γ = Δ} x₁ x 25 | ... | refl = refl 26 | type-assignment-unicity (TACast d1 x) (TACast d2 x₁) 27 | with type-assignment-unicity d1 d2 28 | ... | refl = refl 29 | type-assignment-unicity (TAFailedCast x x₁ x₂ x₃) (TAFailedCast y x₄ x₅ x₆) 30 | with type-assignment-unicity x y 31 | ... | refl = refl 32 | -------------------------------------------------------------------------------- /typed-elaboration.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import lemmas-consistency 6 | open import lemmas-disjointness 7 | open import weakening 8 | 9 | module typed-elaboration where 10 | mutual 11 | typed-elaboration-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} → 12 | Γ ⊢ e ⇒ τ ~> d ⊣ Δ → 13 | Δ , Γ ⊢ d :: τ 14 | typed-elaboration-synth ESConst = TAConst 15 | typed-elaboration-synth (ESVar x₁) = TAVar x₁ 16 | typed-elaboration-synth (ESLam x₁ ex) = TALam x₁ (typed-elaboration-synth ex) 17 | typed-elaboration-synth (ESAp {Δ1 = Δ1} _ d x₁ x₂ x₃ x₄) 18 | with typed-elaboration-ana x₃ | typed-elaboration-ana x₄ 19 | ... | con1 , ih1 | con2 , ih2 = TAAp (TACast (weaken-ta-Δ1 d ih1) con1) (TACast (weaken-ta-Δ2 {Δ1 = Δ1} d ih2) con2) 20 | typed-elaboration-synth (ESEHole {Γ = Γ} {u = u}) = TAEHole (ctx-top ∅ u (Γ , ⦇-⦈) refl)(STAId (λ x τ z → z)) 21 | typed-elaboration-synth (ESNEHole {Γ = Γ} {τ = τ} {u = u} {Δ = Δ} (d1 , d2) ex) 22 | with typed-elaboration-synth ex 23 | ... | ih1 = TANEHole {Δ = Δ ,, (u , Γ , ⦇-⦈)} (ctx-top Δ u (Γ , ⦇-⦈) (d2 u (lem-domsingle _ _))) (weaken-ta-Δ1 (d1 , d2) ih1)(STAId (λ x τ₁ z → z)) 24 | typed-elaboration-synth (ESAsc x) 25 | with typed-elaboration-ana x 26 | ... | con , ih = TACast ih con 27 | 28 | typed-elaboration-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} → 29 | Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ → 30 | (τ' ~ τ) × (Δ , Γ ⊢ d :: τ') 31 | typed-elaboration-ana (EALam x₁ MAHole ex) 32 | with typed-elaboration-ana ex 33 | ... | con , D = TCHole1 , TALam x₁ D 34 | typed-elaboration-ana (EALam x₁ MAArr ex) 35 | with typed-elaboration-ana ex 36 | ... | con , D = TCArr TCRefl con , TALam x₁ D 37 | typed-elaboration-ana (EASubsume x x₁ x₂ x₃) = ~sym x₃ , typed-elaboration-synth x₂ 38 | typed-elaboration-ana (EAEHole {Γ = Γ} {u = u}) = TCRefl , TAEHole (ctx-top ∅ u (Γ , _) refl) (STAId (λ x τ z → z)) 39 | typed-elaboration-ana (EANEHole {Γ = Γ} {u = u} {τ = τ} {Δ = Δ} (d1 , d2) x) 40 | with typed-elaboration-synth x 41 | ... | ih1 = TCRefl , TANEHole {Δ = Δ ,, (u , Γ , τ)} (ctx-top Δ u (Γ , τ) (d2 u (lem-domsingle _ _)) ) (weaken-ta-Δ1 (d1 , d2) ih1) (STAId (λ x₁ τ₁ z → z)) 42 | -------------------------------------------------------------------------------- /weakening.agda: -------------------------------------------------------------------------------- 1 | open import Nat 2 | open import Prelude 3 | open import core 4 | open import contexts 5 | open import lemmas-disjointness 6 | open import exchange 7 | 8 | -- this module contains all the proofs of different weakening structural 9 | -- properties that we use for the hypothetical judgements 10 | module weakening where 11 | mutual 12 | weaken-subst-Δ : ∀{Δ1 Δ2 Γ σ Γ'} → Δ1 ## Δ2 13 | → Δ1 , Γ ⊢ σ :s: Γ' 14 | → (Δ1 ∪ Δ2) , Γ ⊢ σ :s: Γ' 15 | weaken-subst-Δ disj (STAId x) = STAId x 16 | weaken-subst-Δ disj (STASubst subst x) = STASubst (weaken-subst-Δ disj subst) (weaken-ta-Δ1 disj x) 17 | 18 | weaken-ta-Δ1 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2 19 | → Δ1 , Γ ⊢ d :: τ 20 | → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ 21 | weaken-ta-Δ1 disj TAConst = TAConst 22 | weaken-ta-Δ1 disj (TAVar x₁) = TAVar x₁ 23 | weaken-ta-Δ1 disj (TALam x₁ wt) = TALam x₁ (weaken-ta-Δ1 disj wt) 24 | weaken-ta-Δ1 disj (TAAp wt wt₁) = TAAp (weaken-ta-Δ1 disj wt) (weaken-ta-Δ1 disj wt₁) 25 | weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TAEHole {u = u} {Γ' = Γ'} x x₁) = TAEHole (x∈∪l Δ1 Δ2 u _ x ) (weaken-subst-Δ disj x₁) 26 | 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₁) 27 | weaken-ta-Δ1 disj (TACast wt x) = TACast (weaken-ta-Δ1 disj wt) x 28 | weaken-ta-Δ1 disj (TAFailedCast wt x x₁ x₂) = TAFailedCast (weaken-ta-Δ1 disj wt) x x₁ x₂ 29 | 30 | -- this is a little bit of a time saver. since ∪ is commutative on 31 | -- disjoint contexts, and we need that premise anyway in both positions, 32 | -- there's no real reason to repeat the inductive argument above 33 | weaken-ta-Δ2 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2 34 | → Δ2 , Γ ⊢ d :: τ 35 | → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ 36 | weaken-ta-Δ2 {Δ1} {Δ2} {Γ} {d} {τ} disj D = tr (λ q → q , Γ ⊢ d :: τ) (∪comm Δ2 Δ1 (##-comm disj)) (weaken-ta-Δ1 (##-comm disj) D) 37 | 38 | 39 | -- note that these statements are somewhat stronger than usual. this is 40 | -- because we don't have implcit α-conversion. this reifies the 41 | -- often-silent on paper assumption that if you collide with a bound 42 | -- variable you can just α-convert it away and not worry. 43 | mutual 44 | weaken-synth : ∀{ x Γ e τ τ'} → freshh x e 45 | → Γ ⊢ e => τ 46 | → (Γ ,, (x , τ')) ⊢ e => τ 47 | weaken-synth FRHConst SConst = SConst 48 | weaken-synth (FRHAsc frsh) (SAsc x₁) = SAsc (weaken-ana frsh x₁) 49 | weaken-synth {Γ = Γ} (FRHVar {x = x} x₁) (SVar {x = y} x₂) = SVar (x∈∪l Γ (■(x , _)) y _ x₂) 50 | weaken-synth {Γ = Γ} (FRHLam2 x₁ frsh) (SLam x₂ wt) = 51 | SLam (apart-extend1 Γ (flip x₁) x₂) 52 | (exchange-synth {Γ = Γ} (flip x₁) ((weaken-synth frsh wt))) 53 | weaken-synth FRHEHole SEHole = SEHole 54 | weaken-synth (FRHNEHole frsh) (SNEHole x₁ wt) = SNEHole x₁ (weaken-synth frsh wt) 55 | weaken-synth (FRHAp frsh frsh₁) (SAp x₁ wt x₂ x₃) = SAp x₁ (weaken-synth frsh wt) x₂ (weaken-ana frsh₁ x₃) 56 | 57 | weaken-ana : ∀{x Γ e τ τ'} → freshh x e 58 | → Γ ⊢ e <= τ 59 | → (Γ ,, (x , τ')) ⊢ e <= τ 60 | weaken-ana frsh (ASubsume x₁ x₂) = ASubsume (weaken-synth frsh x₁) x₂ 61 | weaken-ana {Γ = Γ} (FRHLam1 neq frsh) (ALam x₂ x₃ wt) = 62 | ALam (apart-extend1 Γ (flip neq) x₂) 63 | x₃ 64 | (exchange-ana {Γ = Γ} (flip neq) (weaken-ana frsh wt)) 65 | 66 | mutual 67 | weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} → 68 | envfresh x σ → 69 | Δ , Γ ⊢ σ :s: Γ' → 70 | Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ' 71 | weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) ) 72 | weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) = 73 | STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst)) 74 | (weaken-ta x₁ x₃) 75 | 76 | weaken-ta : ∀{x Γ Δ d τ τ'} → 77 | fresh x d → 78 | Δ , Γ ⊢ d :: τ → 79 | Δ , Γ ,, (x , τ') ⊢ d :: τ 80 | weaken-ta _ TAConst = TAConst 81 | weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃) 82 | weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y 83 | weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl) 84 | 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)) 85 | weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁) 86 | weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃) 87 | weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃) 88 | weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁ 89 | weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃ 90 | --------------------------------------------------------------------------------