├── .gitignore ├── LICENSE ├── Prelude.agda ├── Prelude ├── Bottom.agda ├── Fin.agda ├── Nat.agda ├── PropositionalEquality.agda ├── Sigma.agda ├── Sum.agda └── Vector.agda ├── README.md ├── Substitution.agda ├── SystemF.agda └── SystemF ├── Preservation.agda ├── Progress.agda ├── Semantics.agda ├── Substitution.agda ├── Syntax.agda ├── TypeReduction.agda └── Typing.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2025 Olle Fredriksson 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /Prelude.agda: -------------------------------------------------------------------------------- 1 | open import Prelude.Bottom public 2 | open import Prelude.Fin public hiding (lift) 3 | open import Prelude.Nat public 4 | open import Prelude.PropositionalEquality hiding (subst) public 5 | open import Prelude.Sigma public 6 | open import Prelude.Sum public 7 | open import Prelude.Vector public -------------------------------------------------------------------------------- /Prelude/Bottom.agda: -------------------------------------------------------------------------------- 1 | module Prelude.Bottom where 2 | 3 | data ⊥ : Set where 4 | 5 | ¬_ : Set → Set 6 | ¬ A = A → ⊥ 7 | 8 | infix 9 ¬_ 9 | 10 | absurd : ∀ {A : Set} → ⊥ → A 11 | absurd () -------------------------------------------------------------------------------- /Prelude/Fin.agda: -------------------------------------------------------------------------------- 1 | module Prelude.Fin where 2 | 3 | open import Prelude.Nat 4 | open import Prelude.PropositionalEquality 5 | 6 | data Fin : (n : ℕ) → Set where 7 | zero : ∀ {n} → Fin (succ n) 8 | succ : ∀ {n} → Fin n → Fin (succ n) 9 | 10 | lift : ∀ {m n} k → (Fin m → Fin n) → Fin (k + m) → Fin (k + n) 11 | lift zero f x = f x 12 | lift (succ k) f zero = zero 13 | lift (succ k) f (succ x) = succ (lift k f x) 14 | 15 | lift-commutes : ∀ {n} k l (x : Fin (l + (k + n))) → lift l succ (lift l (lift k succ) x) ≡ lift l (lift (succ k) succ) (lift l succ x) 16 | lift-commutes k zero x = refl 17 | lift-commutes k (succ l) zero = refl 18 | lift-commutes k (succ l) (succ x) = cong succ (lift-commutes k l x) 19 | 20 | toℕ : ∀ {n} → Fin n → ℕ 21 | toℕ zero = zero 22 | toℕ (succ x) = succ (toℕ x) -------------------------------------------------------------------------------- /Prelude/Nat.agda: -------------------------------------------------------------------------------- 1 | module Prelude.Nat where 2 | 3 | data ℕ : Set where 4 | zero : ℕ 5 | succ : ℕ → ℕ 6 | 7 | {-# BUILTIN NATURAL ℕ #-} 8 | 9 | _+_ : ℕ → ℕ → ℕ 10 | zero + n = n 11 | succ m + n = succ (m + n) 12 | 13 | infixr 4 _+_ -------------------------------------------------------------------------------- /Prelude/PropositionalEquality.agda: -------------------------------------------------------------------------------- 1 | module Prelude.PropositionalEquality where 2 | 3 | open import Agda.Builtin.Equality public 4 | 5 | trans : {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z 6 | trans refl refl = refl 7 | 8 | sym : {A : Set} {x y : A} → x ≡ y → y ≡ x 9 | sym refl = refl 10 | 11 | cong : ∀ {l₁ l₂} {A : Set l₁} {B : Set l₂} {x y : A} (f : A → B) → x ≡ y → f x ≡ f y 12 | cong _ refl = refl 13 | 14 | cong₂ : {A B C : Set} {x y : A} {x' y' : B} (f : A → B → C) → x ≡ y → x' ≡ y' → f x x' ≡ f y y' 15 | cong₂ f refl refl = refl 16 | 17 | subst : ∀ {l₁ l₂} {A : Set l₁} (P : A → Set l₂) {x y : A} → x ≡ y → P x → P y 18 | subst P refl p = p 19 | 20 | subst₂ : ∀ {l₁ l₂} {A : Set l₁} {B : Set l₂} (P : A → B → Set) {x y : A} {x' y' : B} → x ≡ y → x' ≡ y' → P x x' → P y y' 21 | subst₂ P refl refl p = p 22 | 23 | _≡⟨_⟩_ : ∀ {A : Set} (x : A) {y z} → x ≡ y → y ≡ z → x ≡ z 24 | x ≡⟨ refl ⟩ p = p 25 | 26 | _≡⟨⟩_ : ∀ {A : Set} {y} (x : A) → x ≡ y → x ≡ y 27 | x ≡⟨⟩ p = p 28 | 29 | infixr 2 _≡⟨_⟩_ 30 | infixr 2 _≡⟨⟩_ 31 | 32 | _∎ : ∀ {A : Set} (x : A) → x ≡ x 33 | x ∎ = refl 34 | 35 | infix 3 _∎ -------------------------------------------------------------------------------- /Prelude/Sigma.agda: -------------------------------------------------------------------------------- 1 | module Prelude.Sigma where 2 | 3 | open import Agda.Builtin.Sigma public 4 | 5 | _×_ : Set → Set → Set 6 | A × B = Σ A (λ _ → B) 7 | 8 | infixr 2 _×_ -------------------------------------------------------------------------------- /Prelude/Sum.agda: -------------------------------------------------------------------------------- 1 | module Prelude.Sum where 2 | 3 | data _⊎_ (A B : Set) : Set where 4 | inl : A → A ⊎ B 5 | inr : B → A ⊎ B 6 | 7 | infixr 2 _⊎_ -------------------------------------------------------------------------------- /Prelude/Vector.agda: -------------------------------------------------------------------------------- 1 | module Prelude.Vector where 2 | 3 | open import Prelude.Fin 4 | open import Prelude.Nat 5 | open import Prelude.PropositionalEquality 6 | open import Prelude.Sigma 7 | 8 | data Vector (A : Set) : ℕ → Set where 9 | [] : Vector A zero 10 | _∷_ : {n : ℕ} → A → Vector A n → Vector A (succ n) 11 | 12 | infixr 5 _∷_ 13 | 14 | map : {A B : Set} → (A -> B) → {n : ℕ} → Vector A n → Vector B n 15 | map f [] = [] 16 | map f (x ∷ xs) = f x ∷ map f xs 17 | 18 | lookup : ∀ {A n} → Vector A n → Fin n → A 19 | lookup (x ∷ xs) zero = x 20 | lookup (x ∷ xs) (succ i) = lookup xs i 21 | 22 | data All {A : Set} (P : A → Set) : {n : ℕ} → Vector A n → Set where 23 | [] : All P [] 24 | _∷_ : ∀ {n x} {xs : Vector A n} → P x → All P xs → All P (x ∷ xs) 25 | 26 | lookup-map : ∀ {n A B} (f : A → B) (xs : Vector A n) i → lookup (map f xs) i ≡ f (lookup xs i) 27 | lookup-map f (x ∷ xs) zero = refl 28 | lookup-map f (x ∷ xs) (succ i) = lookup-map f xs i 29 | 30 | map-map : ∀ {n A B C} (f : B → C) (g : A → B) (xs : Vector A n) → map f (map g xs) ≡ map (λ x → f (g x)) xs 31 | map-map f g [] = refl 32 | map-map f g (x ∷ xs) rewrite map-map f g xs = refl 33 | 34 | map-ext : ∀ {A B : Set} {n} (f g : A → B) (xs : Vector A n) → (∀ x → f x ≡ g x) → map f xs ≡ map g xs 35 | map-ext f g [] p = refl 36 | map-ext f g (x ∷ xs) p rewrite p x | map-ext f g xs p = refl 37 | 38 | map-id : ∀ {A n} (xs : Vector A n) → map (λ x → x) xs ≡ xs 39 | map-id [] = refl 40 | map-id (x ∷ xs) = cong₂ _∷_ refl (map-id xs) 41 | 42 | lookup-ext : ∀ {A n} (xs ys : Vector A n) → (∀ x → lookup xs x ≡ lookup ys x) → xs ≡ ys 43 | lookup-ext [] [] p = refl 44 | lookup-ext (x ∷ xs) (y ∷ ys) p = cong₂ _∷_ (p zero) (lookup-ext xs ys (λ x → p (succ x))) 45 | 46 | data ZipWith {A B : Set} (f : A → B → Set) : {n : ℕ} → Vector A n → Vector B n → Set where 47 | [] : ZipWith f [] [] 48 | _∷_ : ∀ {n a b} {as : Vector A n} {bs : Vector B n} → f a b → ZipWith f as bs → ZipWith f (a ∷ as) (b ∷ bs) 49 | 50 | _++_ : ∀ {A m n} → Vector A m → Vector A n → Vector A (m + n) 51 | [] ++ ys = ys 52 | (x ∷ xs) ++ ys = x ∷ (xs ++ ys) 53 | 54 | infixr 4 _++_ 55 | 56 | take : ∀ {A m} (n : Fin m) → Vector A m → Vector A (toℕ n) 57 | take zero (x ∷ xs) = [] 58 | take (succ n) (x ∷ xs) = x ∷ take n xs 59 | 60 | update : ∀ {A m} (n : Fin m) → A → Vector A m → Vector A m 61 | update zero y (x ∷ xs) = y ∷ xs 62 | update (succ n) y (x ∷ xs) = x ∷ update n y xs 63 | 64 | lookup-zip-with : ∀ {A B n} {f : A → B → Set} {xs : Vector A n} {ys : Vector B n} → ZipWith f xs ys → ∀ i → f (lookup xs i) (lookup ys i) 65 | lookup-zip-with (x ∷ _) zero = x 66 | lookup-zip-with (_ ∷ xs) (succ i) = lookup-zip-with xs i -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # System Fω in Agda 2 | 3 | This repository contains a formalization of the higher-order polymorphic lambda calculus known as System Fω, plus extensions, in Agda. 4 | 5 | In summary, there's a bit of syntax, some semantics, typing, kinding, type soundness (progress and preservation), and a bunch of tedious proofs about substitutions. 6 | 7 | The (admittedly admissible) extensions are: projectible products, matchable sums, and unpackable existential types. 8 | 9 | It's been checked with Agda 2.7.0.1. Because I'm a masochist (or machochist?), this thing does not use the standard library, though the substitution module is partly stolen therefrom. 10 | 11 | --- 12 | 13 | © 2025 Olle Fredriksson 14 | -------------------------------------------------------------------------------- /Substitution.agda: -------------------------------------------------------------------------------- 1 | -- An adaptation of Data.Fin.Substitution from Agda's standard library. 2 | open import Prelude 3 | import Prelude.Fin as Fin 4 | 5 | Subst : (ℕ → Set) → ℕ → ℕ → Set 6 | Subst T m n = Vector (T n) m 7 | 8 | data Substs (T : ℕ → Set) : ℕ → ℕ → Set where 9 | [] : ∀ {n} → Substs T n n 10 | _∷_ : ∀ {m n o} → Subst T n o → Substs T m n → Substs T m o 11 | 12 | infixr 5 _∷_ 13 | 14 | extensionality : ∀ {T m n} {σ₁ σ₂ : Subst T m n} → 15 | (∀ i → lookup σ₁ i ≡ lookup σ₂ i) → σ₁ ≡ σ₂ 16 | extensionality = lookup-ext _ _ 17 | 18 | record Weaken (T : ℕ → Set) : Set where 19 | field 20 | weaken : ∀ {n} → T n → T (succ n) 21 | 22 | weaken-fin : Weaken Fin 23 | weaken-fin = record 24 | { weaken = succ 25 | } 26 | 27 | record Var (T : ℕ → Set) : Set where 28 | field 29 | super-weaken : Weaken T 30 | var : ∀ {n} → Fin n → T n 31 | 32 | open Weaken super-weaken public 33 | 34 | field 35 | weaken-var : ∀ {n} (x : Fin n) → weaken (var x) ≡ var (succ x) 36 | 37 | lift : ∀ {m n} k → Subst T m n → Subst T (k + m) (k + n) 38 | lift zero σ = σ 39 | lift (succ k) σ = var zero ∷ map weaken (lift k σ) 40 | 41 | lifts : ∀ {m n} k → Substs T m n → Substs T (k + m) (k + n) 42 | lifts k [] = [] 43 | lifts k (σ ∷ σs) = lift k σ ∷ lifts k σs 44 | 45 | id : ∀ {n} → Subst T n n 46 | id {n = zero} = [] 47 | id {n = succ n} = lift 1 id 48 | 49 | weakening : ∀ {n} → Subst T n (succ n) 50 | weakening = map weaken id 51 | 52 | instantiation : ∀ {n} → T n → Subst T (succ n) n 53 | instantiation t = t ∷ id 54 | 55 | lift-id : ∀ {n} k → lift k (id {n = n}) ≡ id 56 | lift-id zero = refl 57 | lift-id (succ k) = cong₂ _∷_ refl (cong (map weaken) (lift-id k)) 58 | 59 | lookup-map-weaken : ∀ {m n} {σ : Subst T m n} x {y} 60 | → lookup σ x ≡ var y 61 | → lookup (map weaken σ) x ≡ var (succ y) 62 | lookup-map-weaken {σ = σ} x {y = y} l = 63 | lookup (map weaken σ) x 64 | ≡⟨ lookup-map weaken σ x ⟩ 65 | weaken (lookup σ x) 66 | ≡⟨ cong weaken l ⟩ 67 | weaken (var y) 68 | ≡⟨ weaken-var y ⟩ 69 | var (succ y) 70 | ∎ 71 | 72 | lookup-id : ∀ {n} (x : Fin n) → lookup id x ≡ var x 73 | lookup-weakening : ∀ {n} (x : Fin n) → lookup weakening x ≡ var (succ x) 74 | 75 | lookup-id zero = refl 76 | lookup-id (succ x) = lookup-weakening x 77 | 78 | lookup-weakening x = lookup-map-weaken {σ = id} x (lookup-id x) 79 | 80 | lookup-lift : ∀ {m n σ} (f : Fin m → Fin n) 81 | → (∀ x → lookup σ x ≡ var (f x)) 82 | → ∀ k x → lookup (lift k σ) x ≡ var (Fin.lift k f x) 83 | lookup-lift f l zero x = l x 84 | lookup-lift f l (succ k) zero = refl 85 | lookup-lift {σ = σ} f l (succ k) (succ x) = 86 | lookup-map-weaken {σ = lift k σ} x (lookup-lift f l k x) 87 | 88 | lookup-lift-lift : ∀ {m n σ} (f : Fin m → Fin n) 89 | → (∀ x → lookup σ (f x) ≡ var x) 90 | → ∀ k x → lookup (lift k σ) (Fin.lift k f x) ≡ var x 91 | lookup-lift-lift f l zero x = l x 92 | lookup-lift-lift f l (succ k) zero = refl 93 | lookup-lift-lift {σ = σ} f l (succ k) (succ x) = 94 | lookup-map-weaken {σ = lift k σ} (Fin.lift k f x) (lookup-lift-lift f l k x) 95 | 96 | lookup-lift-weakening : ∀ {n} k (x : Fin (k + n)) 97 | → lookup (lift k weakening) x ≡ var (Fin.lift k succ x) 98 | lookup-lift-weakening k x = lookup-lift succ lookup-weakening k x 99 | 100 | lookup-lift-lift-weakening : ∀ {n} k l (x : Fin (k + (l + n))) 101 | → lookup (lift k (lift l weakening)) x ≡ var (Fin.lift k (Fin.lift l succ) x) 102 | lookup-lift-lift-weakening k l = lookup-lift (Fin.lift l succ) (lookup-lift-weakening l) k 103 | 104 | lookup-lift-instantiation : ∀ {n t} k (x : Fin (k + n)) 105 | → lookup (lift k (instantiation t)) (Fin.lift k succ x) ≡ var x 106 | lookup-lift-instantiation = lookup-lift-lift succ lookup-id 107 | 108 | lookup-lift-map-weaken : ∀ {m n} {σ : Subst T m n} k x 109 | → lookup (lift k (map weaken σ)) x ≡ lookup (lift k (lift 1 σ)) (Fin.lift k succ x) 110 | lookup-lift-map-weaken zero x = refl 111 | lookup-lift-map-weaken (succ k) zero = refl 112 | lookup-lift-map-weaken {σ = σ} (succ k) (succ x) = 113 | lookup (map weaken (lift k (map weaken σ))) x 114 | ≡⟨ lookup-map weaken (lift k (map weaken σ)) x ⟩ 115 | weaken (lookup (lift k (map weaken σ)) x) 116 | ≡⟨ cong weaken (lookup-lift-map-weaken k x) ⟩ 117 | weaken (lookup (lift k (lift 1 σ)) (Fin.lift k succ x)) 118 | ≡⟨ sym (lookup-map weaken (lift k (lift 1 σ)) (Fin.lift k succ x)) ⟩ 119 | lookup (map weaken (lift k (lift 1 σ))) (Fin.lift k succ x) 120 | ∎ 121 | 122 | var-fin : Var Fin 123 | var-fin = record 124 | { super-weaken = weaken-fin 125 | ; var = λ x → x 126 | ; weaken-var = λ x → refl 127 | } 128 | 129 | record Hoist (S T : ℕ → Set) : Set where 130 | field 131 | super-var : Var S 132 | hoist : ∀ {n} → S n → T n 133 | 134 | open Var super-var public 135 | 136 | hoist-fin : ∀ {T} → Var T → Hoist Fin T 137 | hoist-fin var-t = record 138 | { super-var = var-fin 139 | ; hoist = var 140 | } 141 | where open Var var-t 142 | 143 | hoist-self : ∀ {T} → Var T → Hoist T T 144 | hoist-self var-t = record 145 | { super-var = var-t 146 | ; hoist = λ t → t 147 | } 148 | 149 | record Substitute (S T : ℕ → Set) : Set where 150 | field 151 | subst : ∀ {m n} → Subst S m n → T m → T n 152 | 153 | substs : ∀ {m n} → Substs S m n → T m → T n 154 | substs [] t = t 155 | substs (σ ∷ σs) t = subst σ (substs σs t) 156 | 157 | compose : ∀ {m n o} → Subst T m n → Subst S n o → Subst T m o 158 | compose σ₁ σ₂ = map (subst σ₂) σ₁ 159 | 160 | record Instantiate {S T : ℕ → Set} (var : Var S) (substitute : Substitute S T) : Set where 161 | open Substitute substitute public 162 | open Var var public 163 | 164 | instantiate : ∀ {n} → S n → T (succ n) → T n 165 | instantiate s = subst (instantiation s) 166 | 167 | make-instantiate : ∀ {S T} (var : Var S) (substitute : Substitute S T) → Instantiate var substitute 168 | make-instantiate _ _ = record {} 169 | 170 | record SubstituteSelf (T : ℕ → Set) : Set₁ where 171 | field 172 | super-var : Var T 173 | substitute : ∀ {S} → Hoist S T → Substitute S T 174 | 175 | open Instantiate (make-instantiate super-var (substitute (hoist-self super-var))) public 176 | module Renaming = Instantiate (make-instantiate var-fin (substitute (hoist-fin super-var))) 177 | 178 | field 179 | subst-var-hoist : ∀ {S} (hoist : Hoist S T) {n n' x} {σ : Subst S n n'} 180 | → let module SS = Substitute (substitute hoist) 181 | module H = Hoist hoist 182 | in SS.subst σ (var x) ≡ H.hoist (lookup σ x) 183 | substs-var-ext : ∀ {S₁ S₂} (hoist₁ : Hoist S₁ T) (hoist₂ : Hoist S₂ T) 184 | → ∀ {m n} (σ₁ : Substs S₁ m n) (σ₂ : Substs S₂ m n) 185 | → let 186 | module SS₁ = Instantiate (make-instantiate (Hoist.super-var hoist₁) (substitute hoist₁)) 187 | module SS₂ = Instantiate (make-instantiate (Hoist.super-var hoist₂) (substitute hoist₂)) 188 | in (∀ k (x : Fin (k + m)) → SS₁.substs (SS₁.lifts k σ₁) (var x) ≡ SS₂.substs (SS₂.lifts k σ₂) (var x)) 189 | → ∀ k (t : T (k + m)) → SS₁.substs (SS₁.lifts k σ₁) t ≡ SS₂.substs (SS₂.lifts k σ₂) t 190 | weaken-rename : ∀ {n} {t : T n} → weaken t ≡ Renaming.subst Renaming.weakening t 191 | 192 | subst-var : ∀ {n n' x} {σ : Subst T n n'} → subst σ (var x) ≡ lookup σ x 193 | subst-var = subst-var-hoist (hoist-self super-var) 194 | 195 | substs-var-ext-self : ∀ {m n} (σ₁ : Substs T m n) (σ₂ : Substs T m n) 196 | → (∀ k (x : Fin (k + m)) → substs (lifts k σ₁) (var x) ≡ substs (lifts k σ₂) (var x)) 197 | → ∀ k (t : T (k + m)) → substs (lifts k σ₁) t ≡ substs (lifts k σ₂) t 198 | substs-var-ext-self = substs-var-ext (hoist-self super-var) (hoist-self super-var) 199 | 200 | composes : ∀ {m n} → Substs T m n → Subst T m n 201 | composes [] = id 202 | composes (σ ∷ []) = σ 203 | composes (σ₁ ∷ σ₂ ∷ σs) = compose (composes (σ₂ ∷ σs)) σ₁ 204 | 205 | lookup-compose : ∀ {m n o} {σ₁ : Subst T m n} {σ₂ : Subst T n o} x 206 | → lookup (compose σ₁ σ₂) x ≡ subst σ₂ (lookup σ₁ x) 207 | lookup-compose {σ₁ = σ₁} {σ₂ = σ₂} x = lookup-map (subst σ₂) σ₁ x 208 | 209 | lookup-composes : ∀ {m n} (σs : Substs T m n) x 210 | → lookup (composes σs) x ≡ substs σs (var x) 211 | lookup-composes [] x = lookup-id x 212 | lookup-composes (σ ∷ []) x = sym subst-var 213 | lookup-composes (σ ∷ σ' ∷ σs) x = 214 | lookup (compose (composes (σ' ∷ σs)) σ) x 215 | ≡⟨ lookup-compose {σ₁ = composes (σ' ∷ σs)} x ⟩ 216 | subst σ (lookup (composes (σ' ∷ σs)) x) 217 | ≡⟨ cong (subst σ) (lookup-composes (σ' ∷ σs) x) ⟩ 218 | subst σ (substs (σ' ∷ σs) (var x)) 219 | ≡⟨⟩ 220 | substs (σ ∷ σ' ∷ σs) (var x) 221 | ∎ 222 | 223 | substs-ext : ∀ {m n} (σ₁ : Substs T m n) (σ₂ : Substs T m n) 224 | → (∀ k → composes (lifts k σ₁) ≡ composes (lifts k σ₂)) 225 | → ∀ k (t : T (k + m)) → substs (lifts k σ₁) t ≡ substs (lifts k σ₂) t 226 | substs-ext σ₁ σ₂ h = substs-var-ext-self σ₁ σ₂ λ k x → 227 | substs (lifts k σ₁) (var x) 228 | ≡⟨ sym (lookup-composes (lifts k σ₁) x) ⟩ 229 | lookup (composes (lifts k σ₁)) x 230 | ≡⟨ cong (λ p → lookup p x) (h k) ⟩ 231 | lookup (composes (lifts k σ₂)) x 232 | ≡⟨ lookup-composes (lifts k σ₂) x ⟩ 233 | substs (lifts k σ₂) (var x) 234 | ∎ 235 | 236 | subst-id : ∀ {n} (t : T n) → subst id t ≡ t 237 | subst-id = substs-ext (id ∷ []) [] lift-id 0 238 | 239 | compose-id₂ : ∀ {m n} {σ : Subst T m n} → compose σ id ≡ σ 240 | compose-id₂ {σ = σ} = 241 | map (subst id) σ 242 | ≡⟨ map-ext (subst id) (λ t → t) σ subst-id ⟩ 243 | map (λ t → t) σ 244 | ≡⟨ map-id σ ⟩ 245 | σ 246 | ∎ 247 | 248 | compose-id₁ : ∀ {m n} {σ : Subst T m n} → compose id σ ≡ σ 249 | compose-id₁ {σ = σ} = extensionality {T = T} λ x → 250 | lookup (compose id σ) x 251 | ≡⟨ lookup-compose {σ₁ = id} x ⟩ 252 | subst σ (lookup id x) 253 | ≡⟨ cong (subst σ) (lookup-id x) ⟩ 254 | subst σ (var x) 255 | ≡⟨ subst-var ⟩ 256 | lookup σ x 257 | ∎ 258 | 259 | lookup-compose-lift-weakening : ∀ {m n} k {x} {σ : Subst T (k + succ m) n} 260 | → lookup (compose (lift k weakening) σ) x ≡ lookup σ (Fin.lift k succ x) 261 | lookup-compose-lift-weakening k {x = x} {σ = σ} = 262 | lookup (compose (lift k weakening) σ) x 263 | ≡⟨ lookup-compose {σ₁ = lift k weakening} x ⟩ 264 | subst σ (lookup (lift k weakening) x) 265 | ≡⟨ cong (subst σ) (lookup-lift-weakening k x) ⟩ 266 | subst σ (var (Fin.lift k succ x)) 267 | ≡⟨ subst-var ⟩ 268 | lookup σ (Fin.lift k succ x) 269 | ∎ 270 | 271 | compose-lift-lift-weakening : ∀ {n} k l 272 | → compose (lift l (lift k (weakening {n = n}))) (lift l weakening) 273 | ≡ compose (lift l weakening) (lift l (lift (succ k) weakening)) 274 | compose-lift-lift-weakening k l = extensionality {T = T} λ x → 275 | lookup (compose (lift l (lift k weakening)) (lift l weakening)) x 276 | ≡⟨ lookup-compose {σ₁ = lift l (lift k weakening)} x ⟩ 277 | subst (lift l weakening) (lookup (lift l (lift k weakening)) x) 278 | ≡⟨ cong (subst _) (lookup-lift-lift-weakening l k x) ⟩ 279 | subst (lift l weakening) (var (Fin.lift l (Fin.lift k succ) x)) 280 | ≡⟨ subst-var ⟩ 281 | lookup (lift l weakening) (Fin.lift l (Fin.lift k succ) x) 282 | ≡⟨ lookup-lift-weakening l (Fin.lift l (Fin.lift k succ) x) ⟩ 283 | var (Fin.lift l succ (Fin.lift l (Fin.lift k succ) x)) 284 | ≡⟨ cong var (lift-commutes k l x) ⟩ 285 | var (Fin.lift l (Fin.lift (succ k) succ) (Fin.lift l succ x)) 286 | ≡⟨ sym (lookup-lift-lift-weakening l (succ k) (Fin.lift l succ x)) ⟩ 287 | lookup (lift l (lift (succ k) weakening)) (Fin.lift l succ x) 288 | ≡⟨ sym subst-var ⟩ 289 | subst (lift l (lift (succ k) weakening)) (var (Fin.lift l succ x)) 290 | ≡⟨ cong (subst _) (sym (lookup-lift-weakening l x)) ⟩ 291 | subst (lift l (lift (succ k) weakening)) (lookup (lift l weakening) x) 292 | ≡⟨ sym (lookup-compose {σ₁ = lift l weakening} x) ⟩ 293 | lookup (compose (lift l weakening) (lift l (lift (succ k) weakening))) x 294 | ∎ 295 | 296 | compose-lift-weakening-instantiation : ∀ {n} {t : T n} k 297 | → compose (lift k weakening) (lift k (instantiation t)) ≡ id 298 | compose-lift-weakening-instantiation {t = t} k = extensionality {T = T} λ x → 299 | lookup (compose (lift k weakening) (lift k (instantiation t))) x 300 | ≡⟨ lookup-compose-lift-weakening k ⟩ 301 | lookup (lift k (instantiation t)) (Fin.lift k succ x) 302 | ≡⟨ lookup-lift-instantiation k x ⟩ 303 | var x 304 | ≡⟨ sym (lookup-id x) ⟩ 305 | lookup id x 306 | ∎ 307 | 308 | compose-weakening-instantiation : ∀ {n} {t : T n} 309 | → compose weakening (instantiation t) ≡ id 310 | compose-weakening-instantiation = compose-lift-weakening-instantiation 0 311 | 312 | renaming-subst : ∀ {m m'} {σ : Subst Fin m m'} {t} 313 | → Renaming.subst σ t ≡ subst (map var σ) t 314 | renaming-subst {σ = σ} {t = t} = 315 | substs-var-ext (hoist-fin super-var) (hoist-self super-var) (σ ∷ []) (map var σ ∷ []) 316 | (λ k x → 317 | Renaming.subst (Renaming.lift k σ) (var x) 318 | ≡⟨ subst-var-hoist (hoist-fin super-var) ⟩ 319 | var (lookup (Renaming.lift k σ) x) 320 | ≡⟨ cong var (Renaming.lookup-lift (lookup σ) (λ _ → refl) k x) ⟩ 321 | var (Fin.lift k (lookup σ) x) 322 | ≡⟨ sym (lookup-lift (lookup σ) (lookup-map var σ) k x) ⟩ 323 | lookup (lift k (map var σ)) x 324 | ≡⟨ sym subst-var ⟩ 325 | subst (lift k (map var σ)) (var x) 326 | ∎ 327 | ) 328 | 0 t 329 | 330 | map-var-renaming-id : ∀ {n} → map var (Renaming.id {n = n}) ≡ id 331 | map-var-renaming-id {n = zero} = refl 332 | map-var-renaming-id {n = succ n} = cong (_∷_ (var zero)) ( 333 | map var (map succ Renaming.id) 334 | ≡⟨ map-map var succ Renaming.id ⟩ 335 | map (λ x → var (succ x)) Renaming.id 336 | ≡⟨ map-ext (λ x → var (succ x)) (λ x → weaken (var x)) Renaming.id (λ x → sym (weaken-var x)) ⟩ 337 | map (λ x → weaken (var x)) Renaming.id 338 | ≡⟨ sym (map-map weaken var Renaming.id) ⟩ 339 | map weaken (map var Renaming.id) 340 | ≡⟨ cong (map weaken) map-var-renaming-id ⟩ 341 | map weaken id 342 | ∎ 343 | ) 344 | 345 | map-var-renaming-weakening : ∀ {n} → map var (Renaming.weakening {n = n}) ≡ weakening 346 | map-var-renaming-weakening = 347 | map var (map Renaming.weaken Renaming.id) 348 | ≡⟨ map-map var Renaming.weaken Renaming.id ⟩ 349 | map (λ x → var (succ x)) Renaming.id 350 | ≡⟨ map-ext (λ x → var (succ x)) (λ x → weaken (var x)) Renaming.id (λ x → sym (weaken-var x)) ⟩ 351 | map (λ x → weaken (var x)) Renaming.id 352 | ≡⟨ sym (map-map weaken var Renaming.id) ⟩ 353 | map weaken (map var Renaming.id) 354 | ≡⟨ cong (map weaken) map-var-renaming-id ⟩ 355 | map weaken id 356 | ∎ 357 | 358 | weaken-subst : ∀ {n} {t : T n} → weaken t ≡ subst weakening t 359 | weaken-subst {t = t} = 360 | weaken t 361 | ≡⟨ weaken-rename ⟩ 362 | Renaming.subst Renaming.weakening t 363 | ≡⟨ renaming-subst ⟩ 364 | subst (map var Renaming.weakening) t 365 | ≡⟨ cong (λ p → subst p t) map-var-renaming-weakening ⟩ 366 | subst weakening t 367 | ∎ 368 | 369 | map-var-renaming-lift : ∀ {m n} {σ : Subst Fin m n} k → map var (Renaming.lift k σ) ≡ lift k (map var σ) 370 | map-var-renaming-lift zero = refl 371 | map-var-renaming-lift {σ = σ} (succ k) = cong (_∷_ (var zero)) ( 372 | map var (map succ (Renaming.lift k σ)) 373 | ≡⟨ map-map var succ (Renaming.lift k σ) ⟩ 374 | map (λ x → var (succ x)) (Renaming.lift k σ) 375 | ≡⟨ map-ext (λ x → var (succ x)) (λ x → weaken (var x)) (Renaming.lift k σ) (λ x → sym (weaken-var x)) ⟩ 376 | map (λ x → weaken (var x)) (Renaming.lift k σ) 377 | ≡⟨ sym (map-map weaken var (Renaming.lift k σ)) ⟩ 378 | map weaken (map var (Renaming.lift k σ)) 379 | ≡⟨ cong (map weaken) (map-var-renaming-lift k) ⟩ 380 | map weaken (lift k (map var σ)) 381 | ∎ 382 | ) 383 | 384 | private 385 | lift-1-distributes : ∀ {m n o} {σ₁ : Subst T m n} {σ₂ : Subst T n o} 386 | → (∀ t → weaken (subst σ₂ t) ≡ subst (lift 1 σ₂) (weaken t)) 387 | → lift 1 (compose σ₁ σ₂) ≡ compose (lift 1 σ₁) (lift 1 σ₂) 388 | lift-1-distributes {σ₁ = σ₁} {σ₂ = σ₂} h = 389 | lift 1 (compose σ₁ σ₂) 390 | ≡⟨⟩ 391 | var zero ∷ map weaken (compose σ₁ σ₂) 392 | ≡⟨ cong₂ _∷_ (sym subst-var) lemma ⟩ 393 | subst (lift 1 σ₂) (var zero) ∷ compose (map weaken σ₁) (lift 1 σ₂) 394 | ≡⟨⟩ 395 | compose (lift 1 σ₁) (lift 1 σ₂) 396 | ∎ 397 | where 398 | lemma = 399 | map weaken (compose σ₁ σ₂) 400 | ≡⟨ map-map weaken (subst σ₂) σ₁ ⟩ 401 | map (λ t → weaken (subst σ₂ t)) σ₁ 402 | ≡⟨ map-ext (λ t → weaken (subst σ₂ t)) (λ t → subst (lift 1 σ₂) (weaken t)) σ₁ h ⟩ 403 | map (λ t → subst (lift 1 σ₂) (weaken t)) σ₁ 404 | ≡⟨ sym (map-map (subst (lift 1 σ₂)) weaken σ₁) ⟩ 405 | compose (map weaken σ₁) (var zero ∷ map weaken σ₂) 406 | ∎ 407 | 408 | lift-distributes' : ∀ {m n o} {σ₁ : Subst T m n} {σ₂ : Subst T n o} 409 | → (∀ k t → weaken (subst (lift k σ₂) t) ≡ subst (lift (succ k) σ₂) (weaken t)) 410 | → ∀ k → lift k (compose σ₁ σ₂) ≡ compose (lift k σ₁) (lift k σ₂) 411 | lift-distributes' {σ₁ = σ₁} {σ₂ = σ₂} h zero = refl 412 | lift-distributes' {σ₁ = σ₁} {σ₂ = σ₂} h (succ k) = 413 | lift (succ k) (compose σ₁ σ₂) 414 | ≡⟨ cong (lift 1) (lift-distributes' h k) ⟩ 415 | lift 1 (compose (lift k σ₁) (lift k σ₂)) 416 | ≡⟨ lift-1-distributes (h k) ⟩ 417 | compose (lift (succ k) σ₁) (lift (succ k) σ₂) 418 | ∎ 419 | 420 | map-weaken : ∀ {m n} {σ : Subst T m n} → map weaken σ ≡ compose σ weakening 421 | map-weaken {σ = σ} = 422 | map weaken σ 423 | ≡⟨ map-ext weaken (subst weakening) σ (λ _ → weaken-subst) ⟩ 424 | compose σ weakening 425 | ∎ 426 | 427 | compose-lift-weakening : ∀ {m n} {σ : Subst T m n} k 428 | → compose (lift k σ) (lift k weakening) ≡ compose (lift k weakening) (lift k (lift 1 σ)) 429 | compose-lift-weakening {σ = σ} k = 430 | compose (lift k σ) (lift k weakening) 431 | ≡⟨ sym (lift-distributes' lemma₁ k) ⟩ 432 | lift k (compose σ weakening) 433 | ≡⟨ cong (lift k) (sym (map-weaken)) ⟩ 434 | lift k (map weaken σ) 435 | ≡⟨ sym lemma₂ ⟩ 436 | compose (lift k weakening) (lift k (lift 1 σ)) 437 | ∎ 438 | where 439 | lemma₁ : ∀ k t → weaken (subst (lift k weakening) t) ≡ subst (lift (succ k) weakening) (weaken t) 440 | lemma₁ k t = 441 | weaken (subst (lift k weakening) t) 442 | ≡⟨ weaken-subst ⟩ 443 | subst weakening (subst (lift k weakening) t) 444 | ≡⟨ substs-ext (weakening ∷ lift k weakening ∷ []) (lift (succ k) weakening ∷ weakening ∷ []) (λ l → compose-lift-lift-weakening k l) 0 t ⟩ 445 | subst (lift (succ k) weakening) (subst weakening t) 446 | ≡⟨ cong (subst _) (sym weaken-subst) ⟩ 447 | subst (lift (succ k) weakening) (weaken t) 448 | ∎ 449 | lemma₂ = extensionality {T = T} λ x → 450 | lookup (compose (lift k weakening) (lift k (lift 1 σ))) x 451 | ≡⟨ lookup-compose-lift-weakening k ⟩ 452 | lookup (lift k (lift 1 σ)) (Fin.lift k succ x) 453 | ≡⟨ sym (lookup-lift-map-weaken k x) ⟩ 454 | lookup (lift k (map weaken σ)) x 455 | ∎ 456 | 457 | compose-weakening : ∀ {m n} {σ : Subst T m n} → compose σ weakening ≡ compose weakening (lift 1 σ) 458 | compose-weakening = compose-lift-weakening 0 459 | 460 | weakening-commutes : ∀ {m n} {σ : Subst T m n} t 461 | → subst weakening (subst σ t) ≡ subst (lift 1 σ) (subst weakening t) 462 | weakening-commutes {σ = σ} = 463 | substs-ext (weakening ∷ σ ∷ []) (lift 1 σ ∷ weakening ∷ []) compose-lift-weakening 0 464 | 465 | weaken-commutes : ∀ {m n} {σ : Subst T m n} t 466 | → weaken (subst σ t) ≡ subst (lift 1 σ) (weaken t) 467 | weaken-commutes {σ = σ} t = 468 | weaken (subst σ t) 469 | ≡⟨ weaken-subst ⟩ 470 | subst weakening (subst σ t) 471 | ≡⟨ weakening-commutes t ⟩ 472 | subst (lift 1 σ) (subst weakening t) 473 | ≡⟨ cong (subst _) (sym weaken-subst) ⟩ 474 | subst (lift 1 σ) (weaken t) 475 | ∎ 476 | 477 | weaken-renaming-commutes : ∀ {m n} {σ : Subst Fin m n} t 478 | → weaken (Renaming.subst σ t) ≡ Renaming.subst (Renaming.lift 1 σ) (weaken t) 479 | weaken-renaming-commutes {σ = σ} t = 480 | weaken (Renaming.subst σ t) 481 | ≡⟨ cong weaken renaming-subst ⟩ 482 | weaken (subst (map var σ) t) 483 | ≡⟨ weaken-commutes t ⟩ 484 | subst (lift 1 (map var σ)) (weaken t) 485 | ≡⟨ cong (λ p → subst p (weaken t)) (sym (map-var-renaming-lift 1)) ⟩ 486 | subst (map var (Renaming.lift 1 σ)) (weaken t) 487 | ≡⟨ sym renaming-subst ⟩ 488 | Renaming.subst (Renaming.lift 1 σ) (weaken t) 489 | ∎ 490 | 491 | lift-distributes : ∀ {m n o} {σ₁ : Subst T m n} {σ₂ : Subst T n o} k 492 | → lift k (compose σ₁ σ₂) ≡ compose (lift k σ₁) (lift k σ₂) 493 | lift-distributes = lift-distributes' λ k → weaken-commutes 494 | 495 | subst-compose : ∀ {m n o} {σ₁ : Subst T m n} {σ₂ : Subst T n o} t 496 | → subst (compose σ₁ σ₂) t ≡ subst σ₂ (subst σ₁ t) 497 | subst-compose {σ₁ = σ₁} {σ₂ = σ₂} = substs-ext (compose σ₁ σ₂ ∷ []) (σ₂ ∷ σ₁ ∷ []) lift-distributes 0 498 | 499 | compose-associative : ∀ {m n o p} {σ₁ : Subst T m n} {σ₂ : Subst T n o} {σ₃ : Subst T o p} 500 | → compose (compose σ₁ σ₂) σ₃ ≡ compose σ₁ (compose σ₂ σ₃) 501 | compose-associative {σ₁ = σ₁} {σ₂ = σ₂} {σ₃ = σ₃} = 502 | map (subst σ₃) (map (subst σ₂) σ₁) 503 | ≡⟨ map-map (subst σ₃) (subst σ₂) σ₁ ⟩ 504 | map (λ t → subst σ₃ (subst σ₂ t)) σ₁ 505 | ≡⟨ map-ext (λ t → subst σ₃ (subst σ₂ t)) (subst (compose σ₂ σ₃)) σ₁ (λ t → sym (subst-compose t)) ⟩ 506 | map (subst (compose σ₂ σ₃)) σ₁ 507 | ∎ 508 | 509 | compose-map-weaken-instantiation : ∀ {m n} {σ : Subst T m n} t 510 | → compose (map weaken σ) (instantiation t) ≡ σ 511 | compose-map-weaken-instantiation {σ = σ} t = 512 | compose (map weaken σ) (instantiation t) 513 | ≡⟨ cong (λ p → compose p _) (map-weaken) ⟩ 514 | compose (compose σ weakening) (instantiation t) 515 | ≡⟨ compose-associative ⟩ 516 | compose σ (compose weakening (instantiation t)) 517 | ≡⟨ cong (compose σ) compose-weakening-instantiation ⟩ 518 | compose σ id 519 | ≡⟨ compose-id₂ ⟩ 520 | σ 521 | ∎ 522 | 523 | instantiate-weaken : ∀ {n} {t t' : T n} → instantiate t' (weaken t) ≡ t 524 | instantiate-weaken {t = t} {t' = t'} = 525 | instantiate t' (weaken t) 526 | ≡⟨ cong (instantiate t') weaken-subst ⟩ 527 | subst (instantiation t') (subst weakening t) 528 | ≡⟨ sym (subst-compose t) ⟩ 529 | subst (compose weakening (instantiation t')) t 530 | ≡⟨ cong (λ p → subst p t) compose-weakening-instantiation ⟩ 531 | subst id t 532 | ≡⟨ subst-id t ⟩ 533 | t 534 | ∎ 535 | 536 | compose-instantiation : ∀ {m n} {σ : Subst T m n} t 537 | → compose (instantiation t) σ ≡ compose (lift 1 σ) (instantiation (subst σ t)) 538 | compose-instantiation {σ = σ} t = 539 | compose (instantiation t) σ 540 | ≡⟨⟩ 541 | subst σ t ∷ compose id σ 542 | ≡⟨ cong (_∷_ _) compose-id₁ ⟩ 543 | subst σ t ∷ σ 544 | ≡⟨ cong (_∷_ _) (sym (compose-map-weaken-instantiation (subst σ t))) ⟩ 545 | subst σ t ∷ compose (map weaken σ) (instantiation (subst σ t)) 546 | ≡⟨ cong (λ p → p ∷ compose (map weaken σ) (instantiation (subst σ t))) (sym subst-var) ⟩ 547 | compose (lift 1 σ) (instantiation (subst σ t)) 548 | ∎ 549 | 550 | subst-instantiate : ∀ {m n} {σ : Subst T m n} t t' 551 | → subst σ (instantiate t' t) ≡ instantiate (subst σ t') (subst (lift 1 σ) t) 552 | subst-instantiate {σ = σ} t t' = 553 | subst σ (subst (instantiation t') t) 554 | ≡⟨ sym (subst-compose t) ⟩ 555 | subst (compose (instantiation t') σ) t 556 | ≡⟨ cong (λ p → subst p t) (compose-instantiation t') ⟩ 557 | subst (compose (lift 1 σ) (instantiation (subst σ t'))) t 558 | ≡⟨ subst-compose t ⟩ 559 | subst (instantiation (subst σ t')) (subst (lift 1 σ) t) 560 | ∎ 561 | 562 | rename-instantiate : ∀ {m n} {σ : Subst Fin m n} t t' 563 | → Renaming.subst σ (instantiate t' t) ≡ instantiate (Renaming.subst σ t') (Renaming.subst (Renaming.lift 1 σ) t) 564 | rename-instantiate {σ = σ} t t' = 565 | Renaming.subst σ (instantiate t' t) 566 | ≡⟨ renaming-subst ⟩ 567 | subst (map var σ) (instantiate t' t) 568 | ≡⟨ subst-instantiate t t' ⟩ 569 | instantiate (subst (map var σ) t') (subst (lift 1 (map var σ)) t) 570 | ≡⟨ cong₂ (λ p q → instantiate p (subst q t)) (sym renaming-subst) (sym (map-var-renaming-lift 1)) ⟩ 571 | instantiate (Renaming.subst σ t') (subst (map var (Renaming.lift 1 σ)) t) 572 | ≡⟨ cong (instantiate _) (sym renaming-subst) ⟩ 573 | instantiate (Renaming.subst σ t') (Renaming.subst (Renaming.lift 1 σ) t) 574 | ∎ -------------------------------------------------------------------------------- /SystemF.agda: -------------------------------------------------------------------------------- 1 | import SystemF.Syntax 2 | import SystemF.Substitution 3 | import SystemF.Semantics 4 | import SystemF.Typing 5 | import SystemF.TypeReduction 6 | import SystemF.Progress 7 | import SystemF.Preservation -------------------------------------------------------------------------------- /SystemF/Preservation.agda: -------------------------------------------------------------------------------- 1 | module SystemF.Preservation where 2 | 3 | open import Prelude 4 | import Prelude.Fin as Fin 5 | import Prelude.PropositionalEquality as Eq 6 | open import Substitution 7 | open import SystemF.Syntax 8 | open import SystemF.Semantics 9 | import SystemF.Substitution 10 | open import SystemF.Typing 11 | import SystemF.TypeReduction as TypeReduction 12 | 13 | module TypeRenaming where 14 | open Instantiate SystemF.Substitution.instantiate-fin-type hiding (var; weaken) public 15 | open Instantiate SystemF.Substitution.instantiate-type-type using (weaken) public 16 | module Tp = SubstituteSelf SystemF.Substitution.substitute-self-type 17 | 18 | _∶_⇒_ : ∀ {m m'} (σ : Subst Fin m m') (Δ : TypeContext m) (Δ' : TypeContext m') → Set 19 | σ ∶ Δ ⇒ Δ' = ZipWith (λ x κ → Δ' ⊢ var x ∶ κ) σ Δ 20 | 21 | infix 3 _∶_⇒_ 22 | 23 | weaken-⊢ : 24 | ∀ {m x κ κ'} {Δ : TypeContext m} 25 | → Δ ⊢ var x ∶ κ 26 | → (κ' ∷ Δ) ⊢ var (succ x) ∶ κ 27 | weaken-⊢ var = var 28 | 29 | weaken-⇒ : ∀ {m m' κ} {σ : Subst Fin m m'} {Δ : TypeContext m} {Δ' : TypeContext m'} 30 | → σ ∶ Δ ⇒ Δ' 31 | → map succ σ ∶ Δ ⇒ (κ ∷ Δ') 32 | weaken-⇒ [] = [] 33 | weaken-⇒ (d ∷ ds) = weaken-⊢ d ∷ weaken-⇒ ds 34 | 35 | id-⇒ : ∀ {m} {Δ : TypeContext m} → id ∶ Δ ⇒ Δ 36 | id-⇒ {Δ = []} = [] 37 | id-⇒ {Δ = κ ∷ Δ} = var ∷ weaken-⇒ id-⇒ 38 | 39 | lift-⇒ : ∀ {k m m'} {σ : Subst Fin m m'} (Δ₁ : TypeContext k) {Δ : TypeContext m} {Δ' : TypeContext m'} 40 | → σ ∶ Δ ⇒ Δ' 41 | → lift k σ ∶ (Δ₁ ++ Δ) ⇒ (Δ₁ ++ Δ') 42 | lift-⇒ [] ds = ds 43 | lift-⇒ (κ ∷ Δ₁) ds = var ∷ weaken-⇒ (lift-⇒ Δ₁ ds) 44 | 45 | weakening-⇒ : ∀ {m κ} {Δ : TypeContext m} → weakening ∶ Δ ⇒ (κ ∷ Δ) 46 | weakening-⇒ = weaken-⇒ id-⇒ 47 | 48 | lookup-⇒ : ∀ {m m'} {σ : Subst Fin m m'} {Δ : TypeContext m} {Δ' : TypeContext m'} (v : Fin m) 49 | → σ ∶ Δ ⇒ Δ' 50 | → Δ' ⊢ var (lookup σ v) ∶ lookup Δ v 51 | lookup-⇒ zero (d ∷ _) = d 52 | lookup-⇒ (succ v) (_ ∷ ds) = lookup-⇒ v ds 53 | 54 | preserves-kind : ∀ {m m' Δ Δ' κ τ} (σ : Subst Fin m m') 55 | → Δ ⊢ τ ∶ κ 56 | → σ ∶ Δ ⇒ Δ' 57 | → Δ' ⊢ subst σ τ ∶ κ 58 | preserves-kind σ var h = lookup-⇒ _ h 59 | preserves-kind σ (arrow d d') h = arrow (preserves-kind σ d h) (preserves-kind σ d' h) 60 | preserves-kind σ (all d) h = all (preserves-kind (lift 1 σ) d (lift-⇒ (_ ∷ []) h)) 61 | preserves-kind σ (exists d) h = exists (preserves-kind (lift 1 σ) d (lift-⇒ (_ ∷ []) h)) 62 | preserves-kind σ (lam d) h = lam (preserves-kind (lift 1 σ) d (lift-⇒ (_ ∷ []) h)) 63 | preserves-kind σ (app d d') h = app (preserves-kind σ d h) (preserves-kind σ d' h) 64 | preserves-kind σ (prod d d') h = prod (preserves-kind σ d h) (preserves-kind σ d' h) 65 | preserves-kind σ (sum d d') h = sum (preserves-kind σ d h) (preserves-kind σ d' h) 66 | 67 | map-weaken-renaming-commutes : ∀ {m m' n} {σ : Subst Fin m m'} {Γ : TermContext m n} 68 | → map weaken (map (subst σ) Γ) 69 | ≡ map (subst (lift 1 σ)) (map weaken Γ) 70 | map-weaken-renaming-commutes {σ = σ} {Γ = Γ} = 71 | map weaken (map (subst σ) Γ) 72 | ≡⟨ map-map weaken (subst σ) Γ ⟩ 73 | map (λ τ → weaken (subst σ τ)) Γ 74 | ≡⟨ map-ext _ _ Γ Tp.weaken-renaming-commutes ⟩ 75 | map (λ τ → subst (lift 1 σ) (weaken τ)) Γ 76 | ≡⟨ sym (map-map (subst (lift 1 σ)) weaken Γ) ⟩ 77 | map (subst (lift 1 σ)) (map weaken Γ) 78 | ∎ 79 | 80 | module TypeSubst where 81 | open Instantiate SystemF.Substitution.instantiate-type-type hiding (var) public 82 | module Tp = SubstituteSelf SystemF.Substitution.substitute-self-type 83 | 84 | _∶_⇒_ : ∀ {m m'} (σ : Subst Type m m') (Δ : TypeContext m) (Δ' : TypeContext m') → Set 85 | σ ∶ Δ ⇒ Δ' = ZipWith (λ τ κ → Δ' ⊢ τ ∶ κ) σ Δ 86 | 87 | infix 3 _∶_⇒_ 88 | 89 | weaken-⊢ : 90 | ∀ {m} {Δ : TypeContext m} {κ κ'} {τ} 91 | → Δ ⊢ τ ∶ κ 92 | → (κ' ∷ Δ) ⊢ weaken τ ∶ κ 93 | weaken-⊢ d = TypeRenaming.preserves-kind TypeRenaming.weakening d TypeRenaming.weakening-⇒ 94 | 95 | weaken-⇒ : ∀ {m m'} {σ : Subst Type m m'} {Δ : TypeContext m} {Δ' : TypeContext m'} {κ} 96 | → σ ∶ Δ ⇒ Δ' 97 | → map weaken σ ∶ Δ ⇒ (κ ∷ Δ') 98 | weaken-⇒ [] = [] 99 | weaken-⇒ (d ∷ ds) = weaken-⊢ d ∷ weaken-⇒ ds 100 | 101 | id-⇒ : ∀ {m} {Δ : TypeContext m} → id ∶ Δ ⇒ Δ 102 | id-⇒ {Δ = []} = [] 103 | id-⇒ {Δ = x ∷ Δ} = var ∷ weaken-⇒ id-⇒ 104 | 105 | weakening-⇒ : ∀ {m} {κ} {Δ : TypeContext m} → weakening ∶ Δ ⇒ (κ ∷ Δ) 106 | weakening-⇒ = weaken-⇒ id-⇒ 107 | 108 | lift-⇒ : ∀ {m m'} {σ : Subst Type m m'} {Δ : TypeContext m} {Δ' : TypeContext m'} {κ} 109 | → σ ∶ Δ ⇒ Δ' 110 | → lift 1 σ ∶ (κ ∷ Δ) ⇒ (κ ∷ Δ') 111 | lift-⇒ ds = var ∷ weaken-⇒ ds 112 | 113 | lookup-⇒ : ∀ {m m'} {σ : Subst Type m m'} {Δ : TypeContext m} {Δ' : TypeContext m'} (v : Fin m) 114 | → σ ∶ Δ ⇒ Δ' 115 | → Δ' ⊢ lookup σ v ∶ lookup Δ v 116 | lookup-⇒ zero (d ∷ _) = d 117 | lookup-⇒ (succ v) (_ ∷ ds) = lookup-⇒ v ds 118 | 119 | preserves-kind : ∀ {m m' Δ Δ' κ τ} (σ : Subst Type m m') 120 | → Δ ⊢ τ ∶ κ 121 | → σ ∶ Δ ⇒ Δ' 122 | → Δ' ⊢ subst σ τ ∶ κ 123 | 124 | preserves-kind σ var h = lookup-⇒ _ h 125 | preserves-kind σ (arrow d d') h = arrow (preserves-kind σ d h) (preserves-kind σ d' h) 126 | preserves-kind σ (all d) h = all (preserves-kind (lift 1 σ) d (lift-⇒ h)) 127 | preserves-kind σ (exists d) h = exists (preserves-kind (lift 1 σ) d (lift-⇒ h)) 128 | preserves-kind σ (lam d) h = lam (preserves-kind (lift 1 σ) d (lift-⇒ h)) 129 | preserves-kind σ (app d d') h = app (preserves-kind σ d h) (preserves-kind σ d' h) 130 | preserves-kind σ (prod d d') h = prod (preserves-kind σ d h) (preserves-kind σ d' h) 131 | preserves-kind σ (sum d d') h = sum (preserves-kind σ d h) (preserves-kind σ d' h) 132 | 133 | preserves-equality : ∀ {m m' τ τ'} (σ : Subst Type m m') 134 | → τ ≡ₜ τ' 135 | → subst σ τ ≡ₜ subst σ τ' 136 | preserves-equality σ trefl = trefl 137 | preserves-equality σ (tsym eq) = tsym (preserves-equality σ eq) 138 | preserves-equality σ (ttrans eq eq') = ttrans (preserves-equality σ eq) (preserves-equality σ eq') 139 | preserves-equality σ (arrow eq eq') = arrow (preserves-equality σ eq) (preserves-equality σ eq') 140 | preserves-equality σ (all eq) = all (preserves-equality (lift 1 σ) eq) 141 | preserves-equality σ (exists eq) = exists (preserves-equality (lift 1 σ) eq) 142 | preserves-equality σ (lam eq) = lam (preserves-equality (lift 1 σ) eq) 143 | preserves-equality σ (app eq eq') = app (preserves-equality σ eq) (preserves-equality σ eq') 144 | preserves-equality σ (app-lam {τ = τ} {τ' = τ'}) = Eq.subst (_≡ₜ_ _) (sym (Tp.subst-instantiate τ τ')) app-lam 145 | preserves-equality σ (prod eq eq') = prod (preserves-equality σ eq) (preserves-equality σ eq') 146 | preserves-equality σ (sum eq eq') = sum (preserves-equality σ eq) (preserves-equality σ eq') 147 | 148 | map-weaken-subst-commutes : ∀ {m m' n} {σ : Subst Type m m'} {Γ : TermContext m n} 149 | → map weaken (map (subst σ) Γ) 150 | ≡ map (subst (lift 1 σ)) (map weaken Γ) 151 | map-weaken-subst-commutes {σ = σ} {Γ = Γ} = 152 | map weaken (map (subst σ) Γ) 153 | ≡⟨ map-map weaken (subst σ) Γ ⟩ 154 | map (λ τ → weaken (subst σ τ)) Γ 155 | ≡⟨ map-ext _ _ Γ Tp.weaken-commutes ⟩ 156 | map (λ τ → subst (lift 1 σ) (weaken τ)) Γ 157 | ≡⟨ sym (map-map (subst (lift 1 σ)) weaken Γ) ⟩ 158 | map (subst (lift 1 σ)) (map weaken Γ) 159 | ∎ 160 | 161 | module TermTypeRenaming where 162 | open TypeRenaming using (_∶_⇒_; lift-⇒; preserves-kind; module Tp) public 163 | module _ {n : ℕ} where 164 | open Instantiate (SystemF.Substitution.instantiate-fin-term-type {n = n}) hiding (var) public 165 | 166 | preserves-type : ∀ {m m' n Δ Δ' t τ} {Γ : TermContext m n} (σ : Subst Fin m m') 167 | → Δ ⹁ Γ ⊢ t ∶ τ 168 | → σ ∶ Δ ⇒ Δ' 169 | → Δ' ⹁ map (TypeRenaming.subst σ) Γ ⊢ subst σ t ∶ TypeRenaming.subst σ τ 170 | preserves-type {Γ = Γ} σ var h = 171 | Eq.subst (λ p → _ ⹁ _ ⊢ _ ∶ p) (lookup-map (TypeRenaming.subst σ) Γ _) var 172 | preserves-type σ (lam d) h = 173 | lam (preserves-type σ d h) 174 | preserves-type σ (app d d') h = 175 | app (preserves-type σ d h) (preserves-type σ d' h) 176 | preserves-type σ (tlam d) h = 177 | tlam (Eq.subst (λ p → _ ⹁ p ⊢ _ ∶ _) (sym TypeRenaming.map-weaken-renaming-commutes) (preserves-type (TypeRenaming.lift 1 σ) d (lift-⇒ (_ ∷ []) h))) 178 | preserves-type σ (tapp {τ = τ} {τ' = τ'} d d') h = 179 | Eq.subst (λ p → _ ⹁ _ ⊢ _ ∶ p) (sym (Tp.rename-instantiate τ τ')) (tapp (preserves-type σ d h) (preserves-kind σ d' h)) 180 | preserves-type σ (pack {τ = τ} {τ' = τ'} d d') h = 181 | pack (Eq.subst (λ p → _ ⹁ _ ⊢ _ ∶ p) (Tp.rename-instantiate τ τ' ) (preserves-type σ d h)) (preserves-kind σ d' h) 182 | preserves-type {Δ' = Δ'} {Γ} σ (unpack {κ = κ} {τ' = τ'} {t = t} {t' = t'} d d') h = 183 | unpack 184 | (preserves-type σ d h) 185 | (subst₂ 186 | (λ p q → κ ∷ Δ' ⹁ p ⊢ subst (TypeRenaming.lift 1 σ) t' ∶ q) 187 | (cong (_∷_ _) (sym TypeRenaming.map-weaken-renaming-commutes)) 188 | (sym (Tp.weaken-renaming-commutes τ')) 189 | (preserves-type (TypeRenaming.lift 1 σ) d' (lift-⇒ (κ ∷ []) h)) 190 | ) 191 | preserves-type σ (prod d d') h = prod (preserves-type σ d h) (preserves-type σ d' h) 192 | preserves-type σ (proj₁ d) h = proj₁ (preserves-type σ d h) 193 | preserves-type σ (proj₂ d) h = proj₂ (preserves-type σ d h) 194 | preserves-type σ (left d) h = left (preserves-type σ d h) 195 | preserves-type σ (right d) h = right (preserves-type σ d h) 196 | preserves-type σ (match d d₁ d₂) h = match (preserves-type σ d h) (preserves-type σ d₁ h) (preserves-type σ d₂ h) 197 | preserves-type σ (type-eq d eq) h = type-eq (preserves-type σ d h) (TypeReduction.renaming-≡ₜ eq) 198 | 199 | module TermTypeSubst where 200 | open TypeSubst using (_∶_⇒_; lift-⇒; preserves-kind; module Tp) public 201 | module _ {n : ℕ} where 202 | open Instantiate (SystemF.Substitution.instantiate-type-term-type {n = n}) using (subst) public 203 | open Weaken (SystemF.Substitution.weaken-term-type {n = n}) public 204 | 205 | preserves-type : ∀ {m m' n Δ Δ' t τ} {Γ : TermContext m n} (σ : Subst Type m m') 206 | → Δ ⹁ Γ ⊢ t ∶ τ 207 | → σ ∶ Δ ⇒ Δ' 208 | → Δ' ⹁ map (TypeSubst.subst σ) Γ ⊢ subst σ t ∶ TypeSubst.subst σ τ 209 | preserves-type {Γ = Γ} σ var h = 210 | Eq.subst (λ p → _ ⹁ _ ⊢ _ ∶ p) (lookup-map (TypeSubst.subst σ) Γ _) var 211 | preserves-type σ (lam d) h = 212 | lam (preserves-type σ d h) 213 | preserves-type σ (app d d') h = 214 | app (preserves-type σ d h) (preserves-type σ d' h) 215 | preserves-type σ (tlam d) h = 216 | tlam (Eq.subst (λ p → _ ⹁ p ⊢ _ ∶ _) (sym TypeSubst.map-weaken-subst-commutes) (preserves-type (TypeSubst.lift 1 σ) d (lift-⇒ h))) 217 | preserves-type σ (tapp {τ = τ} {τ' = τ'} d d') h = 218 | Eq.subst (λ p → _ ⹁ _ ⊢ _ ∶ p) (sym (Tp.subst-instantiate τ τ')) (tapp (preserves-type σ d h) (preserves-kind σ d' h)) 219 | preserves-type σ (pack {τ = τ} {τ' = τ'} d d') h = 220 | pack (Eq.subst (λ p → _ ⹁ _ ⊢ _ ∶ p) (Tp.subst-instantiate τ τ' ) (preserves-type σ d h)) (preserves-kind σ d' h) 221 | preserves-type {Δ' = Δ'} {Γ} σ (unpack {κ = κ} {τ' = τ'} {t = t} {t' = t'} d d') h = 222 | unpack 223 | (preserves-type σ d h) 224 | (subst₂ 225 | (λ p q → κ ∷ Δ' ⹁ p ⊢ subst (TypeSubst.lift 1 σ) t' ∶ q) 226 | (cong (_∷_ _) (sym TypeSubst.map-weaken-subst-commutes)) 227 | (sym (Tp.weaken-commutes τ')) 228 | (preserves-type (TypeSubst.lift 1 σ) d' (lift-⇒ h)) 229 | ) 230 | preserves-type σ (prod d d') h = prod (preserves-type σ d h) (preserves-type σ d' h) 231 | preserves-type σ (proj₁ d) h = proj₁ (preserves-type σ d h) 232 | preserves-type σ (proj₂ d) h = proj₂ (preserves-type σ d h) 233 | preserves-type σ (left d) h = left (preserves-type σ d h) 234 | preserves-type σ (right d) h = right (preserves-type σ d h) 235 | preserves-type σ (match d d₁ d₂) h = match (preserves-type σ d h) (preserves-type σ d₁ h) (preserves-type σ d₂ h) 236 | preserves-type σ (type-eq d eq) h = 237 | type-eq (preserves-type σ d h) (TypeSubst.preserves-equality σ eq) 238 | 239 | module TermRenaming where 240 | module _ {m : ℕ} where 241 | open Instantiate (SystemF.Substitution.instantiate-fin-term {m = m}) hiding (var; lift; weaken) public 242 | open Var var-fin hiding (var; id; weakening) 243 | 244 | _⊢_∶_⇒_ : ∀ {m n n'} (Δ : TypeContext m) (σ : Subst Fin n n') (Γ : TermContext m n) (Γ' : TermContext m n') → Set 245 | Δ ⊢ σ ∶ Γ ⇒ Γ' = ZipWith (λ x τ → Δ ⹁ Γ' ⊢ var x ∶ τ) σ Γ 246 | 247 | infix 3 _⊢_∶_⇒_ 248 | 249 | weaken-⊢ : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {τ τ' x} 250 | → Δ ⹁ Γ ⊢ var x ∶ τ 251 | → Δ ⹁ (τ' ∷ Γ) ⊢ var (weaken x) ∶ τ 252 | weaken-⊢ var = var 253 | weaken-⊢ (type-eq d eq) = type-eq (weaken-⊢ d) eq 254 | 255 | weaken-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst Fin n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} {τ} 256 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 257 | → Δ ⊢ map weaken σ ∶ Γ ⇒ (τ ∷ Γ') 258 | weaken-⇒ [] = [] 259 | weaken-⇒ (d ∷ ds) = weaken-⊢ d ∷ weaken-⇒ ds 260 | 261 | id-⇒ : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} → Δ ⊢ id {m = m} ∶ Γ ⇒ Γ 262 | id-⇒ {Γ = []} = [] 263 | id-⇒ {Γ = τ ∷ Δ} = var ∷ weaken-⇒ id-⇒ 264 | 265 | weakening-⇒ : ∀ {m n τ} {Δ : TypeContext m} {Γ : TermContext m n} → Δ ⊢ weakening {m = m} ∶ Γ ⇒ (τ ∷ Γ) 266 | weakening-⇒ = weaken-⇒ id-⇒ 267 | 268 | lift-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst Fin n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} {τ} 269 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 270 | → Δ ⊢ lift 1 σ ∶ (τ ∷ Γ) ⇒ (τ ∷ Γ') 271 | lift-⇒ d = var ∷ weaken-⇒ d 272 | 273 | lift-type-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst Fin n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} {κ} 274 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 275 | → (κ ∷ Δ) ⊢ map (λ x → x) σ ∶ map TypeSubst.weaken Γ ⇒ map TypeSubst.weaken Γ' 276 | lift-type-⇒ [] = [] 277 | lift-type-⇒ (d ∷ ds) = TermTypeRenaming.preserves-type TypeRenaming.weakening d TypeRenaming.weakening-⇒ ∷ lift-type-⇒ ds 278 | 279 | lookup-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst Fin n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} (v : Fin n) 280 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 281 | → Δ ⹁ Γ' ⊢ var (lookup σ v) ∶ lookup Γ v 282 | lookup-⇒ zero (d ∷ _) = d 283 | lookup-⇒ (succ v) (_ ∷ ds) = lookup-⇒ v ds 284 | 285 | preserves-type : ∀ {m n n'} (σ : Subst Fin n n') {Δ} {Γ : TermContext m n} {Γ' : TermContext m n'} {τ : Type m} {t : Term m n} 286 | → Δ ⹁ Γ ⊢ t ∶ τ 287 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 288 | → Δ ⹁ Γ' ⊢ subst σ t ∶ τ 289 | preserves-type σ var h = lookup-⇒ _ h 290 | preserves-type σ (lam d) h = lam (preserves-type (lift 1 σ) d (lift-⇒ h)) 291 | preserves-type σ (app d d') h = app (preserves-type σ d h) (preserves-type σ d' h) 292 | preserves-type σ (tlam d) h = tlam (preserves-type (map (λ x → x) σ) d (lift-type-⇒ h)) 293 | preserves-type σ (tapp d d') h = tapp (preserves-type σ d h) d' 294 | preserves-type σ (pack d d') h = pack (preserves-type σ d h) d' 295 | preserves-type σ (unpack d d') h = unpack (preserves-type σ d h) (preserves-type (lift 1 (map (λ x → x) σ)) d' (lift-⇒ (lift-type-⇒ h))) 296 | preserves-type σ (prod d d') h = prod (preserves-type σ d h) (preserves-type σ d' h) 297 | preserves-type σ (proj₁ d) h = proj₁ (preserves-type σ d h) 298 | preserves-type σ (proj₂ d) h = proj₂ (preserves-type σ d h) 299 | preserves-type σ (left d) h = left (preserves-type σ d h) 300 | preserves-type σ (right d) h = right (preserves-type σ d h) 301 | preserves-type σ (match d d₁ d₂) h = match (preserves-type σ d h) (preserves-type (lift 1 σ) d₁ (lift-⇒ h)) (preserves-type (lift 1 σ) d₂ (lift-⇒ h)) 302 | preserves-type σ (type-eq d eq) h = type-eq (preserves-type σ d h) eq 303 | 304 | module TermSubst where 305 | module _ {m : ℕ} where 306 | open Instantiate (SystemF.Substitution.instantiate-term-term {m = m}) hiding (var) public 307 | 308 | _⊢_∶_⇒_ : ∀ {m n n'} (Δ : TypeContext m) (σ : Subst (Term m) n n') (Γ : TermContext m n) (Γ' : TermContext m n') → Set 309 | Δ ⊢ σ ∶ Γ ⇒ Γ' = ZipWith (λ t τ → Δ ⹁ Γ' ⊢ t ∶ τ) σ Γ 310 | 311 | infix 3 _⊢_∶_⇒_ 312 | 313 | weaken-⊢ : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {τ τ' t} 314 | → Δ ⹁ Γ ⊢ t ∶ τ 315 | → Δ ⹁ (τ' ∷ Γ) ⊢ weaken t ∶ τ 316 | weaken-⊢ {m = m} d = TermRenaming.preserves-type (TermRenaming.weakening {m = m}) d TermRenaming.weakening-⇒ 317 | 318 | weaken-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst (Term m) n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} {τ} 319 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 320 | → Δ ⊢ map weaken σ ∶ Γ ⇒ (τ ∷ Γ') 321 | weaken-⇒ [] = [] 322 | weaken-⇒ (d ∷ ds) = weaken-⊢ d ∷ weaken-⇒ ds 323 | 324 | lift-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst (Term m) n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} {τ} 325 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 326 | → Δ ⊢ lift 1 σ ∶ (τ ∷ Γ) ⇒ (τ ∷ Γ') 327 | lift-⇒ d = var ∷ weaken-⇒ d 328 | 329 | lift-type-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst (Term m) n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} {κ} 330 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 331 | → (κ ∷ Δ) ⊢ map TermTypeSubst.weaken σ ∶ map TypeSubst.weaken Γ ⇒ map TypeSubst.weaken Γ' 332 | lift-type-⇒ [] = [] 333 | lift-type-⇒ (d ∷ ds) = TermTypeRenaming.preserves-type TypeRenaming.weakening d TypeRenaming.weakening-⇒ ∷ lift-type-⇒ ds 334 | 335 | lookup-⇒ : ∀ {m n n'} {Δ : TypeContext m} {σ : Subst (Term m) n n'} {Γ : TermContext m n} {Γ' : TermContext m n'} (v : Fin n) 336 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 337 | → Δ ⹁ Γ' ⊢ lookup σ v ∶ lookup Γ v 338 | lookup-⇒ zero (d ∷ _) = d 339 | lookup-⇒ (succ v) (_ ∷ ds) = lookup-⇒ v ds 340 | 341 | preserves-type : ∀ {m n n'} (σ : Subst (Term m) n n') {Δ} {Γ : TermContext m n} {Γ' : TermContext m n'} {τ : Type m} {t : Term m n} 342 | → Δ ⹁ Γ ⊢ t ∶ τ 343 | → Δ ⊢ σ ∶ Γ ⇒ Γ' 344 | → Δ ⹁ Γ' ⊢ subst σ t ∶ τ 345 | preserves-type σ var h = lookup-⇒ _ h 346 | preserves-type σ (lam d) h = lam (preserves-type (lift 1 σ) d (lift-⇒ h)) 347 | preserves-type σ (app d d') h = app (preserves-type σ d h) (preserves-type σ d' h) 348 | preserves-type σ (tlam d) h = tlam (preserves-type (map TermTypeSubst.weaken σ) d (lift-type-⇒ h)) 349 | preserves-type σ (tapp d d') h = tapp (preserves-type σ d h) d' 350 | preserves-type σ (pack d d') h = pack (preserves-type σ d h) d' 351 | preserves-type σ (unpack d d') h = unpack (preserves-type σ d h) (preserves-type (lift 1 (map TermTypeSubst.weaken σ)) d' (lift-⇒ (lift-type-⇒ h))) 352 | preserves-type σ (prod d d') h = prod (preserves-type σ d h) (preserves-type σ d' h) 353 | preserves-type σ (proj₁ d) h = proj₁ (preserves-type σ d h) 354 | preserves-type σ (proj₂ d) h = proj₂ (preserves-type σ d h) 355 | preserves-type σ (left d) h = left (preserves-type σ d h) 356 | preserves-type σ (right d) h = right (preserves-type σ d h) 357 | preserves-type σ (match d d₁ d₂) h = match (preserves-type σ d h) (preserves-type (lift 1 σ) d₁ (lift-⇒ h)) (preserves-type (lift 1 σ) d₂ (lift-⇒ h)) 358 | preserves-type σ (type-eq d eq) h = type-eq (preserves-type σ d h) eq 359 | 360 | preservation : ∀ {t t' τ} 361 | → [] ⹁ [] ⊢ t ∶ τ 362 | → t ⟶ t' 363 | → [] ⹁ [] ⊢ t' ∶ τ 364 | preservation (app d d') (app₁ step) = app (preservation d step) d' 365 | preservation (app d d') (app₂ v step) = app d (preservation d' step) 366 | preservation (app d d') (app-lam v) = 367 | let eq , d'' = TypeReduction.lam-inversion d trefl 368 | in TermSubst.preserves-type (TermSubst.instantiation _) d'' (type-eq d' (tsym eq) ∷ []) 369 | preservation (tapp d d') (tapp step) = tapp (preservation d step) d' 370 | preservation (tapp d d') tapp-tlam with TypeReduction.tlam-inversion d trefl 371 | ... | refl , d'' = TermTypeSubst.preserves-type (TypeSubst.instantiation _) d'' (d' ∷ []) 372 | preservation (pack d d') (pack step) = pack (preservation d step) d' 373 | preservation (unpack d d') (unpack step) = unpack (preservation d step) d' 374 | preservation (unpack d d') (unpack-pack v) with TypeReduction.pack-inversion d trefl 375 | ... | refl , eq , d'' , d''' = 376 | TermSubst.preserves-type 377 | (TermSubst.instantiation _) 378 | (Eq.subst 379 | (λ p → _ ⹁ _ ⊢ _ ∶ p) 380 | TypeSubst.Tp.instantiate-weaken 381 | (TermTypeSubst.preserves-type (TypeSubst.instantiation _) d' (d''' ∷ []))) (type-eq d'' (TypeReduction.subst-≡ₜ eq) ∷ []) 382 | preservation (prod d d') (prod₁ step) = prod (preservation d step) d' 383 | preservation (prod d d') (prod₂ v step) = prod d (preservation d' step) 384 | preservation (proj₁ d) (proj₁ step) = proj₁ (preservation d step) 385 | preservation (proj₁ d) (proj₁-prod v v') = TypeReduction.prod-inversion d trefl .fst 386 | preservation (proj₂ d) (proj₂ step) = proj₂ (preservation d step) 387 | preservation (proj₂ d) (proj₂-prod v v') = TypeReduction.prod-inversion d trefl .snd 388 | preservation (left d) (left step) = left (preservation d step) 389 | preservation (right d) (right step) = right (preservation d step) 390 | preservation (match d d₁ d₂) (match step) = match (preservation d step) d₁ d₂ 391 | preservation (match d d₁ d₂) (match-left v) = 392 | TermSubst.preserves-type (TermSubst.instantiation _) d₁ (TypeReduction.left-inversion d trefl ∷ []) 393 | preservation (match d d₁ d₂) (match-right v) = 394 | TermSubst.preserves-type (TermSubst.instantiation _) d₂ (TypeReduction.right-inversion d trefl ∷ []) 395 | preservation (type-eq d eq) step = type-eq (preservation d step) eq -------------------------------------------------------------------------------- /SystemF/Progress.agda: -------------------------------------------------------------------------------- 1 | module SystemF.Progress where 2 | 3 | open import Prelude 4 | open import SystemF.Semantics 5 | open import SystemF.Syntax 6 | open import SystemF.Typing 7 | import SystemF.TypeReduction as TypeReduction 8 | 9 | module CanonicalForms where 10 | arrow-lam : ∀ {m Δ τ τ₁ τ₂} {t : Term m 0} 11 | → Value t 12 | → Δ ⹁ [] ⊢ t ∶ τ 13 | → τ ≡ₜ arrow τ₁ τ₂ 14 | → Σ (Type m × Term m 1) λ (τ₁' , t') → t ≡ lam τ₁' t' 15 | arrow-lam lam _ eq = _ , refl 16 | arrow-lam tlam (tlam d) eq = absurd (TypeReduction.¬-all-≡ₜ-arrow eq) 17 | arrow-lam tlam (type-eq d eq') eq = arrow-lam tlam d (ttrans eq' eq) 18 | arrow-lam (pack v) (pack d x) eq = absurd (TypeReduction.¬-exists-≡ₜ-arrow eq) 19 | arrow-lam (pack v) (type-eq d eq') eq = arrow-lam (pack v) d (ttrans eq' eq) 20 | arrow-lam (prod v v') (prod d d') eq = absurd (TypeReduction.¬-prod-≡ₜ-arrow eq) 21 | arrow-lam (prod v v') (type-eq d x) eq = arrow-lam (prod v v') d (ttrans x eq) 22 | arrow-lam (left v) (left d) eq = absurd (TypeReduction.¬-sum-≡ₜ-arrow eq) 23 | arrow-lam (left v) (type-eq d eq') eq = arrow-lam (left v) d (ttrans eq' eq) 24 | arrow-lam (right v) (right d) eq = absurd (TypeReduction.¬-sum-≡ₜ-arrow eq) 25 | arrow-lam (right v) (type-eq d eq') eq = arrow-lam (right v) d (ttrans eq' eq) 26 | 27 | all-tlam : ∀ {m Δ κ τ τ'} {t : Term m 0} 28 | → Value t 29 | → Δ ⹁ [] ⊢ t ∶ τ 30 | → τ ≡ₜ all κ τ' 31 | → Σ (Kind × Term (succ m) 0) λ (κ' , t') → t ≡ tlam κ' t' 32 | all-tlam lam (lam d) eq = absurd (TypeReduction.¬-all-≡ₜ-arrow (tsym eq)) 33 | all-tlam lam (type-eq d eq') eq = all-tlam lam d (ttrans eq' eq) 34 | all-tlam tlam _ eq = _ , refl 35 | all-tlam (pack v) (pack d d') eq = absurd (TypeReduction.¬-exists-≡ₜ-all eq) 36 | all-tlam (pack v) (type-eq d eq') eq = all-tlam (pack v) d (ttrans eq' eq) 37 | all-tlam (prod v v₁) (prod d d') eq = absurd (TypeReduction.¬-prod-≡ₜ-all eq) 38 | all-tlam (prod v v₁) (type-eq d eq') eq = all-tlam (prod v v₁) d (ttrans eq' eq) 39 | all-tlam (left v) (left d) eq = absurd (TypeReduction.¬-sum-≡ₜ-all eq) 40 | all-tlam (left v) (type-eq d eq') eq = all-tlam (left v) d (ttrans eq' eq) 41 | all-tlam (right v) (right d) eq = absurd (TypeReduction.¬-sum-≡ₜ-all eq) 42 | all-tlam (right v) (type-eq d eq') eq = all-tlam (right v) d (ttrans eq' eq) 43 | 44 | exists-pack : ∀ {m Δ κ τ τ'} {t : Term m 0} 45 | → Value t 46 | → Δ ⹁ [] ⊢ t ∶ τ 47 | → τ ≡ₜ exists κ τ' 48 | → Σ (Type _ × Term _ _ × Kind × Type _) λ (τ₁ , t' , κ' , τ₂) → Value t' × (t ≡ pack τ₁ t' (exists κ' τ₂)) 49 | exists-pack lam (lam d) eq = absurd (TypeReduction.¬-exists-≡ₜ-arrow (tsym eq)) 50 | exists-pack lam (type-eq d eq') eq = exists-pack lam d (ttrans eq' eq) 51 | exists-pack tlam (tlam d) eq = absurd (TypeReduction.¬-exists-≡ₜ-all (tsym eq)) 52 | exists-pack tlam (type-eq d eq') eq = exists-pack tlam d (ttrans eq' eq) 53 | exists-pack (pack v) (pack d d') eq = _ , v , refl 54 | exists-pack (pack v) (type-eq d eq') eq = exists-pack (pack v) d (ttrans eq' eq) 55 | exists-pack (prod v v') (prod d d') eq = absurd (TypeReduction.¬-prod-≡ₜ-exists eq) 56 | exists-pack (prod v v') (type-eq d eq') eq = exists-pack (prod v v') d (ttrans eq' eq) 57 | exists-pack (left v) (left d) eq = absurd (TypeReduction.¬-sum-≡ₜ-exists eq) 58 | exists-pack (left v) (type-eq d eq') eq = exists-pack (left v) d (ttrans eq' eq) 59 | exists-pack (right v) (right d) eq = absurd (TypeReduction.¬-sum-≡ₜ-exists eq) 60 | exists-pack (right v) (type-eq d eq') eq = exists-pack (right v) d (ttrans eq' eq) 61 | 62 | prod-prod : ∀ {m Δ τ τ₁ τ₂} {t : Term m 0} 63 | → Value t 64 | → Δ ⹁ [] ⊢ t ∶ τ 65 | → τ ≡ₜ prod τ₁ τ₂ 66 | → Σ (Term _ _ × Term _ _) λ (t₁ , t₂) → Value t₁ × Value t₂ × (t ≡ prod t₁ t₂) 67 | prod-prod lam (lam d) eq = absurd (TypeReduction.¬-prod-≡ₜ-arrow (tsym eq)) 68 | prod-prod lam (type-eq d eq') eq = prod-prod lam d (ttrans eq' eq) 69 | prod-prod tlam (tlam d) eq = absurd (TypeReduction.¬-prod-≡ₜ-all (tsym eq)) 70 | prod-prod tlam (type-eq d eq') eq = prod-prod tlam d (ttrans eq' eq) 71 | prod-prod (pack v) (pack d d') eq = absurd (TypeReduction.¬-prod-≡ₜ-exists (tsym eq)) 72 | prod-prod (pack v) (type-eq d eq') eq = prod-prod (pack v) d (ttrans eq' eq) 73 | prod-prod (prod v v') (prod d d') eq = _ , v , v' , refl 74 | prod-prod (prod v v') (type-eq d eq') eq = prod-prod (prod v v') d (ttrans eq' eq) 75 | prod-prod (left v) (left d) eq = absurd (TypeReduction.¬-prod-≡ₜ-sum (tsym eq)) 76 | prod-prod (left v) (type-eq d eq') eq = prod-prod (left v) d (ttrans eq' eq) 77 | prod-prod (right v) (right d) eq = absurd (TypeReduction.¬-prod-≡ₜ-sum (tsym eq)) 78 | prod-prod (right v) (type-eq d eq') eq = prod-prod (right v) d (ttrans eq' eq) 79 | 80 | sum-either : ∀ {m Δ τ τ₁ τ₂} {t : Term m 0} 81 | → Value t 82 | → Δ ⹁ [] ⊢ t ∶ τ 83 | → τ ≡ₜ sum τ₁ τ₂ 84 | → Σ (Term _ _) λ t' → Value t' × ((t ≡ left t') ⊎ (t ≡ right t')) 85 | sum-either lam (lam d) eq = absurd (TypeReduction.¬-sum-≡ₜ-arrow (tsym eq)) 86 | sum-either lam (type-eq d eq') eq = sum-either lam d (ttrans eq' eq) 87 | sum-either tlam (tlam d) eq = absurd (TypeReduction.¬-sum-≡ₜ-all (tsym eq)) 88 | sum-either tlam (type-eq d eq') eq = sum-either tlam d (ttrans eq' eq) 89 | sum-either (pack v) (pack d d') eq = absurd (TypeReduction.¬-sum-≡ₜ-exists (tsym eq)) 90 | sum-either (pack v) (type-eq d eq') eq = sum-either (pack v) d (ttrans eq' eq) 91 | sum-either (prod v v') (prod d d') eq = absurd (TypeReduction.¬-prod-≡ₜ-sum eq) 92 | sum-either (prod v v') (type-eq d eq') eq = sum-either (prod v v') d (ttrans eq' eq) 93 | sum-either (left v) (left d) eq = _ , v , inl refl 94 | sum-either (left v) (type-eq d eq') eq = _ , v , inl refl 95 | sum-either (right v) (right d) eq = _ , v , inr refl 96 | sum-either (right v) (type-eq d eq') eq = _ , v , inr refl 97 | 98 | progress : ∀ {m Δ τ} (t : Term m zero) 99 | → Δ ⹁ [] ⊢ t ∶ τ 100 | → Value t ⊎ Σ (Term m zero) (λ t' → t ⟶ t') 101 | progress (var ()) var 102 | progress _ (lam _) = inl lam 103 | progress (app t t') (app d d') with progress t d 104 | ... | inr (t , step) = inr (_ , app₁ step) 105 | ... | inl v with CanonicalForms.arrow-lam v d trefl | progress t' d' 106 | ... | _ , refl | inr (t' , step) = inr (_ , app₂ lam step) 107 | ... | _ , refl | inl v' = inr (_ , app-lam v') 108 | progress _ (tlam _) = inl tlam 109 | progress (tapp t τ) (tapp d _) with progress t d 110 | ... | inr (t , step) = inr (_ , tapp step) 111 | ... | inl v with CanonicalForms.all-tlam v d trefl 112 | ... | _ , refl = inr (_ , tapp-tlam) 113 | progress (pack τ t τ') (pack d d') with progress t d 114 | ... | inr (t , step) = inr (_ , pack step) 115 | ... | inl v = inl (pack v) 116 | progress (unpack t t') (unpack d d') with progress t d 117 | ... | inr (t , step) = inr (_ , unpack step) 118 | ... | inl v with CanonicalForms.exists-pack v d trefl 119 | ... | _ , v' , refl = inr (_ , unpack-pack v') 120 | progress (prod t t') (prod d d') with progress t d 121 | ... | inr (t , step) = inr (_ , prod₁ step ) 122 | ... | inl v with progress t' d' 123 | ... | inr (t' , step) = inr (_ , prod₂ v step) 124 | ... | inl v' = inl (prod v v') 125 | progress (proj₁ t) (proj₁ d) with progress t d 126 | ... | inr (t , step) = inr (_ , proj₁ step) 127 | ... | inl v with CanonicalForms.prod-prod v d trefl 128 | ... | _ , v₁ , v₂ , refl = inr (_ , proj₁-prod v₁ v₂) 129 | progress (proj₂ t) (proj₂ d) with progress t d 130 | ... | inr (t , step) = inr (_ , proj₂ step) 131 | ... | inl v with CanonicalForms.prod-prod v d trefl 132 | ... | _ , v₁ , v₂ , refl = inr (_ , proj₂-prod v₁ v₂) 133 | progress (left t) (left d) with progress t d 134 | ... | inr (t , step) = inr (_ , left step) 135 | ... | inl v = inl (left v) 136 | progress (right t) (right d) with progress t d 137 | ... | inr (t , step) = inr (_ , right step) 138 | ... | inl v = inl (right v) 139 | progress (match t t₁ t₂) (match d d₁ d₂) with progress t d 140 | ... | inr (t , step) = inr (_ , match step) 141 | ... | inl v with CanonicalForms.sum-either v d trefl 142 | ... | _ , v' , inl refl = inr (_ , match-left v') 143 | ... | _ , v' , inr refl = inr (_ , match-right v') 144 | progress t (type-eq d eq) = progress t d -------------------------------------------------------------------------------- /SystemF/Semantics.agda: -------------------------------------------------------------------------------- 1 | module SystemF.Semantics where 2 | 3 | open import Prelude 4 | open import SystemF.Syntax 5 | open import SystemF.Substitution hiding (instantiate-term; instantiate-type) 6 | open import Substitution 7 | 8 | instantiate-term : ∀ {m n} (t : Term m n) (t' : Term m (succ n)) → Term m n 9 | instantiate-term = Instantiate.instantiate SystemF.Substitution.instantiate-term-term 10 | 11 | instantiate-type : ∀ {m n} (t : Type m) (t' : Term (succ m) n) → Term m n 12 | instantiate-type = Instantiate.instantiate SystemF.Substitution.instantiate-type-term-type 13 | 14 | data _⟶_ {m n} : Term m n → Term m n → Set where 15 | app₁ : ∀ {t₁ t₂ t₁'} 16 | → t₁ ⟶ t₁' 17 | → app t₁ t₂ ⟶ app t₁' t₂ 18 | app₂ : ∀ {t₁ t₂ t₂'} 19 | → Value t₁ 20 | → t₂ ⟶ t₂' 21 | → app t₁ t₂ ⟶ app t₁ t₂' 22 | app-lam : ∀ {τ t t'} 23 | → Value t' 24 | → app (lam τ t) t' ⟶ instantiate-term t' t 25 | tapp : ∀ {τ t t'} 26 | → t ⟶ t' 27 | → tapp t τ ⟶ tapp t' τ 28 | tapp-tlam : ∀ {κ τ t} 29 | → tapp (tlam κ t) τ ⟶ instantiate-type τ t 30 | pack : ∀ {τ τ' t t'} 31 | → t ⟶ t' 32 | → pack τ t τ' ⟶ pack τ t' τ' 33 | unpack : ∀ {t t' t''} 34 | → t ⟶ t' 35 | → unpack t t'' ⟶ unpack t' t'' 36 | unpack-pack : ∀ {κ τ τ' t t'} 37 | → Value t 38 | → unpack (pack τ t (exists κ τ')) t' ⟶ instantiate-term t (instantiate-type τ t') 39 | prod₁ : ∀ {t₁ t₁' t₂} 40 | → t₁ ⟶ t₁' 41 | → prod t₁ t₂ ⟶ prod t₁' t₂ 42 | prod₂ : ∀ {t₁ t₂ t₂'} 43 | → Value t₁ 44 | → t₂ ⟶ t₂' 45 | → prod t₁ t₂ ⟶ prod t₁ t₂' 46 | proj₁ : ∀ {t t'} 47 | → t ⟶ t' 48 | → proj₁ t ⟶ proj₁ t' 49 | proj₂ : ∀ {t t'} 50 | → t ⟶ t' 51 | → proj₂ t ⟶ proj₂ t' 52 | proj₁-prod : ∀ {t₁ t₂} 53 | → Value t₁ 54 | → Value t₂ 55 | → proj₁ (prod t₁ t₂) ⟶ t₁ 56 | proj₂-prod : ∀ {t₁ t₂} 57 | → Value t₁ 58 | → Value t₂ 59 | → proj₂ (prod t₁ t₂) ⟶ t₂ 60 | left : ∀ {t t'} 61 | → t ⟶ t' 62 | → left t ⟶ left t' 63 | right : ∀ {t t'} 64 | → t ⟶ t' 65 | → right t ⟶ right t' 66 | match : ∀ {t t' t₁ t₂} 67 | → t ⟶ t' 68 | → match t t₁ t₂ ⟶ match t' t₁ t₂ 69 | match-left : ∀ {t t₁ t₂} 70 | → Value t 71 | → match (left t) t₁ t₂ ⟶ instantiate-term t t₁ 72 | match-right : ∀ {t t₁ t₂} 73 | → Value t 74 | → match (right t) t₁ t₂ ⟶ instantiate-term t t₂ 75 | 76 | infix 4 _⟶_ 77 | 78 | ¬-step-value : ∀ {m n} {t t' : Term m n} 79 | → Value t 80 | → ¬ (t ⟶ t') 81 | ¬-step-value (pack value) (pack step) = ¬-step-value value step 82 | ¬-step-value (left v) (left step) = ¬-step-value v step 83 | ¬-step-value (right v) (right step) = ¬-step-value v step 84 | ¬-step-value (prod v v') (prod₁ step) = ¬-step-value v step 85 | ¬-step-value (prod v v') (prod₂ v'' step) = ¬-step-value v' step 86 | 87 | deterministic : ∀ {m n} {t t₁ t₂ : Term m n} 88 | → t ⟶ t₁ 89 | → t ⟶ t₂ 90 | → t₁ ≡ t₂ 91 | deterministic (app₁ step₁) (app₁ step₂) rewrite deterministic step₁ step₂ = refl 92 | deterministic (app₁ step₁) (app₂ v₂ step₂) = absurd (¬-step-value v₂ step₁) 93 | deterministic (app₂ v₁ step₁) (app₁ step₂) = absurd (¬-step-value v₁ step₂) 94 | deterministic (app₂ v₁ step₁) (app₂ v₂ step₂) rewrite deterministic step₁ step₂ = refl 95 | deterministic (app₂ v₁ step₁) (app-lam v₂) = absurd (¬-step-value v₂ step₁) 96 | deterministic (app-lam v₁) (app₂ v₂ step₂) = absurd (¬-step-value v₁ step₂) 97 | deterministic (app-lam _) (app-lam _) = refl 98 | deterministic (tapp step₁) (tapp step₂) rewrite deterministic step₁ step₂ = refl 99 | deterministic tapp-tlam tapp-tlam = refl 100 | deterministic (pack step₁) (pack step₂) rewrite deterministic step₁ step₂ = refl 101 | deterministic (unpack step₁) (unpack step₂) rewrite deterministic step₁ step₂ = refl 102 | deterministic (unpack (pack step₁)) (unpack-pack v₂) = absurd (¬-step-value v₂ step₁) 103 | deterministic (unpack-pack v₁) (unpack (pack step₂)) = absurd (¬-step-value v₁ step₂) 104 | deterministic (unpack-pack v₁) (unpack-pack v₂) = refl 105 | deterministic (prod₁ step₁) (prod₁ step₂) rewrite deterministic step₁ step₂ = refl 106 | deterministic (prod₁ step₁) (prod₂ v₂ step₂) = absurd (¬-step-value v₂ step₁) 107 | deterministic (prod₂ v₁ step₁) (prod₁ step₂) = absurd (¬-step-value v₁ step₂) 108 | deterministic (prod₂ v₁ step₁) (prod₂ v₂ step₂) rewrite deterministic step₁ step₂ = refl 109 | deterministic (proj₁ step₁) (proj₁-prod v₂ v₂') = absurd (¬-step-value (prod v₂ v₂') step₁) 110 | deterministic (proj₂ step₁) (proj₂-prod v₂ v₂') = absurd (¬-step-value (prod v₂ v₂') step₁) 111 | deterministic (proj₁-prod v₁ v₁') (proj₁ step₂) = absurd (¬-step-value (prod v₁ v₁') step₂) 112 | deterministic (proj₂-prod v₁ v₁') (proj₂ step₂) = absurd (¬-step-value (prod v₁ v₁') step₂) 113 | deterministic (proj₁ step₁) (proj₁ step₂) rewrite deterministic step₁ step₂ = refl 114 | deterministic (proj₂ step₁) (proj₂ step₂) rewrite deterministic step₁ step₂ = refl 115 | deterministic (proj₁-prod v₁ v₂) (proj₁-prod v₁' v₂') = refl 116 | deterministic (proj₂-prod v₁ v₂) (proj₂-prod v₁' v₂') = refl 117 | deterministic (left step₁) (left step₂) rewrite deterministic step₁ step₂ = refl 118 | deterministic (right step₁) (right step₂) rewrite deterministic step₁ step₂ = refl 119 | deterministic (match step₁) (match step₂) rewrite deterministic step₁ step₂ = refl 120 | deterministic (match step₁) (match-left v₂) = absurd (¬-step-value (left v₂) step₁) 121 | deterministic (match step₁) (match-right v₂) = absurd (¬-step-value (right v₂) step₁) 122 | deterministic (match-left v₁) (match step₂) = absurd (¬-step-value (left v₁) step₂) 123 | deterministic (match-left v₁) (match-left v₂) = refl 124 | deterministic (match-right v₁) (match step₂) = absurd (¬-step-value (right v₁) step₂) 125 | deterministic (match-right v₁) (match-right v₂) = refl -------------------------------------------------------------------------------- /SystemF/Substitution.agda: -------------------------------------------------------------------------------- 1 | module SystemF.Substitution where 2 | 3 | open import Prelude 4 | import Prelude.Fin as Fin 5 | open import Substitution 6 | 7 | open import SystemF.Syntax 8 | 9 | module SubstType {T} (hoist-t : Hoist T Type) where 10 | open Hoist hoist-t 11 | 12 | subst : ∀ {m m'} → Subst T m m' → Type m → Type m' 13 | substs : ∀ {m m' size} → Subst T m m' → Vector (Type m) size → Vector (Type m') size 14 | 15 | subst σ (var x) = hoist (lookup σ x) 16 | subst σ (arrow τ τ') = arrow (subst σ τ) (subst σ τ') 17 | subst σ (all κ τ) = all κ (subst (lift 1 σ) τ) 18 | subst σ (exists κ τ) = exists κ (subst (lift 1 σ) τ) 19 | subst σ (lam κ τ) = lam κ (subst (lift 1 σ) τ) 20 | subst σ (app τ τ') = app (subst σ τ) (subst σ τ') 21 | subst σ (prod τ τ') = prod (subst σ τ) (subst σ τ') 22 | subst σ (sum τ τ') = sum (subst σ τ) (subst σ τ') 23 | 24 | substs σ [] = [] 25 | substs σ (τ ∷ τs) = subst σ τ ∷ substs σ τs 26 | 27 | substs-map : ∀ {size m m'} (σ : Subst T m m') (τs : Vector (Type m) size) 28 | → substs σ τs ≡ map (subst σ) τs 29 | substs-map σ [] = refl 30 | substs-map σ (τ ∷ τs) = cong (_∷_ (subst σ τ)) (substs-map σ τs) 31 | 32 | substitute-type : ∀ {T} → Hoist T Type → Substitute T Type 33 | substitute-type hoist-t = record 34 | { subst = SubstType.subst hoist-t 35 | } 36 | 37 | hoist-fin-type : Hoist Fin Type 38 | hoist-fin-type = record 39 | { super-var = var-fin 40 | ; hoist = var 41 | } 42 | 43 | rename-type : Substitute Fin Type 44 | rename-type = substitute-type hoist-fin-type 45 | 46 | weaken-type : Weaken Type 47 | weaken-type = record 48 | { weaken = subst weakening 49 | } 50 | where open Substitute rename-type 51 | open Var var-fin 52 | 53 | var-type : Var Type 54 | var-type = record 55 | { super-weaken = weaken-type 56 | ; var = var 57 | ; weaken-var = λ x → sym (cong Type.var (sym (lookup-weakening x))) 58 | } 59 | where open Var var-fin using (lookup-weakening) 60 | 61 | hoist-type-type : Hoist Type Type 62 | hoist-type-type = hoist-self var-type 63 | 64 | substitute-type-type : Substitute Type Type 65 | substitute-type-type = substitute-type hoist-type-type 66 | 67 | instantiate-type : ∀ {T} (hoist : Hoist T Type) → Instantiate (Hoist.super-var hoist) (substitute-type hoist) 68 | instantiate-type _ = record {} 69 | 70 | instantiate-fin-type : Instantiate var-fin rename-type 71 | instantiate-fin-type = instantiate-type hoist-fin-type 72 | 73 | instantiate-type-type : Instantiate var-type substitute-type-type 74 | instantiate-type-type = instantiate-type hoist-type-type 75 | 76 | module SubstsVarExtTypeLemmas {T} (hoist-t : Hoist T Type) where 77 | open Hoist hoist-t 78 | open Substitute (substitute-type hoist-t) 79 | open SubstType hoist-t using (substs-map) renaming (substs to substs-types) 80 | 81 | arrow-lifts-substs : ∀ {m n} k {τ τ' : Type (k + m)} (σ : Substs T m n) → 82 | substs (lifts k σ) (arrow τ τ') ≡ arrow (substs (lifts k σ) τ) (substs (lifts k σ) τ') 83 | arrow-lifts-substs k [] = refl 84 | arrow-lifts-substs k (σ ∷ σs) = cong (subst _) (arrow-lifts-substs k σs) 85 | 86 | all-lifts-substs : ∀ {m n} k {κ : Kind} {τ : Type (succ (k + m))} (σ : Substs T m n) → 87 | substs (lifts k σ) (all κ τ) ≡ all κ (substs (lifts (succ k) σ) τ) 88 | all-lifts-substs k [] = refl 89 | all-lifts-substs k (σ ∷ σs) = cong (subst _) (all-lifts-substs k σs) 90 | 91 | exists-lifts-substs : ∀ {m n} k {κ : Kind} {τ : Type (succ (k + m))} (σ : Substs T m n) → 92 | substs (lifts k σ) (exists κ τ) ≡ exists κ (substs (lifts (succ k) σ) τ) 93 | exists-lifts-substs k [] = refl 94 | exists-lifts-substs k (σ ∷ σs) = cong (subst _) (exists-lifts-substs k σs) 95 | 96 | lam-lifts-substs : ∀ {m n} k {κ : Kind} {τ : Type (succ (k + m))} (σ : Substs T m n) → 97 | substs (lifts k σ) (lam κ τ) ≡ lam κ (substs (lifts (succ k) σ) τ) 98 | lam-lifts-substs k [] = refl 99 | lam-lifts-substs k (σ ∷ σs) = cong (subst _) (lam-lifts-substs k σs) 100 | 101 | app-lifts-substs : ∀ {m n} k {τ τ' : Type (k + m)} (σ : Substs T m n) → 102 | substs (lifts k σ) (app τ τ') ≡ app (substs (lifts k σ) τ) (substs (lifts k σ) τ') 103 | app-lifts-substs k [] = refl 104 | app-lifts-substs k (σ ∷ σs) = cong (subst _) (app-lifts-substs k σs) 105 | 106 | prod-lifts-substs : ∀ {m n} k {τ τ' : Type (k + m)} (σ : Substs T m n) → 107 | substs (lifts k σ) (prod τ τ') ≡ prod (substs (lifts k σ) τ) (substs (lifts k σ) τ') 108 | prod-lifts-substs k [] = refl 109 | prod-lifts-substs k (σ ∷ σs) = cong (subst _) (prod-lifts-substs k σs) 110 | 111 | sum-lifts-substs : ∀ {m n} k {τ τ' : Type (k + m)} (σ : Substs T m n) → 112 | substs (lifts k σ) (sum τ τ') ≡ sum (substs (lifts k σ) τ) (substs (lifts k σ) τ') 113 | sum-lifts-substs k [] = refl 114 | sum-lifts-substs k (σ ∷ σs) = cong (subst _) (sum-lifts-substs k σs) 115 | 116 | module SubstsVarExtType {T₁ T₂} (hoist₁ : Hoist T₁ Type) (hoist₂ : Hoist T₂ Type) where 117 | module T₁ = Instantiate (make-instantiate (Hoist.super-var hoist₁) (substitute-type hoist₁)) 118 | module T₂ = Instantiate (make-instantiate (Hoist.super-var hoist₂) (substitute-type hoist₂)) 119 | module LemmaT₁ = SubstsVarExtTypeLemmas hoist₁ 120 | module LemmaT₂ = SubstsVarExtTypeLemmas hoist₂ 121 | 122 | substs-var-ext 123 | : ∀ {m n} (σ₁ : Substs T₁ m n) (σ₂ : Substs T₂ m n) 124 | → (∀ k (x : Fin (k + m)) → T₁.substs (T₁.lifts k σ₁) (Type.var x) ≡ T₂.substs (T₂.lifts k σ₂) (Type.var x)) 125 | → ∀ k (t : Type (k + m)) → T₁.substs (T₁.lifts k σ₁) t ≡ T₂.substs (T₂.lifts k σ₂) t 126 | substs-var-ext σ₁ σ₂ h k (var x) = h k x 127 | substs-var-ext σ₁ σ₂ h k (arrow τ τ') = 128 | T₁.substs (T₁.lifts k σ₁) (arrow τ τ') 129 | ≡⟨ LemmaT₁.arrow-lifts-substs k σ₁ ⟩ 130 | arrow (T₁.substs (T₁.lifts k σ₁) τ) (T₁.substs (T₁.lifts k σ₁) τ') 131 | ≡⟨ cong₂ arrow (substs-var-ext σ₁ σ₂ h k τ) (substs-var-ext σ₁ σ₂ h k τ') ⟩ 132 | arrow (T₂.substs (T₂.lifts k σ₂) τ) (T₂.substs (T₂.lifts k σ₂) τ') 133 | ≡⟨ sym (LemmaT₂.arrow-lifts-substs k σ₂) ⟩ 134 | T₂.substs (T₂.lifts k σ₂) (arrow τ τ') 135 | ∎ 136 | substs-var-ext σ₁ σ₂ h k (all κ τ) = 137 | T₁.substs (T₁.lifts k σ₁) (all κ τ) 138 | ≡⟨ LemmaT₁.all-lifts-substs k σ₁ ⟩ 139 | all κ (T₁.substs (T₁.lifts (succ k) σ₁) τ) 140 | ≡⟨ cong (all κ) (substs-var-ext σ₁ σ₂ h (succ k) τ) ⟩ 141 | all κ (T₂.substs (T₂.lifts (succ k) σ₂) τ) 142 | ≡⟨ sym (LemmaT₂.all-lifts-substs k σ₂) ⟩ 143 | T₂.substs (T₂.lifts k σ₂) (all κ τ) 144 | ∎ 145 | substs-var-ext σ₁ σ₂ h k (exists κ τ) = 146 | T₁.substs (T₁.lifts k σ₁) (exists κ τ) 147 | ≡⟨ LemmaT₁.exists-lifts-substs k σ₁ ⟩ 148 | exists κ (T₁.substs (T₁.lifts (succ k) σ₁) τ) 149 | ≡⟨ cong (exists κ) (substs-var-ext σ₁ σ₂ h (succ k) τ) ⟩ 150 | exists κ (T₂.substs (T₂.lifts (succ k) σ₂) τ) 151 | ≡⟨ sym (LemmaT₂.exists-lifts-substs k σ₂) ⟩ 152 | T₂.substs (T₂.lifts k σ₂) (exists κ τ) 153 | ∎ 154 | substs-var-ext σ₁ σ₂ h k (lam κ τ) = 155 | T₁.substs (T₁.lifts k σ₁) (lam κ τ) 156 | ≡⟨ LemmaT₁.lam-lifts-substs k σ₁ ⟩ 157 | lam κ (T₁.substs (T₁.lifts (succ k) σ₁) τ) 158 | ≡⟨ cong (lam κ) (substs-var-ext σ₁ σ₂ h (succ k) τ) ⟩ 159 | lam κ (T₂.substs (T₂.lifts (succ k) σ₂) τ) 160 | ≡⟨ sym (LemmaT₂.lam-lifts-substs k σ₂) ⟩ 161 | T₂.substs (T₂.lifts k σ₂) (lam κ τ) 162 | ∎ 163 | substs-var-ext σ₁ σ₂ h k (app τ τ') = 164 | T₁.substs (T₁.lifts k σ₁) (app τ τ') 165 | ≡⟨ LemmaT₁.app-lifts-substs k σ₁ ⟩ 166 | app (T₁.substs (T₁.lifts k σ₁) τ) (T₁.substs (T₁.lifts k σ₁) τ') 167 | ≡⟨ cong₂ app (substs-var-ext σ₁ σ₂ h k τ) (substs-var-ext σ₁ σ₂ h k τ') ⟩ 168 | app (T₂.substs (T₂.lifts k σ₂) τ) (T₂.substs (T₂.lifts k σ₂) τ') 169 | ≡⟨ sym (LemmaT₂.app-lifts-substs k σ₂) ⟩ 170 | T₂.substs (T₂.lifts k σ₂) (app τ τ') 171 | ∎ 172 | substs-var-ext σ₁ σ₂ h k (prod τ τ') = 173 | T₁.substs (T₁.lifts k σ₁) (prod τ τ') 174 | ≡⟨ LemmaT₁.prod-lifts-substs k σ₁ ⟩ 175 | prod (T₁.substs (T₁.lifts k σ₁) τ) (T₁.substs (T₁.lifts k σ₁) τ') 176 | ≡⟨ cong₂ prod (substs-var-ext σ₁ σ₂ h k τ) (substs-var-ext σ₁ σ₂ h k τ') ⟩ 177 | prod (T₂.substs (T₂.lifts k σ₂) τ) (T₂.substs (T₂.lifts k σ₂) τ') 178 | ≡⟨ sym (LemmaT₂.prod-lifts-substs k σ₂) ⟩ 179 | T₂.substs (T₂.lifts k σ₂) (prod τ τ') 180 | ∎ 181 | substs-var-ext σ₁ σ₂ h k (sum τ τ') = 182 | T₁.substs (T₁.lifts k σ₁) (sum τ τ') 183 | ≡⟨ LemmaT₁.sum-lifts-substs k σ₁ ⟩ 184 | sum (T₁.substs (T₁.lifts k σ₁) τ) (T₁.substs (T₁.lifts k σ₁) τ') 185 | ≡⟨ cong₂ sum (substs-var-ext σ₁ σ₂ h k τ) (substs-var-ext σ₁ σ₂ h k τ') ⟩ 186 | sum (T₂.substs (T₂.lifts k σ₂) τ) (T₂.substs (T₂.lifts k σ₂) τ') 187 | ≡⟨ sym (LemmaT₂.sum-lifts-substs k σ₂) ⟩ 188 | T₂.substs (T₂.lifts k σ₂) (sum τ τ') 189 | ∎ 190 | 191 | substitute-self-type : SubstituteSelf Type 192 | substitute-self-type = record 193 | { super-var = var-type 194 | ; substitute = substitute-type 195 | ; subst-var-hoist = λ _ → refl 196 | ; substs-var-ext = SubstsVarExtType.substs-var-ext 197 | ; weaken-rename = refl 198 | } 199 | 200 | module SubstTermType {T} (hoist-t : Hoist T Type) where 201 | open Hoist hoist-t 202 | module ST = SubstType hoist-t 203 | 204 | subst : ∀ {m m' n} → Subst T m m' → Term m n → Term m' n 205 | subst σ (var x) = Term.var x 206 | subst σ (lam τ t) = lam (ST.subst σ τ) (subst σ t) 207 | subst σ (app t t') = app (subst σ t) (subst σ t') 208 | subst σ (tlam κ t) = tlam κ (subst (lift 1 σ) t) 209 | subst σ (tapp t τ) = tapp (subst σ t) (ST.subst σ τ) 210 | subst σ (pack τ t τ') = pack (ST.subst σ τ) (subst σ t) (ST.subst σ τ') 211 | subst σ (unpack t t') = unpack (subst σ t) (subst (lift 1 σ) t') 212 | subst σ (prod t t') = prod (subst σ t) (subst σ t') 213 | subst σ (proj₁ t) = proj₁ (subst σ t) 214 | subst σ (proj₂ t) = proj₂ (subst σ t) 215 | subst σ (left t) = left (subst σ t) 216 | subst σ (right t) = right (subst σ t) 217 | subst σ (match t t' t'') = match (subst σ t) (subst σ t') (subst σ t'') 218 | 219 | Flip : ∀ {A B : Set} → (A → B → Set) → B → A → Set 220 | Flip f b a = f a b 221 | 222 | substitute-term-type : ∀ {T n} → Hoist T Type → Substitute T (Flip Term n) 223 | substitute-term-type hoist-t = record 224 | { subst = subst 225 | } 226 | where open SubstTermType hoist-t 227 | 228 | rename-term-type : ∀ {n} → Substitute Fin (Flip Term n) 229 | rename-term-type = substitute-term-type hoist-fin-type 230 | 231 | substitute-term-type-type : ∀ {n} → Substitute Type (Flip Term n) 232 | substitute-term-type-type = substitute-term-type hoist-type-type 233 | 234 | instantiate-term-type : ∀ {T n} (hoist : Hoist T Type) → Instantiate (Hoist.super-var hoist) (substitute-term-type {n = n} hoist) 235 | instantiate-term-type _ = record {} 236 | 237 | instantiate-fin-term-type : ∀ {n} → Instantiate var-fin (rename-term-type {n = n}) 238 | instantiate-fin-term-type = instantiate-term-type hoist-fin-type 239 | 240 | instantiate-type-term-type : ∀ {n} → Instantiate var-type (substitute-term-type {n = n} hoist-type-type) 241 | instantiate-type-term-type = instantiate-term-type hoist-type-type 242 | 243 | weaken-term-type : ∀ {n} → Weaken (Flip Term n) 244 | weaken-term-type = record 245 | { weaken = subst weakening 246 | } 247 | where open Substitute rename-term-type 248 | open Var var-fin 249 | 250 | module SubstTerm {T : ℕ → ℕ → Set} (weaken-t : ∀ {n} → Weaken (Flip T n)) (hoist-t : ∀ {m} → Hoist (T m) (Term m)) where 251 | subst : ∀ {m n n'} → Subst (T m) n n' → Term m n → Term m n' 252 | subst σ (var x) = Hoist.hoist hoist-t (lookup σ x) 253 | subst σ (lam τ t) = lam τ (subst (Hoist.lift hoist-t 1 σ) t) 254 | subst σ (app t t') = app (subst σ t) (subst σ t') 255 | subst σ (tlam κ t) = tlam κ (subst (map (Weaken.weaken weaken-t) σ) t) 256 | subst σ (tapp t τ) = tapp (subst σ t) τ 257 | subst σ (pack τ t τ') = pack τ (subst σ t) τ' 258 | subst σ (unpack t t') = unpack (subst σ t) (subst (Hoist.lift hoist-t 1 (map (Weaken.weaken weaken-t) σ)) t') 259 | subst σ (prod t t') = prod (subst σ t) (subst σ t') 260 | subst σ (proj₁ t) = proj₁ (subst σ t) 261 | subst σ (proj₂ t) = proj₂ (subst σ t) 262 | subst σ (left t) = left (subst σ t) 263 | subst σ (right t) = right (subst σ t) 264 | subst σ (match t t' t'') = match (subst σ t) (subst (Hoist.lift hoist-t 1 σ) t') (subst (Hoist.lift hoist-t 1 σ) t'') 265 | 266 | substitute-term : ∀ {T : ℕ → ℕ → Set} {m} → (∀ {n} → Weaken (Flip T n)) → (∀ {m} → Hoist (T m) (Term m)) → Substitute (T m) (Term m) 267 | substitute-term weaken-t hoist-t = record 268 | { subst = subst 269 | } 270 | where open SubstTerm weaken-t hoist-t 271 | 272 | weaken-const-fin : ∀ {n} → Weaken (λ _ → Fin n) 273 | weaken-const-fin = record 274 | { weaken = λ x → x 275 | } 276 | 277 | hoist-fin-term : ∀ {m} → Hoist Fin (Term m) 278 | hoist-fin-term = record 279 | { super-var = var-fin 280 | ; hoist = var 281 | } 282 | 283 | rename-term : ∀ {m} → Substitute Fin (Term m) 284 | rename-term = substitute-term weaken-const-fin hoist-fin-term 285 | 286 | instantiate-term : ∀ {T : ℕ → ℕ → Set} {m} (weaken : ∀ {n} → Weaken (Flip T n)) (hoist : ∀ {m} → Hoist (T m) (Term m)) 287 | → Instantiate (Hoist.super-var (hoist {m = m})) (substitute-term weaken hoist) 288 | instantiate-term weaken-t hoist-t = record {} 289 | 290 | instantiate-fin-term : ∀ {m} → Instantiate var-fin (rename-term {m = m}) 291 | instantiate-fin-term = instantiate-term weaken-const-fin hoist-fin-term 292 | 293 | weaken-term : ∀ {m} → Weaken (Term m) 294 | weaken-term = record 295 | { weaken = subst weakening 296 | } 297 | where open Substitute rename-term 298 | open Var var-fin 299 | 300 | var-term : ∀ {m} → Var (Term m) 301 | var-term = record 302 | { super-weaken = weaken-term 303 | ; var = var 304 | ; weaken-var = λ x → sym (cong Term.var (sym (lookup-weakening x))) 305 | } 306 | where open Var var-fin using (lookup-weakening) 307 | 308 | hoist-term-term : ∀ {m} → Hoist (Term m) (Term m) 309 | hoist-term-term = hoist-self var-term 310 | 311 | substitute-term-term : ∀ {m} → Substitute (Term m) (Term m) 312 | substitute-term-term = substitute-term weaken-term-type hoist-term-term 313 | 314 | instantiate-term-term : ∀ {m} → Instantiate (var-term {m = m}) substitute-term-term 315 | instantiate-term-term = instantiate-term weaken-term-type hoist-term-term 316 | -------------------------------------------------------------------------------- /SystemF/Syntax.agda: -------------------------------------------------------------------------------- 1 | module SystemF.Syntax where 2 | 3 | open import Prelude 4 | 5 | data Kind : Set where 6 | star : Kind 7 | arrow : Kind → Kind → Kind 8 | 9 | data Type (m : ℕ) : Set where 10 | var : Fin m → Type m 11 | arrow : Type m → Type m → Type m 12 | all : Kind → Type (succ m) → Type m 13 | exists : Kind → Type (succ m) → Type m 14 | lam : Kind → Type (succ m) → Type m 15 | app : Type m → Type m → Type m 16 | prod : Type m → Type m → Type m 17 | sum : Type m → Type m → Type m 18 | 19 | data Term (m n : ℕ) : Set where 20 | var : Fin n → Term m n 21 | lam : Type m → Term m (succ n) → Term m n 22 | app : Term m n → Term m n → Term m n 23 | tlam : Kind → Term (succ m) n → Term m n 24 | tapp : Term m n → Type m → Term m n 25 | pack : Type m → Term m n → Type m → Term m n 26 | unpack : Term m n → Term (succ m) (succ n) → Term m n 27 | prod : Term m n → Term m n → Term m n 28 | proj₁ proj₂ : Term m n → Term m n 29 | left right : Term m n → Term m n 30 | match : Term m n → Term m (succ n) → Term m (succ n) → Term m n 31 | 32 | data Value {m n : ℕ} : Term m n → Set where 33 | lam : ∀ {τ t} → Value (lam τ t) 34 | tlam : ∀ {κ t} → Value (tlam κ t) 35 | pack : ∀ {τ t τ'} → Value t → Value (pack τ t τ') 36 | prod : ∀ {t₁ t₂} → Value t₁ → Value t₂ → Value (prod t₁ t₂) 37 | left : ∀ {t} → Value t → Value (left t) 38 | right : ∀ {t} → Value t → Value (right t) -------------------------------------------------------------------------------- /SystemF/TypeReduction.agda: -------------------------------------------------------------------------------- 1 | module SystemF.TypeReduction where 2 | 3 | open import Prelude 4 | import Prelude.PropositionalEquality as Eq 5 | open import SystemF.Syntax 6 | open import SystemF.Typing 7 | open import SystemF.Substitution 8 | open import Substitution 9 | 10 | open SubstituteSelf SystemF.Substitution.substitute-self-type 11 | 12 | data _⇛_ {m} : Type m → Type m → Set where 13 | trefl : ∀ {τ} → τ ⇛ τ 14 | arrow : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ⇛ τ₁' → τ₂ ⇛ τ₂' → arrow τ₁ τ₂ ⇛ arrow τ₁' τ₂' 15 | all : ∀ {κ τ τ'} → τ ⇛ τ' → all κ τ ⇛ all κ τ' 16 | exists : ∀ {κ τ τ'} → τ ⇛ τ' → exists κ τ ⇛ exists κ τ' 17 | lam : ∀ {κ τ τ'} → τ ⇛ τ' → lam κ τ ⇛ lam κ τ' 18 | app : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ⇛ τ₁' → τ₂ ⇛ τ₂' → app τ₁ τ₂ ⇛ app τ₁' τ₂' 19 | app-lam : ∀ {κ τ₁ τ₁' τ₂ τ₂'} → τ₁ ⇛ τ₁' → τ₂ ⇛ τ₂' → app (lam κ τ₁) τ₂ ⇛ instantiate τ₂' τ₁' 20 | prod : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ⇛ τ₁' → τ₂ ⇛ τ₂' → prod τ₁ τ₂ ⇛ prod τ₁' τ₂' 21 | sum : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ⇛ τ₁' → τ₂ ⇛ τ₂' → sum τ₁ τ₂ ⇛ sum τ₁' τ₂' 22 | 23 | infix 3 _⇛_ 24 | 25 | data _⇛*_ {m} : Type m → Type m → Set where 26 | [] : ∀ {τ} → τ ⇛* τ 27 | _∷_ : ∀ {τ₁ τ₂ τ₃} → τ₁ ⇛ τ₂ → τ₂ ⇛* τ₃ → τ₁ ⇛* τ₃ 28 | 29 | infix 3 _⇛*_ 30 | infix 5 _∷_ 31 | 32 | _++⇛*_ : ∀ {m} {τ₁ τ₂ τ₃ : Type m} → τ₁ ⇛* τ₂ → τ₂ ⇛* τ₃ → τ₁ ⇛* τ₃ 33 | [] ++⇛* steps' = steps' 34 | (step ∷ steps) ++⇛* steps' = step ∷ (steps ++⇛* steps') 35 | 36 | infix 4 _++⇛*_ 37 | 38 | data _⇔*_ {m} : Type m → Type m → Set where 39 | base : ∀ {τ τ'} → τ ⇛ τ' → τ ⇔* τ' 40 | tsym : ∀ {τ τ'} → τ ⇔* τ' → τ' ⇔* τ 41 | ttrans : ∀ {τ₁ τ₂ τ₃} → τ₁ ⇔* τ₂ → τ₂ ⇔* τ₃ → τ₁ ⇔* τ₃ 42 | 43 | infix 3 _⇔*_ 44 | 45 | data _≡flat_ {m} : Type m → Type m → Set where 46 | [] : ∀ {τ} → τ ≡flat τ 47 | _∷_ : ∀ {τ₁ τ₂ τ₃} → τ₁ ⇛ τ₂ → τ₂ ≡flat τ₃ → τ₁ ≡flat τ₃ 48 | _∷sym_ : ∀ {τ₁ τ₂ τ₃} → τ₂ ⇛ τ₁ → τ₂ ≡flat τ₃ → τ₁ ≡flat τ₃ 49 | 50 | infix 3 _≡flat_ 51 | infix 5 _∷sym_ 52 | 53 | flat-snoc : ∀ {m} {τ₁ τ₂ τ₃ : Type m} → τ₁ ≡flat τ₂ → τ₂ ⇛ τ₃ → τ₁ ≡flat τ₃ 54 | flat-snoc [] step = step ∷ [] 55 | flat-snoc (step' ∷ eq) step = step' ∷ flat-snoc eq step 56 | flat-snoc (step' ∷sym eq) step = step' ∷sym flat-snoc eq step 57 | 58 | flat-snoc-sym : ∀ {m} {τ₁ τ₂ τ₃ : Type m} → τ₁ ≡flat τ₂ → τ₃ ⇛ τ₂ → τ₁ ≡flat τ₃ 59 | flat-snoc-sym [] step = step ∷sym [] 60 | flat-snoc-sym (step' ∷ eq) step = step' ∷ flat-snoc-sym eq step 61 | flat-snoc-sym (step' ∷sym eq) step = step' ∷sym flat-snoc-sym eq step 62 | 63 | flat-sym : ∀ {m} {τ τ' : Type m} → τ ≡flat τ' → τ' ≡flat τ 64 | flat-sym [] = [] 65 | flat-sym (step ∷ eq) = flat-snoc-sym (flat-sym eq) step 66 | flat-sym (step ∷sym eq) = flat-snoc (flat-sym eq) step 67 | 68 | flat-trans : ∀ {m} {τ₁ τ₂ τ₃ : Type m} → τ₁ ≡flat τ₂ → τ₂ ≡flat τ₃ → τ₁ ≡flat τ₃ 69 | flat-trans [] eq' = eq' 70 | flat-trans (step ∷ eq) eq' = step ∷ flat-trans eq eq' 71 | flat-trans (step ∷sym eq) eq' = step ∷sym flat-trans eq eq' 72 | 73 | flat-arrow : ∀ {m} {τ₁ τ₁' τ₂ τ₂' : Type m} → τ₁ ≡flat τ₁' → τ₂ ≡flat τ₂' → arrow τ₁ τ₂ ≡flat arrow τ₁' τ₂' 74 | flat-arrow [] [] = [] 75 | flat-arrow [] (step ∷ eq') = arrow trefl step ∷ flat-arrow [] eq' 76 | flat-arrow [] (step ∷sym eq') = arrow trefl step ∷sym flat-arrow [] eq' 77 | flat-arrow (step ∷ eq) eq' = arrow step trefl ∷ flat-arrow eq eq' 78 | flat-arrow (step ∷sym eq) eq' = arrow step trefl ∷sym flat-arrow eq eq' 79 | 80 | flat-all : ∀ {m} {κ} {τ τ' : Type (succ m)} → τ ≡flat τ' → all κ τ ≡flat all κ τ' 81 | flat-all [] = [] 82 | flat-all (step ∷ eq) = all step ∷ flat-all eq 83 | flat-all (step ∷sym eq) = all step ∷sym flat-all eq 84 | 85 | flat-exists : ∀ {m} {κ} {τ τ' : Type (succ m)} → τ ≡flat τ' → exists κ τ ≡flat exists κ τ' 86 | flat-exists [] = [] 87 | flat-exists (step ∷ eq) = exists step ∷ flat-exists eq 88 | flat-exists (step ∷sym eq) = exists step ∷sym flat-exists eq 89 | 90 | flat-lam : ∀ {m} {κ} {τ τ' : Type (succ m)} → τ ≡flat τ' → lam κ τ ≡flat lam κ τ' 91 | flat-lam [] = [] 92 | flat-lam (step ∷ eq) = lam step ∷ flat-lam eq 93 | flat-lam (step ∷sym eq) = lam step ∷sym flat-lam eq 94 | 95 | flat-app : ∀ {m} {τ₁ τ₁' τ₂ τ₂' : Type m} → τ₁ ≡flat τ₁' → τ₂ ≡flat τ₂' → app τ₁ τ₂ ≡flat app τ₁' τ₂' 96 | flat-app [] [] = [] 97 | flat-app [] (step ∷ eq') = app trefl step ∷ flat-app [] eq' 98 | flat-app [] (step ∷sym eq') = app trefl step ∷sym flat-app [] eq' 99 | flat-app (step ∷ eq) eq' = app step trefl ∷ flat-app eq eq' 100 | flat-app (step ∷sym eq) eq' = app step trefl ∷sym flat-app eq eq' 101 | 102 | flat-prod : ∀ {m} {τ₁ τ₁' τ₂ τ₂' : Type m} → τ₁ ≡flat τ₁' → τ₂ ≡flat τ₂' → prod τ₁ τ₂ ≡flat prod τ₁' τ₂' 103 | flat-prod [] [] = [] 104 | flat-prod [] (step ∷ eq') = prod trefl step ∷ flat-prod [] eq' 105 | flat-prod [] (step ∷sym eq') = prod trefl step ∷sym flat-prod [] eq' 106 | flat-prod (step ∷ eq) eq' = prod step trefl ∷ flat-prod eq eq' 107 | flat-prod (step ∷sym eq) eq' = prod step trefl ∷sym flat-prod eq eq' 108 | 109 | flat-sum : ∀ {m} {τ₁ τ₁' τ₂ τ₂' : Type m} → τ₁ ≡flat τ₁' → τ₂ ≡flat τ₂' → sum τ₁ τ₂ ≡flat sum τ₁' τ₂' 110 | flat-sum [] [] = [] 111 | flat-sum [] (step ∷ eq') = sum trefl step ∷ flat-sum [] eq' 112 | flat-sum [] (step ∷sym eq') = sum trefl step ∷sym flat-sum [] eq' 113 | flat-sum (step ∷ eq) eq' = sum step trefl ∷ flat-sum eq eq' 114 | flat-sum (step ∷sym eq) eq' = sum step trefl ∷sym flat-sum eq eq' 115 | 116 | flatten : ∀ {m} {τ τ' : Type m} → τ ≡ₜ τ' → τ ≡flat τ' 117 | flatten trefl = [] 118 | flatten (tsym eq) = flat-sym (flatten eq) 119 | flatten (ttrans eq eq') = flat-trans (flatten eq) (flatten eq') 120 | flatten (arrow eq eq') = flat-arrow (flatten eq) (flatten eq') 121 | flatten (all eq) = flat-all (flatten eq) 122 | flatten (exists eq) = flat-exists (flatten eq) 123 | flatten (lam eq) = flat-lam (flatten eq) 124 | flatten (app eq eq') = flat-app (flatten eq) (flatten eq') 125 | flatten app-lam = app-lam trefl trefl ∷ [] 126 | flatten (prod eq eq') = flat-prod (flatten eq) (flatten eq') 127 | flatten (sum eq eq') = flat-sum (flatten eq) (flatten eq') 128 | 129 | flat-reduction : ∀ {m} {τ τ' : Type m} → τ ≡flat τ' → τ ⇔* τ' 130 | flat-reduction [] = base trefl 131 | flat-reduction (step ∷ eq) = ttrans (base step) (flat-reduction eq) 132 | flat-reduction (step ∷sym eq) = ttrans (tsym (base step)) (flat-reduction eq) 133 | 134 | type-equality-reduction : ∀ {m} {τ τ' : Type m} → τ ≡ₜ τ' → τ ⇔* τ' 135 | type-equality-reduction eq = flat-reduction (flatten eq) 136 | 137 | type-reduction-equality : ∀ {m} {τ τ' : Type m} → τ ⇛ τ' → τ ≡ₜ τ' 138 | type-reduction-equality trefl = trefl 139 | type-reduction-equality (arrow step step') = arrow (type-reduction-equality step) (type-reduction-equality step') 140 | type-reduction-equality (all step) = all (type-reduction-equality step) 141 | type-reduction-equality (exists step) = exists (type-reduction-equality step) 142 | type-reduction-equality (lam step) = lam (type-reduction-equality step) 143 | type-reduction-equality (app step step') = app (type-reduction-equality step) (type-reduction-equality step') 144 | type-reduction-equality (app-lam step step') = ttrans (app (lam (type-reduction-equality step)) (type-reduction-equality step')) app-lam 145 | type-reduction-equality (prod step step') = prod (type-reduction-equality step) (type-reduction-equality step') 146 | type-reduction-equality (sum step step') = sum (type-reduction-equality step) (type-reduction-equality step') 147 | 148 | type-reductions-closure-equality : ∀ {m} {τ τ' : Type m} → τ ⇔* τ' → τ ≡ₜ τ' 149 | type-reductions-closure-equality (base step) = type-reduction-equality step 150 | type-reductions-closure-equality (tsym step) = tsym (type-reductions-closure-equality step) 151 | type-reductions-closure-equality (ttrans step step') = ttrans (type-reductions-closure-equality step) (type-reductions-closure-equality step') 152 | 153 | type-reductions-equality : ∀ {m} {τ τ' : Type m} → τ ⇛* τ' → τ ≡ₜ τ' 154 | type-reductions-equality [] = trefl 155 | type-reductions-equality (step ∷ steps) = ttrans (type-reduction-equality step) (type-reductions-equality steps) 156 | 157 | _⇛subst_ : ∀ {m m'} (σ σ' : Subst Type m m') → Set 158 | σ ⇛subst σ' = ZipWith _⇛_ σ σ' 159 | 160 | infix 3 _⇛subst_ 161 | 162 | renaming-⇛ : ∀ {m m'} {τ τ'} {σ : Subst Fin m m'} → τ ⇛ τ' → Renaming.subst σ τ ⇛ Renaming.subst σ τ' 163 | renaming-⇛ trefl = trefl 164 | renaming-⇛ (arrow step step') = arrow (renaming-⇛ step) (renaming-⇛ step') 165 | renaming-⇛ (all step) = all (renaming-⇛ step) 166 | renaming-⇛ (exists step) = exists (renaming-⇛ step) 167 | renaming-⇛ (lam step) = lam (renaming-⇛ step) 168 | renaming-⇛ (app step step') = app (renaming-⇛ step) (renaming-⇛ step') 169 | renaming-⇛ {σ = σ} (app-lam {κ = κ} {τ₁ = τ₁} {τ₁' = τ₁'} {τ₂ = τ₂} {τ₂' = τ₂'} step step') = 170 | Eq.subst (λ p → Renaming.subst σ (app (lam κ τ₁) τ₂) ⇛ p) (sym (rename-instantiate τ₁' τ₂')) (app-lam (renaming-⇛ step) (renaming-⇛ step')) 171 | renaming-⇛ (prod step step') = prod (renaming-⇛ step) (renaming-⇛ step') 172 | renaming-⇛ (sum step step') = sum (renaming-⇛ step) (renaming-⇛ step') 173 | 174 | renaming-⇛* : ∀ {m m'} {τ τ'} {σ : Subst Fin m m'} → τ ⇛* τ' → Renaming.subst σ τ ⇛* Renaming.subst σ τ' 175 | renaming-⇛* [] = [] 176 | renaming-⇛* (step ∷ steps) = renaming-⇛ step ∷ renaming-⇛* steps 177 | 178 | lookup-⇛ : ∀ {m m'} {σ σ' : Subst Type m m'} → σ ⇛subst σ' → ∀ x → lookup σ x ⇛ lookup σ' x 179 | lookup-⇛ (step ∷ σ) zero = step 180 | lookup-⇛ (_ ∷ σ) (succ x) = lookup-⇛ σ x 181 | 182 | weaken-⇛ : ∀ {m m'} {σ σ' : Subst Type m m'} → σ ⇛subst σ' → map weaken σ ⇛subst map weaken σ' 183 | weaken-⇛ [] = [] 184 | weaken-⇛ (step ∷ steps) = renaming-⇛ step ∷ weaken-⇛ steps 185 | 186 | lift-⇛ : ∀ {m m'} {σ σ' : Subst Type m m'} → σ ⇛subst σ' → lift 1 σ ⇛subst lift 1 σ' 187 | lift-⇛ σ = trefl ∷ weaken-⇛ σ 188 | 189 | id-⇛ : ∀ {m} → id {n = m} ⇛subst id 190 | id-⇛ {m = zero} = [] 191 | id-⇛ {m = succ m} = trefl ∷ weaken-⇛ id-⇛ 192 | 193 | refl-⇛subst : ∀ {m m'} {σ : Subst Type m m'} → σ ⇛subst σ 194 | refl-⇛subst {σ = []} = [] 195 | refl-⇛subst {σ = _ ∷ σ} = trefl ∷ refl-⇛subst 196 | 197 | instantiation-⇛ : ∀ {m} {τ τ' : Type m} → τ ⇛ τ' → instantiation τ ⇛subst instantiation τ' 198 | instantiation-⇛ step = step ∷ id-⇛ 199 | 200 | subst-⇛ : ∀ {m m'} {σ σ' : Subst Type m m'} → σ ⇛subst σ' → ∀ τ → subst σ τ ⇛ subst σ' τ 201 | subst-⇛ σ (var x) = lookup-⇛ σ x 202 | subst-⇛ σ (arrow τ τ') = arrow (subst-⇛ σ τ) (subst-⇛ σ τ') 203 | subst-⇛ σ (all x τ) = all (subst-⇛ (lift-⇛ σ) τ) 204 | subst-⇛ σ (exists x τ) = exists (subst-⇛ (lift-⇛ σ) τ) 205 | subst-⇛ σ (lam x τ) = lam (subst-⇛ (lift-⇛ σ) τ) 206 | subst-⇛ σ (app τ τ') = app (subst-⇛ σ τ) (subst-⇛ σ τ') 207 | subst-⇛ σ (prod τ τ') = prod (subst-⇛ σ τ) (subst-⇛ σ τ') 208 | subst-⇛ σ (sum τ τ') = sum (subst-⇛ σ τ) (subst-⇛ σ τ') 209 | 210 | subst-⇛-⇛ : ∀ {m m'} {σ σ' : Subst Type m m'} {τ τ'} → τ ⇛ τ' → σ ⇛subst σ' → subst σ τ ⇛ subst σ' τ' 211 | subst-⇛-⇛ (trefl {τ = τ}) σ = subst-⇛ σ τ 212 | subst-⇛-⇛ (arrow step step') σ = arrow (subst-⇛-⇛ step σ) (subst-⇛-⇛ step' σ) 213 | subst-⇛-⇛ (all step) σ = all (subst-⇛-⇛ step (lift-⇛ σ)) 214 | subst-⇛-⇛ (exists step) σ = exists (subst-⇛-⇛ step (lift-⇛ σ)) 215 | subst-⇛-⇛ (lam step) σ = lam (subst-⇛-⇛ step (lift-⇛ σ)) 216 | subst-⇛-⇛ (app step step') σ = app (subst-⇛-⇛ step σ) (subst-⇛-⇛ step' σ) 217 | subst-⇛-⇛ {σ = σ} {σ' = σ'} (app-lam {κ = κ} {τ₁ = τ₁} {τ₁' = τ₁'} {τ₂ = τ₂} {τ₂' = τ₂'} step step') σr = 218 | Eq.subst (λ p → subst σ (app (lam κ τ₁) τ₂) ⇛ p) (sym (subst-instantiate τ₁' τ₂')) (app-lam (subst-⇛-⇛ step (lift-⇛ σr)) (subst-⇛-⇛ step' σr)) 219 | subst-⇛-⇛ (prod step step') σ = prod (subst-⇛-⇛ step σ) (subst-⇛-⇛ step' σ) 220 | subst-⇛-⇛ (sum step step') σ = sum (subst-⇛-⇛ step σ) (subst-⇛-⇛ step' σ) 221 | 222 | subst-⇛* : ∀ {m m'} {σ : Subst Type m m'} {τ τ' : Type m} → τ ⇛* τ' → subst σ τ ⇛* subst σ τ' 223 | subst-⇛* [] = [] 224 | subst-⇛* (step ∷ steps) = subst-⇛-⇛ step refl-⇛subst ∷ subst-⇛* steps 225 | 226 | diamond : ∀ {m} {τ τ₁ τ₂ : Type m} → τ ⇛ τ₁ → τ ⇛ τ₂ → Σ (Type m) λ τ' → τ₁ ⇛ τ' × τ₂ ⇛ τ' 227 | {-# CATCHALL #-} 228 | diamond trefl step₂ = _ , step₂ , trefl 229 | {-# CATCHALL #-} 230 | diamond step₁ trefl = _ , trefl , step₁ 231 | diamond (arrow step₁ step₁') (arrow step₂ step₂') = 232 | let (_ , step₁ , step₂) = diamond step₁ step₂ 233 | (_ , step₁' , step₂') = diamond step₁' step₂' 234 | in _ , arrow step₁ step₁' , arrow step₂ step₂' 235 | diamond (all step₁) (all step₂) = 236 | let (_ , step₁ , step₂) = diamond step₁ step₂ 237 | in _ , all step₁ , all step₂ 238 | diamond (exists step₁) (exists step₂) = 239 | let (_ , step₁ , step₂) = diamond step₁ step₂ 240 | in _ , exists step₁ , exists step₂ 241 | diamond (lam step₁) (lam step₂) = 242 | let (_ , step₁ , step₂) = diamond step₁ step₂ 243 | in _ , lam step₁ , lam step₂ 244 | diamond (app step₁ step₁') (app step₂ step₂') = 245 | let (_ , step₁ , step₂) = diamond step₁ step₂ 246 | (_ , step₁' , step₂') = diamond step₁' step₂' 247 | in _ , app step₁ step₁' , app step₂ step₂' 248 | diamond (app trefl step₁') (app-lam {τ₁' = τ₁'} step₂ step₂') = 249 | let (_ , step₁' , step₂') = diamond step₁' step₂' 250 | in 251 | _ , app-lam step₂ step₁' , subst-⇛ (instantiation-⇛ step₂') τ₁' 252 | diamond (app (lam step₁) step₁') (app-lam step₂ step₂') = 253 | let (_ , step₁ , step₂) = diamond step₁ step₂ 254 | (_ , step₁' , step₂') = diamond step₁' step₂' 255 | in _ , app-lam step₁ step₁' , subst-⇛-⇛ step₂ (instantiation-⇛ step₂') 256 | diamond (app-lam {τ₁' = τ₁'} step₁ step₁') (app trefl step₂') = 257 | let (_ , step₁' , step₂') = diamond step₁' step₂' 258 | in 259 | _ , subst-⇛ (instantiation-⇛ step₁') τ₁' , app-lam step₁ step₂' 260 | diamond (app-lam step₁ step₁') (app (lam step₂) step₂') = 261 | let (_ , step₁ , step₂) = diamond step₁ step₂ 262 | (_ , step₁' , step₂') = diamond step₁' step₂' 263 | in _ , subst-⇛-⇛ step₁ (instantiation-⇛ step₁') , app-lam step₂ step₂' 264 | diamond (app-lam step₁ step₁') (app-lam step₂ step₂') = 265 | let (_ , step₁ , step₂) = diamond step₁ step₂ 266 | (_ , step₁' , step₂') = diamond step₁' step₂' 267 | in _ , subst-⇛-⇛ step₁ (instantiation-⇛ step₁') , subst-⇛-⇛ step₂ (instantiation-⇛ step₂') 268 | diamond (prod step₁ step₁') (prod step₂ step₂') = 269 | let (_ , step₁ , step₂) = diamond step₁ step₂ 270 | (_ , step₁' , step₂') = diamond step₁' step₂' 271 | in _ , prod step₁ step₁' , prod step₂ step₂' 272 | diamond (sum step₁ step₁') (sum step₂ step₂') = 273 | let (_ , step₁ , step₂) = diamond step₁ step₂ 274 | (_ , step₁' , step₂') = diamond step₁' step₂' 275 | in _ , sum step₁ step₁' , sum step₂ step₂' 276 | 277 | strip : ∀ {m} {τ τ₁ τ₂ : Type m} → τ ⇛ τ₁ → τ ⇛* τ₂ → Σ (Type m) λ τ' → τ₁ ⇛* τ' × τ₂ ⇛ τ' 278 | strip step [] = _ , [] , step 279 | strip step₁₂ (step₁₃ ∷ steps₃₅) = 280 | let _ , step₂₄ , step₃₄ = diamond step₁₂ step₁₃ 281 | _ , steps₄₆ , step₅₆ = strip step₃₄ steps₃₅ 282 | in _ , (step₂₄ ∷ steps₄₆) , step₅₆ 283 | 284 | confluence-⇛* : ∀ {m} {τ τ₁ τ₂ : Type m} → τ ⇛* τ₁ → τ ⇛* τ₂ → Σ (Type m) λ τ' → τ₁ ⇛* τ' × τ₂ ⇛* τ' 285 | confluence-⇛* [] steps₂ = _ , steps₂ , [] 286 | confluence-⇛* (step₁₂ ∷ steps₂₃) steps₁₄ = 287 | let _ , steps₂₅ , step₄₅ = strip step₁₂ steps₁₄ 288 | _ , steps₃₆ , steps₅₆ = confluence-⇛* steps₂₃ steps₂₅ 289 | in _ , steps₃₆ , step₄₅ ∷ steps₅₆ 290 | 291 | confluence-⇔ : ∀ {m} {τ₁ τ₂ : Type m} → τ₁ ⇔* τ₂ → Σ (Type m) λ τ → τ₁ ⇛* τ × τ₂ ⇛* τ 292 | confluence-⇔ (base step) = _ , (step ∷ []) , [] 293 | confluence-⇔ (tsym steps) = 294 | let (_ , steps , steps') = confluence-⇔ steps 295 | in _ , steps' , steps 296 | confluence-⇔ (ttrans steps steps') = 297 | let (_ , steps₁ , steps₂) = confluence-⇔ steps 298 | (_ , steps₁' , steps₂') = confluence-⇔ steps' 299 | (_ , connect₁ , connect₂) = confluence-⇛* steps₂ steps₁' 300 | in _ , (steps₁ ++⇛* connect₁) , (steps₂' ++⇛* connect₂) 301 | 302 | confluence-≡ₜ : ∀ {m} {τ τ' : Type m} → τ ≡ₜ τ' → Σ (Type m) λ τ'' → τ ⇛* τ'' × τ' ⇛* τ'' 303 | confluence-≡ₜ eq = confluence-⇔ (type-equality-reduction eq) 304 | 305 | subst-≡ₜ : ∀ {m m'} {σ : Subst Type m m'} {τ τ' : Type m} → τ ≡ₜ τ' → subst σ τ ≡ₜ subst σ τ' 306 | subst-≡ₜ eq with confluence-≡ₜ eq 307 | ... | _ , steps , steps' = ttrans (type-reductions-equality (subst-⇛* steps)) (tsym (type-reductions-equality (subst-⇛* steps'))) 308 | 309 | renaming-≡ₜ : ∀ {m m'} {τ τ' : Type m} {σ : Subst Fin m m'} → τ ≡ₜ τ' → Renaming.subst σ τ ≡ₜ Renaming.subst σ τ' 310 | renaming-≡ₜ eq with confluence-≡ₜ eq 311 | ... | _ , steps , steps' = ttrans (type-reductions-equality (renaming-⇛* steps)) (tsym (type-reductions-equality (renaming-⇛* steps'))) 312 | 313 | arrow-preserved : ∀ {m} {τ₁ τ₂ τ : Type m} 314 | → arrow τ₁ τ₂ ⇛* τ 315 | → Σ (Type m × Type m) λ (τ₁' , τ₂') → (τ ≡ arrow τ₁' τ₂') × τ₁ ⇛* τ₁' × τ₂ ⇛* τ₂' 316 | arrow-preserved [] = _ , refl , [] , [] 317 | arrow-preserved (trefl ∷ steps) = arrow-preserved steps 318 | arrow-preserved (arrow step step' ∷ steps) = 319 | let _ , eq , steps₁ , steps₂ = arrow-preserved steps 320 | in _ , eq , step ∷ steps₁ , step' ∷ steps₂ 321 | 322 | all-preserved : ∀ {m} {κ τ₁} {τ : Type m} 323 | → all κ τ₁ ⇛* τ 324 | → Σ (Type (succ m)) λ τ₂ → (τ ≡ all κ τ₂) × τ₁ ⇛* τ₂ 325 | all-preserved [] = _ , refl , [] 326 | all-preserved (trefl ∷ steps) = all-preserved steps 327 | all-preserved (all step ∷ steps) = 328 | let _ , eq , steps' = all-preserved steps 329 | in _ , eq , step ∷ steps' 330 | 331 | prod-preserved : ∀ {m} {τ₁ τ₂ τ : Type m} 332 | → prod τ₁ τ₂ ⇛* τ 333 | → Σ (Type m × Type m) λ (τ₁' , τ₂') → (τ ≡ prod τ₁' τ₂') × τ₁ ⇛* τ₁' × τ₂ ⇛* τ₂' 334 | prod-preserved [] = _ , refl , [] , [] 335 | prod-preserved (trefl ∷ steps) = prod-preserved steps 336 | prod-preserved (prod step₁ step₂ ∷ steps) = 337 | let _ , eq , steps₁ , steps₂ = prod-preserved steps 338 | in _ , eq , step₁ ∷ steps₁ , step₂ ∷ steps₂ 339 | 340 | sum-preserved : ∀ {m} {τ₁ τ₂ τ : Type m} 341 | → sum τ₁ τ₂ ⇛* τ 342 | → Σ (Type m × Type m) λ (τ₁' , τ₂') → (τ ≡ sum τ₁' τ₂') × τ₁ ⇛* τ₁' × τ₂ ⇛* τ₂' 343 | sum-preserved [] = _ , refl , [] , [] 344 | sum-preserved (trefl ∷ steps) = sum-preserved steps 345 | sum-preserved (sum step₁ step₂ ∷ steps) = 346 | let _ , eq , steps₁ , steps₂ = sum-preserved steps 347 | in _ , eq , step₁ ∷ steps₁ , step₂ ∷ steps₂ 348 | 349 | exists-preserved : ∀ {m} {κ τ₁} {τ : Type m} 350 | → exists κ τ₁ ⇛* τ 351 | → Σ (Type (succ m)) λ τ₂ → (τ ≡ exists κ τ₂) × τ₁ ⇛* τ₂ 352 | exists-preserved [] = _ , refl , [] 353 | exists-preserved (trefl ∷ steps) = exists-preserved steps 354 | exists-preserved (exists step ∷ steps) = 355 | let _ , eq , steps' = exists-preserved steps 356 | in _ , eq , step ∷ steps' 357 | 358 | lam-inversion : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {τ₁ τ₁' τ τ₂ t} 359 | → Δ ⹁ Γ ⊢ lam τ₁ t ∶ τ 360 | → τ ≡ₜ arrow τ₁' τ₂ 361 | → (τ₁ ≡ₜ τ₁') × (Δ ⹁ τ₁ ∷ Γ ⊢ t ∶ τ₂) 362 | lam-inversion (lam d) eq with confluence-≡ₜ eq 363 | ... | _ , steps , steps' with arrow-preserved steps | arrow-preserved steps' 364 | ... | _ , refl , steps₁ , steps₂ | _ , refl , steps₁' , steps₂' = 365 | ttrans (type-reductions-equality steps₁) (tsym (type-reductions-equality steps₁')) , 366 | type-eq d (ttrans (type-reductions-equality steps₂) (tsym (type-reductions-equality steps₂'))) 367 | lam-inversion (type-eq d eq) eq' = lam-inversion d (ttrans eq eq') 368 | 369 | tlam-inversion : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {κ₁ κ₂ τ τ' t} 370 | → Δ ⹁ Γ ⊢ tlam κ₁ t ∶ τ 371 | → τ ≡ₜ all κ₂ τ' 372 | → (κ₁ ≡ κ₂) × (κ₁ ∷ Δ ⹁ map weaken Γ ⊢ t ∶ τ') 373 | tlam-inversion (tlam d) eq with confluence-≡ₜ eq 374 | ... | _ , steps , steps' with all-preserved steps | all-preserved steps' 375 | ... | _ , refl , steps₁ | _ , refl , steps₁' = 376 | refl , type-eq d (ttrans (type-reductions-equality steps₁) (tsym (type-reductions-equality steps₁'))) 377 | tlam-inversion (type-eq d x) eq = tlam-inversion d (ttrans x eq) 378 | 379 | prod-inversion : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {τ₁ τ₂ τ t₁ t₂} 380 | → Δ ⹁ Γ ⊢ prod t₁ t₂ ∶ τ 381 | → τ ≡ₜ prod τ₁ τ₂ 382 | → (Δ ⹁ Γ ⊢ t₁ ∶ τ₁) × (Δ ⹁ Γ ⊢ t₂ ∶ τ₂) 383 | prod-inversion (prod d d') eq with confluence-≡ₜ eq 384 | ... | _ , steps , steps' with prod-preserved steps | prod-preserved steps' 385 | ... | _ , refl , steps₁ , steps₂ | _ , refl , steps₁' , steps₂' = 386 | type-eq d (ttrans (type-reductions-equality steps₁) (tsym (type-reductions-equality steps₁'))) , 387 | type-eq d' (ttrans (type-reductions-equality steps₂) (tsym (type-reductions-equality steps₂'))) 388 | prod-inversion (type-eq d x) eq = prod-inversion d (ttrans x eq) 389 | 390 | left-inversion : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {τ₁ τ₂ τ t} 391 | → Δ ⹁ Γ ⊢ left t ∶ τ 392 | → τ ≡ₜ sum τ₁ τ₂ 393 | → Δ ⹁ Γ ⊢ t ∶ τ₁ 394 | left-inversion (left d) eq with confluence-≡ₜ eq 395 | ... | _ , steps , steps' with sum-preserved steps | sum-preserved steps' 396 | ... | _ , refl , steps₁ , steps₂ | _ , refl , steps₁' , steps₂' = 397 | type-eq d (ttrans (type-reductions-equality steps₁) (tsym (type-reductions-equality steps₁'))) 398 | left-inversion (type-eq d x) eq = left-inversion d (ttrans x eq) 399 | 400 | right-inversion : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {τ₁ τ₂ τ t} 401 | → Δ ⹁ Γ ⊢ right t ∶ τ 402 | → τ ≡ₜ sum τ₁ τ₂ 403 | → Δ ⹁ Γ ⊢ t ∶ τ₂ 404 | right-inversion (right d) eq with confluence-≡ₜ eq 405 | ... | _ , steps , steps' with sum-preserved steps | sum-preserved steps' 406 | ... | _ , refl , steps₁ , steps₂ | _ , refl , steps₁' , steps₂' = 407 | type-eq d (ttrans (type-reductions-equality steps₂) (tsym (type-reductions-equality steps₂'))) 408 | right-inversion (type-eq d x) eq = right-inversion d (ttrans x eq) 409 | 410 | pack-inversion : ∀ {m n} {Δ : TypeContext m} {Γ : TermContext m n} {κ₁ κ₂ τ₀ τ₁ τ₂ τ t} 411 | → Δ ⹁ Γ ⊢ pack τ₀ t (exists κ₁ τ₁) ∶ τ 412 | → τ ≡ₜ exists κ₂ τ₂ 413 | → (κ₁ ≡ κ₂) × (τ₁ ≡ₜ τ₂) × (Δ ⹁ Γ ⊢ t ∶ instantiate τ₀ τ₁) × (Δ ⊢ τ₀ ∶ κ₁) 414 | pack-inversion (pack d d') eq with confluence-≡ₜ eq 415 | ... | _ , steps , steps' with exists-preserved steps | exists-preserved steps' 416 | ... | _ , refl , steps₁ | _ , refl , steps₁' = refl , ttrans (type-reductions-equality steps₁) (tsym (type-reductions-equality steps₁')) , d , d' 417 | pack-inversion (type-eq d x) eq = pack-inversion d (ttrans x eq) 418 | 419 | ¬-all-≡ₜ-arrow : ∀ {m κ τ₁} {τ₂ τ₃ : Type m} → ¬ (all κ τ₁ ≡ₜ arrow τ₂ τ₃) 420 | ¬-all-≡ₜ-arrow eq with confluence-≡ₜ eq 421 | ... | _ , all-steps , arrow-steps with all-preserved all-steps | arrow-preserved arrow-steps 422 | ... | _ , refl , _ | _ , () , _ 423 | 424 | ¬-exists-≡ₜ-arrow : ∀ {m κ τ₁} {τ₂ τ₃ : Type m} → ¬ (exists κ τ₁ ≡ₜ arrow τ₂ τ₃) 425 | ¬-exists-≡ₜ-arrow eq with confluence-≡ₜ eq 426 | ... | _ , exists-steps , arrow-steps with exists-preserved exists-steps | arrow-preserved arrow-steps 427 | ... | _ , refl , _ | _ , () , _ 428 | 429 | ¬-prod-≡ₜ-arrow : ∀ {m} {τ₁ τ₂ τ₃ τ₄ : Type m} → ¬ (prod τ₁ τ₂ ≡ₜ arrow τ₃ τ₄) 430 | ¬-prod-≡ₜ-arrow eq with confluence-≡ₜ eq 431 | ... | _ , prod-steps , arrow-steps with prod-preserved prod-steps | arrow-preserved arrow-steps 432 | ... | _ , refl , _ | _ , () , _ 433 | 434 | ¬-sum-≡ₜ-arrow : ∀ {m} {τ₁ τ₂ τ₃ τ₄ : Type m} → ¬ (sum τ₁ τ₂ ≡ₜ arrow τ₃ τ₄) 435 | ¬-sum-≡ₜ-arrow eq with confluence-≡ₜ eq 436 | ... | _ , sum-steps , arrow-steps with sum-preserved sum-steps | arrow-preserved arrow-steps 437 | ... | _ , refl , _ | _ , () , _ 438 | 439 | ¬-exists-≡ₜ-all : ∀ {m κ₁ κ₂} {τ₁ τ₂ : Type (succ m)} → ¬ (exists κ₁ τ₁ ≡ₜ all κ₂ τ₂) 440 | ¬-exists-≡ₜ-all eq with confluence-≡ₜ eq 441 | ... | _ , exists-steps , all-steps with exists-preserved exists-steps | all-preserved all-steps 442 | ... | _ , refl , _ | _ , () , _ 443 | 444 | ¬-prod-≡ₜ-all : ∀ {m κ} {τ₁ τ₂ : Type m} {τ₃} → ¬ (prod τ₁ τ₂ ≡ₜ all κ τ₃) 445 | ¬-prod-≡ₜ-all eq with confluence-≡ₜ eq 446 | ... | _ , prod-steps , all-steps with prod-preserved prod-steps | all-preserved all-steps 447 | ... | _ , refl , _ | _ , () , _ 448 | 449 | ¬-sum-≡ₜ-all : ∀ {m κ} {τ₁ τ₂ : Type m} {τ₃} → ¬ (sum τ₁ τ₂ ≡ₜ all κ τ₃) 450 | ¬-sum-≡ₜ-all eq with confluence-≡ₜ eq 451 | ... | _ , sum-steps , all-steps with sum-preserved sum-steps | all-preserved all-steps 452 | ... | _ , refl , _ | _ , () , _ 453 | 454 | ¬-prod-≡ₜ-exists : ∀ {m κ} {τ₁ τ₂ : Type m} {τ₃} → ¬ (prod τ₁ τ₂ ≡ₜ exists κ τ₃) 455 | ¬-prod-≡ₜ-exists eq with confluence-≡ₜ eq 456 | ... | _ , prod-steps , exists-steps with prod-preserved prod-steps | exists-preserved exists-steps 457 | ... | _ , refl , _ | _ , () , _ 458 | 459 | ¬-sum-≡ₜ-exists : ∀ {m κ} {τ₁ τ₂ : Type m} {τ₃} → ¬ (sum τ₁ τ₂ ≡ₜ exists κ τ₃) 460 | ¬-sum-≡ₜ-exists eq with confluence-≡ₜ eq 461 | ... | _ , sum-steps , exists-steps with sum-preserved sum-steps | exists-preserved exists-steps 462 | ... | _ , refl , _ | _ , () , _ 463 | 464 | ¬-prod-≡ₜ-sum : ∀ {m} {τ₁ τ₂ τ₃ τ₄ : Type m} → ¬ (prod τ₁ τ₂ ≡ₜ sum τ₃ τ₄) 465 | ¬-prod-≡ₜ-sum eq with confluence-≡ₜ eq 466 | ... | _ , prod-steps , sum-steps with prod-preserved prod-steps | sum-preserved sum-steps 467 | ... | _ , refl , _ | _ , () , _ -------------------------------------------------------------------------------- /SystemF/Typing.agda: -------------------------------------------------------------------------------- 1 | module SystemF.Typing where 2 | 3 | open import Prelude 4 | open import Substitution 5 | open import SystemF.Substitution 6 | open import SystemF.Syntax 7 | 8 | private 9 | instantiate : ∀ {m} (τ : Type m) (τ' : Type (succ m)) → Type m 10 | instantiate = Instantiate.instantiate instantiate-type-type 11 | 12 | weaken : ∀ {m} → Type m → Type (succ m) 13 | weaken = Weaken.weaken weaken-type 14 | 15 | Context : (T : Set) → ℕ → Set 16 | Context = Vector 17 | 18 | TypeContext : ℕ → Set 19 | TypeContext = Context Kind 20 | 21 | TermContext : ℕ → ℕ → Set 22 | TermContext m n = Context (Type m) n 23 | 24 | data _⊢_∶_ {m} (Δ : TypeContext m) : Type m → Kind → Set where 25 | var : ∀ {v} → Δ ⊢ var v ∶ lookup Δ v 26 | arrow : ∀ {τ τ'} → Δ ⊢ τ ∶ star → Δ ⊢ τ' ∶ star → Δ ⊢ arrow τ τ' ∶ star 27 | all : ∀ {κ τ} → κ ∷ Δ ⊢ τ ∶ star → Δ ⊢ all κ τ ∶ star 28 | exists : ∀ {κ τ} → κ ∷ Δ ⊢ τ ∶ star → Δ ⊢ exists κ τ ∶ star 29 | lam : ∀ {κ κ' τ} → κ ∷ Δ ⊢ τ ∶ κ' → Δ ⊢ lam κ τ ∶ arrow κ κ' 30 | app : ∀ {τ τ' κ κ'} → Δ ⊢ τ ∶ arrow κ κ' → Δ ⊢ τ' ∶ κ → Δ ⊢ app τ τ' ∶ κ' 31 | prod : ∀ {τ τ'} → Δ ⊢ τ ∶ star → Δ ⊢ τ' ∶ star → Δ ⊢ prod τ τ' ∶ star 32 | sum : ∀ {τ τ'} → Δ ⊢ τ ∶ star → Δ ⊢ τ' ∶ star → Δ ⊢ sum τ τ' ∶ star 33 | 34 | infix 3 _⊢_∶_ 35 | 36 | data _≡ₜ_ {m} : Type m → Type m → Set where 37 | trefl : ∀ {τ} → τ ≡ₜ τ 38 | tsym : ∀ {τ τ'} → τ ≡ₜ τ' → τ' ≡ₜ τ 39 | ttrans : ∀ {τ₁ τ₂ τ₃} → τ₁ ≡ₜ τ₂ → τ₂ ≡ₜ τ₃ → τ₁ ≡ₜ τ₃ 40 | arrow : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ≡ₜ τ₁' → τ₂ ≡ₜ τ₂' → arrow τ₁ τ₂ ≡ₜ arrow τ₁' τ₂' 41 | all : ∀ {κ τ τ'} → τ ≡ₜ τ' → all κ τ ≡ₜ all κ τ' 42 | exists : ∀ {κ τ τ'} → τ ≡ₜ τ' → exists κ τ ≡ₜ exists κ τ' 43 | lam : ∀ {κ τ τ'} → τ ≡ₜ τ' → lam κ τ ≡ₜ lam κ τ' 44 | app : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ≡ₜ τ₁' → τ₂ ≡ₜ τ₂' → app τ₁ τ₂ ≡ₜ app τ₁' τ₂' 45 | app-lam : ∀ {κ τ τ'} → app (lam κ τ) τ' ≡ₜ instantiate τ' τ 46 | prod : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ≡ₜ τ₁' → τ₂ ≡ₜ τ₂' → prod τ₁ τ₂ ≡ₜ prod τ₁' τ₂' 47 | sum : ∀ {τ₁ τ₁' τ₂ τ₂'} → τ₁ ≡ₜ τ₁' → τ₂ ≡ₜ τ₂' → sum τ₁ τ₂ ≡ₜ sum τ₁' τ₂' 48 | 49 | infix 3 _≡ₜ_ 50 | 51 | data _⹁_⊢_∶_ {m n} (Δ : TypeContext m) (Γ : TermContext m n) : Term m n → Type m → Set where 52 | var : ∀ {v} 53 | → Δ ⹁ Γ ⊢ var v ∶ lookup Γ v 54 | lam : ∀ {τ τ' t} 55 | → Δ ⹁ (τ ∷ Γ) ⊢ t ∶ τ' 56 | → Δ ⹁ Γ ⊢ lam τ t ∶ arrow τ τ' 57 | app : ∀ {τ τ' t t'} 58 | → Δ ⹁ Γ ⊢ t ∶ arrow τ τ' 59 | → Δ ⹁ Γ ⊢ t' ∶ τ 60 | → Δ ⹁ Γ ⊢ app t t' ∶ τ' 61 | tlam : ∀ {κ τ t} 62 | → κ ∷ Δ ⹁ map weaken Γ ⊢ t ∶ τ 63 | → Δ ⹁ Γ ⊢ tlam κ t ∶ all κ τ 64 | tapp : ∀ {κ τ t τ'} 65 | → Δ ⹁ Γ ⊢ t ∶ all κ τ 66 | → Δ ⊢ τ' ∶ κ 67 | → Δ ⹁ Γ ⊢ tapp t τ' ∶ instantiate τ' τ 68 | pack : ∀ {κ τ τ' t} 69 | → Δ ⹁ Γ ⊢ t ∶ instantiate τ' τ 70 | → Δ ⊢ τ' ∶ κ 71 | → Δ ⹁ Γ ⊢ pack τ' t (exists κ τ) ∶ exists κ τ 72 | unpack : ∀ {κ τ τ' t t'} 73 | → Δ ⹁ Γ ⊢ t ∶ exists κ τ 74 | → κ ∷ Δ ⹁ τ ∷ map weaken Γ ⊢ t' ∶ weaken τ' 75 | → Δ ⹁ Γ ⊢ unpack t t' ∶ τ' 76 | prod : ∀ {τ τ' t t'} 77 | → Δ ⹁ Γ ⊢ t ∶ τ 78 | → Δ ⹁ Γ ⊢ t' ∶ τ' 79 | → Δ ⹁ Γ ⊢ prod t t' ∶ prod τ τ' 80 | proj₁ : ∀ {τ₁ τ₂ t} 81 | → Δ ⹁ Γ ⊢ t ∶ prod τ₁ τ₂ 82 | → Δ ⹁ Γ ⊢ proj₁ t ∶ τ₁ 83 | proj₂ : ∀ {τ₁ τ₂ t} 84 | → Δ ⹁ Γ ⊢ t ∶ prod τ₁ τ₂ 85 | → Δ ⹁ Γ ⊢ proj₂ t ∶ τ₂ 86 | left : ∀ {τ₁ τ₂ t} 87 | → Δ ⹁ Γ ⊢ t ∶ τ₁ 88 | → Δ ⹁ Γ ⊢ left t ∶ sum τ₁ τ₂ 89 | right : ∀ {τ₁ τ₂ t} 90 | → Δ ⹁ Γ ⊢ t ∶ τ₂ 91 | → Δ ⹁ Γ ⊢ right t ∶ sum τ₁ τ₂ 92 | match : ∀ {τ τ₁ τ₂ t t₁ t₂} 93 | → Δ ⹁ Γ ⊢ t ∶ sum τ₁ τ₂ 94 | → Δ ⹁ τ₁ ∷ Γ ⊢ t₁ ∶ τ 95 | → Δ ⹁ τ₂ ∷ Γ ⊢ t₂ ∶ τ 96 | → Δ ⹁ Γ ⊢ match t t₁ t₂ ∶ τ 97 | type-eq : ∀ {t τ τ'} 98 | → Δ ⹁ Γ ⊢ t ∶ τ 99 | → τ ≡ₜ τ' 100 | → Δ ⹁ Γ ⊢ t ∶ τ' 101 | 102 | infix 3 _⹁_⊢_∶_ --------------------------------------------------------------------------------