576 lines
16 KiB
Agda
576 lines
16 KiB
Agda
module 842Inference where
|
||
import Relation.Binary.PropositionalEquality as Eq
|
||
open Eq using (_≡_; refl; sym; trans; cong; cong₂; _≢_)
|
||
open import Data.Empty using (⊥; ⊥-elim)
|
||
open import Data.Nat using (ℕ; zero; suc; _+_)
|
||
open import Data.String using (String; _≟_)
|
||
open import Data.Product using (_×_; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩)
|
||
open import Relation.Nullary using (¬_; Dec; yes; no)
|
||
import plfa.part2.DeBruijn as DB
|
||
|
||
-- Syntax.
|
||
|
||
infix 4 _∋_⦂_
|
||
infix 4 _⊢_↑_
|
||
infix 4 _⊢_↓_
|
||
infixl 5 _,_⦂_
|
||
|
||
infixr 7 _⇒_
|
||
|
||
infix 5 ƛ_⇒_
|
||
infix 5 μ_⇒_
|
||
infix 6 _↑
|
||
infix 6 _↓_
|
||
infixl 7 _·_
|
||
infix 8 `suc_
|
||
infix 9 `_
|
||
|
||
Id : Set
|
||
Id = String
|
||
|
||
data Type : Set where
|
||
`ℕ : Type
|
||
_⇒_ : Type → Type → Type
|
||
|
||
data Context : Set where
|
||
∅ : Context
|
||
_,_⦂_ : Context → Id → Type → Context
|
||
|
||
data Term⁺ : Set
|
||
data Term⁻ : Set
|
||
|
||
data Term⁺ where
|
||
`_ : Id → Term⁺
|
||
_·_ : Term⁺ → Term⁻ → Term⁺
|
||
_↓_ : Term⁻ → Type → Term⁺
|
||
|
||
data Term⁻ where
|
||
ƛ_⇒_ : Id → Term⁻ → Term⁻
|
||
`zero : Term⁻
|
||
`suc_ : Term⁻ → Term⁻
|
||
`case_[zero⇒_|suc_⇒_] : Term⁺ → Term⁻ → Id → Term⁻ → Term⁻
|
||
μ_⇒_ : Id → Term⁻ → Term⁻
|
||
_↑ : Term⁺ → Term⁻
|
||
|
||
-- Examples of terms.
|
||
|
||
two : Term⁻
|
||
two = `suc (`suc `zero)
|
||
|
||
plus : Term⁺
|
||
plus = (μ "p" ⇒ ƛ "m" ⇒ ƛ "n" ⇒
|
||
`case (` "m") [zero⇒ ` "n" ↑
|
||
|suc "m" ⇒ `suc (` "p" · (` "m" ↑) · (` "n" ↑) ↑) ])
|
||
↓ (`ℕ ⇒ `ℕ ⇒ `ℕ)
|
||
|
||
2+2 : Term⁺
|
||
2+2 = plus · two · two
|
||
Ch : Type
|
||
Ch = (`ℕ ⇒ `ℕ) ⇒ `ℕ ⇒ `ℕ
|
||
|
||
twoᶜ : Term⁻
|
||
twoᶜ = (ƛ "s" ⇒ ƛ "z" ⇒ ` "s" · (` "s" · (` "z" ↑) ↑) ↑)
|
||
|
||
plusᶜ : Term⁺
|
||
plusᶜ = (ƛ "m" ⇒ ƛ "n" ⇒ ƛ "s" ⇒ ƛ "z" ⇒
|
||
` "m" · (` "s" ↑) · (` "n" · (` "s" ↑) · (` "z" ↑) ↑) ↑)
|
||
↓ (Ch ⇒ Ch ⇒ Ch)
|
||
|
||
sucᶜ : Term⁻
|
||
sucᶜ = ƛ "x" ⇒ `suc (` "x" ↑)
|
||
|
||
2+2ᶜ : Term⁺
|
||
2+2ᶜ = plusᶜ · twoᶜ · twoᶜ · sucᶜ · `zero
|
||
|
||
-- Lookup judgments.
|
||
|
||
data _∋_⦂_ : Context → Id → Type → Set where
|
||
|
||
Z : ∀ {Γ x A}
|
||
--------------------
|
||
→ Γ , x ⦂ A ∋ x ⦂ A
|
||
|
||
S : ∀ {Γ x y A B}
|
||
→ x ≢ y
|
||
→ Γ ∋ x ⦂ A
|
||
-----------------
|
||
→ Γ , y ⦂ B ∋ x ⦂ A
|
||
|
||
-- Synthesis and inheritance.
|
||
|
||
data _⊢_↑_ : Context → Term⁺ → Type → Set
|
||
data _⊢_↓_ : Context → Term⁻ → Type → Set
|
||
|
||
data _⊢_↑_ where
|
||
|
||
⊢` : ∀ {Γ A x}
|
||
→ Γ ∋ x ⦂ A
|
||
-----------
|
||
→ Γ ⊢ ` x ↑ A
|
||
|
||
_·_ : ∀ {Γ L M A B}
|
||
→ Γ ⊢ L ↑ A ⇒ B
|
||
→ Γ ⊢ M ↓ A
|
||
-------------
|
||
→ Γ ⊢ L · M ↑ B
|
||
|
||
⊢↓ : ∀ {Γ M A}
|
||
→ Γ ⊢ M ↓ A
|
||
---------------
|
||
→ Γ ⊢ (M ↓ A) ↑ A
|
||
|
||
data _⊢_↓_ where
|
||
|
||
⊢ƛ : ∀ {Γ x N A B}
|
||
→ Γ , x ⦂ A ⊢ N ↓ B
|
||
-------------------
|
||
→ Γ ⊢ ƛ x ⇒ N ↓ A ⇒ B
|
||
|
||
⊢zero : ∀ {Γ}
|
||
--------------
|
||
→ Γ ⊢ `zero ↓ `ℕ
|
||
|
||
⊢suc : ∀ {Γ M}
|
||
→ Γ ⊢ M ↓ `ℕ
|
||
---------------
|
||
→ Γ ⊢ `suc M ↓ `ℕ
|
||
|
||
⊢case : ∀ {Γ L M x N A}
|
||
→ Γ ⊢ L ↑ `ℕ
|
||
→ Γ ⊢ M ↓ A
|
||
→ Γ , x ⦂ `ℕ ⊢ N ↓ A
|
||
-------------------------------------
|
||
→ Γ ⊢ `case L [zero⇒ M |suc x ⇒ N ] ↓ A
|
||
|
||
⊢μ : ∀ {Γ x N A}
|
||
→ Γ , x ⦂ A ⊢ N ↓ A
|
||
-----------------
|
||
→ Γ ⊢ μ x ⇒ N ↓ A
|
||
|
||
⊢↑ : ∀ {Γ M A B}
|
||
→ Γ ⊢ M ↑ A
|
||
→ A ≡ B
|
||
-------------
|
||
→ Γ ⊢ (M ↑) ↓ B
|
||
|
||
|
||
|
||
-- PLFA exercise: write the term for multiplication (from Lambda)
|
||
|
||
-- PLFA exercise: extend the rules to support products (from More)
|
||
|
||
-- PLFA exercise (stretch): extend the rules to support the other
|
||
-- constructs from More
|
||
|
||
-- Equality of types.
|
||
|
||
_≟Tp_ : (A B : Type) → Dec (A ≡ B)
|
||
`ℕ ≟Tp `ℕ = yes refl
|
||
`ℕ ≟Tp (A ⇒ B) = no λ()
|
||
(A ⇒ B) ≟Tp `ℕ = no λ()
|
||
(A ⇒ B) ≟Tp (A′ ⇒ B′)
|
||
with A ≟Tp A′ | B ≟Tp B′
|
||
... | no A≢ | _ = no λ{refl → A≢ refl}
|
||
... | yes _ | no B≢ = no λ{refl → B≢ refl}
|
||
... | yes refl | yes refl = yes refl
|
||
|
||
-- Helpers: domain and range of equal function types are equal,
|
||
-- `ℕ is not a function type.
|
||
|
||
dom≡ : ∀ {A A′ B B′} → A ⇒ B ≡ A′ ⇒ B′ → A ≡ A′
|
||
dom≡ refl = refl
|
||
|
||
rng≡ : ∀ {A A′ B B′} → A ⇒ B ≡ A′ ⇒ B′ → B ≡ B′
|
||
rng≡ refl = refl
|
||
|
||
ℕ≢⇒ : ∀ {A B} → `ℕ ≢ A ⇒ B
|
||
ℕ≢⇒ ()
|
||
|
||
-- Lookup judgments are unique.
|
||
|
||
uniq-∋ : ∀ {Γ x A B} → Γ ∋ x ⦂ A → Γ ∋ x ⦂ B → A ≡ B
|
||
uniq-∋ Z Z = refl
|
||
uniq-∋ Z (S x≢y _) = ⊥-elim (x≢y refl)
|
||
uniq-∋ (S x≢y _) Z = ⊥-elim (x≢y refl)
|
||
uniq-∋ (S _ ∋x) (S _ ∋x′) = uniq-∋ ∋x ∋x′
|
||
|
||
-- A synthesized type is unique.
|
||
|
||
uniq-↑ : ∀ {Γ M A B} → Γ ⊢ M ↑ A → Γ ⊢ M ↑ B → A ≡ B
|
||
uniq-↑ (⊢` ∋x) (⊢` ∋x′) = uniq-∋ ∋x ∋x′
|
||
uniq-↑ (⊢L · ⊢M) (⊢L′ · ⊢M′) = rng≡ (uniq-↑ ⊢L ⊢L′)
|
||
uniq-↑ (⊢↓ ⊢M) (⊢↓ ⊢M′) = refl
|
||
|
||
-- Failed lookups still fail if a different binding is added.
|
||
|
||
ext∋ : ∀ {Γ B x y}
|
||
→ x ≢ y
|
||
→ ¬ ∃[ A ]( Γ ∋ x ⦂ A )
|
||
-----------------------------
|
||
→ ¬ ∃[ A ]( Γ , y ⦂ B ∋ x ⦂ A )
|
||
ext∋ x≢y _ ⟨ A , Z ⟩ = x≢y refl
|
||
ext∋ _ ¬∃ ⟨ A , S _ ⊢x ⟩ = ¬∃ ⟨ A , ⊢x ⟩
|
||
|
||
-- Decision procedure for lookup judgments.
|
||
|
||
lookup : ∀ (Γ : Context) (x : Id)
|
||
-----------------------
|
||
→ Dec (∃[ A ](Γ ∋ x ⦂ A))
|
||
lookup ∅ x = no (λ ())
|
||
lookup (Γ , y ⦂ B) x with x ≟ y
|
||
... | yes refl = yes ⟨ B , Z ⟩
|
||
... | no x≢y with lookup Γ x
|
||
... | no ¬∃ = no (ext∋ x≢y ¬∃)
|
||
... | yes ⟨ A , ⊢x ⟩ = yes ⟨ A , S x≢y ⊢x ⟩
|
||
|
||
-- Helpers for promoting a failure to type.
|
||
|
||
¬arg : ∀ {Γ A B L M}
|
||
→ Γ ⊢ L ↑ A ⇒ B
|
||
→ ¬ Γ ⊢ M ↓ A
|
||
-------------------------
|
||
→ ¬ ∃[ B′ ](Γ ⊢ L · M ↑ B′)
|
||
¬arg ⊢L ¬⊢M ⟨ B′ , ⊢L′ · ⊢M′ ⟩ rewrite dom≡ (uniq-↑ ⊢L ⊢L′) = ¬⊢M ⊢M′
|
||
|
||
¬switch : ∀ {Γ M A B}
|
||
→ Γ ⊢ M ↑ A
|
||
→ A ≢ B
|
||
---------------
|
||
→ ¬ Γ ⊢ (M ↑) ↓ B
|
||
¬switch ⊢M A≢B (⊢↑ ⊢M′ A′≡B) rewrite uniq-↑ ⊢M ⊢M′ = A≢B A′≡B
|
||
|
||
-- Mutually-recursive synthesize and inherit functions.
|
||
|
||
synthesize : ∀ (Γ : Context) (M : Term⁺)
|
||
-----------------------
|
||
→ Dec (∃[ A ](Γ ⊢ M ↑ A))
|
||
|
||
inherit : ∀ (Γ : Context) (M : Term⁻) (A : Type)
|
||
---------------
|
||
→ Dec (Γ ⊢ M ↓ A)
|
||
|
||
synthesize Γ (` x) with lookup Γ x
|
||
... | no ¬∃ = no (λ{ ⟨ A , ⊢` ∋x ⟩ → ¬∃ ⟨ A , ∋x ⟩ })
|
||
... | yes ⟨ A , ∋x ⟩ = yes ⟨ A , ⊢` ∋x ⟩
|
||
synthesize Γ (L · M) with synthesize Γ L
|
||
... | no ¬∃ = no (λ{ ⟨ _ , ⊢L · _ ⟩ → ¬∃ ⟨ _ , ⊢L ⟩ })
|
||
... | yes ⟨ `ℕ , ⊢L ⟩ = no (λ{ ⟨ _ , ⊢L′ · _ ⟩ → ℕ≢⇒ (uniq-↑ ⊢L ⊢L′) })
|
||
... | yes ⟨ A ⇒ B , ⊢L ⟩ with inherit Γ M A
|
||
... | no ¬⊢M = no (¬arg ⊢L ¬⊢M)
|
||
... | yes ⊢M = yes ⟨ B , ⊢L · ⊢M ⟩
|
||
synthesize Γ (M ↓ A) with inherit Γ M A
|
||
... | no ¬⊢M = no (λ{ ⟨ _ , ⊢↓ ⊢M ⟩ → ¬⊢M ⊢M })
|
||
... | yes ⊢M = yes ⟨ A , ⊢↓ ⊢M ⟩
|
||
|
||
inherit Γ (ƛ x ⇒ N) `ℕ = no (λ())
|
||
inherit Γ (ƛ x ⇒ N) (A ⇒ B) with inherit (Γ , x ⦂ A) N B
|
||
... | no ¬⊢N = no (λ{ (⊢ƛ ⊢N) → ¬⊢N ⊢N })
|
||
... | yes ⊢N = yes (⊢ƛ ⊢N)
|
||
inherit Γ `zero `ℕ = yes ⊢zero
|
||
inherit Γ `zero (A ⇒ B) = no (λ())
|
||
inherit Γ (`suc M) `ℕ with inherit Γ M `ℕ
|
||
... | no ¬⊢M = no (λ{ (⊢suc ⊢M) → ¬⊢M ⊢M })
|
||
... | yes ⊢M = yes (⊢suc ⊢M)
|
||
inherit Γ (`suc M) (A ⇒ B) = no (λ())
|
||
inherit Γ (`case L [zero⇒ M |suc x ⇒ N ]) A with synthesize Γ L
|
||
... | no ¬∃ = no (λ{ (⊢case ⊢L _ _) → ¬∃ ⟨ `ℕ , ⊢L ⟩})
|
||
... | yes ⟨ _ ⇒ _ , ⊢L ⟩ = no (λ{ (⊢case ⊢L′ _ _) → ℕ≢⇒ (uniq-↑ ⊢L′ ⊢L) })
|
||
... | yes ⟨ `ℕ , ⊢L ⟩ with inherit Γ M A
|
||
... | no ¬⊢M = no (λ{ (⊢case _ ⊢M _) → ¬⊢M ⊢M })
|
||
... | yes ⊢M with inherit (Γ , x ⦂ `ℕ) N A
|
||
... | no ¬⊢N = no (λ{ (⊢case _ _ ⊢N) → ¬⊢N ⊢N })
|
||
... | yes ⊢N = yes (⊢case ⊢L ⊢M ⊢N)
|
||
inherit Γ (μ x ⇒ N) A with inherit (Γ , x ⦂ A) N A
|
||
... | no ¬⊢N = no (λ{ (⊢μ ⊢N) → ¬⊢N ⊢N })
|
||
... | yes ⊢N = yes (⊢μ ⊢N)
|
||
inherit Γ (M ↑) B with synthesize Γ M
|
||
... | no ¬∃ = no (λ{ (⊢↑ ⊢M _) → ¬∃ ⟨ _ , ⊢M ⟩ })
|
||
... | yes ⟨ A , ⊢M ⟩ with A ≟Tp B
|
||
... | no A≢B = no (¬switch ⊢M A≢B)
|
||
... | yes A≡B = yes (⊢↑ ⊢M A≡B)
|
||
|
||
-- Copied from Lambda.
|
||
|
||
_≠_ : ∀ (x y : Id) → x ≢ y
|
||
x ≠ y with x ≟ y
|
||
... | no x≢y = x≢y
|
||
... | yes _ = ⊥-elim impossible
|
||
where postulate impossible : ⊥
|
||
|
||
-- Computed by evaluating 'synthesize ∅ 2+2' and editing.
|
||
|
||
⊢2+2 : ∅ ⊢ 2+2 ↑ `ℕ
|
||
⊢2+2 =
|
||
(⊢↓
|
||
(⊢μ
|
||
(⊢ƛ
|
||
(⊢ƛ
|
||
(⊢case (⊢` (S (λ()) Z)) (⊢↑ (⊢` Z) refl)
|
||
(⊢suc
|
||
(⊢↑
|
||
(⊢`
|
||
(S (λ())
|
||
(S (λ())
|
||
(S (λ()) Z)))
|
||
· ⊢↑ (⊢` Z) refl
|
||
· ⊢↑ (⊢` (S (λ()) Z)) refl)
|
||
refl))))))
|
||
· ⊢suc (⊢suc ⊢zero)
|
||
· ⊢suc (⊢suc ⊢zero))
|
||
|
||
-- Check that synthesis is correct (more below).
|
||
|
||
_ : synthesize ∅ 2+2 ≡ yes ⟨ `ℕ , ⊢2+2 ⟩
|
||
_ = refl
|
||
|
||
-- Example: 2+2 for Church numerals.
|
||
|
||
⊢2+2ᶜ : ∅ ⊢ 2+2ᶜ ↑ `ℕ
|
||
⊢2+2ᶜ =
|
||
⊢↓
|
||
(⊢ƛ
|
||
(⊢ƛ
|
||
(⊢ƛ
|
||
(⊢ƛ
|
||
(⊢↑
|
||
(⊢`
|
||
(S (λ())
|
||
(S (λ())
|
||
(S (λ()) Z)))
|
||
· ⊢↑ (⊢` (S (λ()) Z)) refl
|
||
·
|
||
⊢↑
|
||
(⊢`
|
||
(S (λ())
|
||
(S (λ()) Z))
|
||
· ⊢↑ (⊢` (S (λ()) Z)) refl
|
||
· ⊢↑ (⊢` Z) refl)
|
||
refl)
|
||
refl)))))
|
||
·
|
||
⊢ƛ
|
||
(⊢ƛ
|
||
(⊢↑
|
||
(⊢` (S (λ()) Z) ·
|
||
⊢↑ (⊢` (S (λ()) Z) · ⊢↑ (⊢` Z) refl)
|
||
refl)
|
||
refl))
|
||
·
|
||
⊢ƛ
|
||
(⊢ƛ
|
||
(⊢↑
|
||
(⊢` (S (λ()) Z) ·
|
||
⊢↑ (⊢` (S (λ()) Z) · ⊢↑ (⊢` Z) refl)
|
||
refl)
|
||
refl))
|
||
· ⊢ƛ (⊢suc (⊢↑ (⊢` Z) refl))
|
||
· ⊢zero
|
||
|
||
_ : synthesize ∅ 2+2ᶜ ≡ yes ⟨ `ℕ , ⊢2+2ᶜ ⟩
|
||
_ = refl
|
||
|
||
-- Testing error cases.
|
||
|
||
_ : synthesize ∅ ((ƛ "x" ⇒ ` "y" ↑) ↓ (`ℕ ⇒ `ℕ)) ≡ no _
|
||
_ = refl
|
||
|
||
-- Bad argument type.
|
||
|
||
_ : synthesize ∅ (plus · sucᶜ) ≡ no _
|
||
_ = refl
|
||
|
||
-- Bad function types.
|
||
|
||
_ : synthesize ∅ (plus · sucᶜ · two) ≡ no _
|
||
_ = refl
|
||
|
||
_ : synthesize ∅ ((two ↓ `ℕ) · two) ≡ no _
|
||
_ = refl
|
||
|
||
_ : synthesize ∅ (twoᶜ ↓ `ℕ) ≡ no _
|
||
_ = refl
|
||
|
||
-- A natural can't have a function type.
|
||
|
||
_ : synthesize ∅ (`zero ↓ `ℕ ⇒ `ℕ) ≡ no _
|
||
_ = refl
|
||
|
||
_ : synthesize ∅ (two ↓ `ℕ ⇒ `ℕ) ≡ no _
|
||
_ = refl
|
||
|
||
-- Can't hide a bad type.
|
||
|
||
_ : synthesize ∅ (`suc twoᶜ ↓ `ℕ) ≡ no _
|
||
_ = refl
|
||
|
||
-- Can't case on a function type.
|
||
|
||
_ : synthesize ∅
|
||
((`case (twoᶜ ↓ Ch) [zero⇒ `zero |suc "x" ⇒ ` "x" ↑ ] ↓ `ℕ) ) ≡ no _
|
||
_ = refl
|
||
|
||
-- Can't hide a bad type inside case.
|
||
|
||
_ : synthesize ∅
|
||
((`case (twoᶜ ↓ `ℕ) [zero⇒ `zero |suc "x" ⇒ ` "x" ↑ ] ↓ `ℕ) ) ≡ no _
|
||
_ = refl
|
||
|
||
-- Mismatch of inherited and synthesized types.
|
||
|
||
_ : synthesize ∅ (((ƛ "x" ⇒ ` "x" ↑) ↓ `ℕ ⇒ (`ℕ ⇒ `ℕ))) ≡ no _
|
||
_ = refl
|
||
|
||
|
||
-- Erasure: Taking the evidence provided by synthesis on a decorated term
|
||
-- and producing the corresponding inherently-typed term.
|
||
|
||
-- Erasing a type.
|
||
|
||
∥_∥Tp : Type → DB.Type
|
||
∥ `ℕ ∥Tp = DB.`ℕ
|
||
∥ A ⇒ B ∥Tp = ∥ A ∥Tp DB.⇒ ∥ B ∥Tp
|
||
|
||
-- Erasing a context.
|
||
|
||
∥_∥Cx : Context → DB.Context
|
||
∥ ∅ ∥Cx = DB.∅
|
||
∥ Γ , x ⦂ A ∥Cx = ∥ Γ ∥Cx DB., ∥ A ∥Tp
|
||
|
||
-- Erasing a lookup judgment.
|
||
|
||
∥_∥∋ : ∀ {Γ x A} → Γ ∋ x ⦂ A → ∥ Γ ∥Cx DB.∋ ∥ A ∥Tp
|
||
∥ Z ∥∋ = DB.Z
|
||
∥ S x≢ ⊢x ∥∋ = DB.S ∥ ⊢x ∥∋
|
||
|
||
-- Mutually-recursive functions to erase typing judgments.
|
||
|
||
∥_∥⁺ : ∀ {Γ M A} → Γ ⊢ M ↑ A → ∥ Γ ∥Cx DB.⊢ ∥ A ∥Tp
|
||
∥_∥⁻ : ∀ {Γ M A} → Γ ⊢ M ↓ A → ∥ Γ ∥Cx DB.⊢ ∥ A ∥Tp
|
||
|
||
∥ ⊢` ⊢x ∥⁺ = DB.` ∥ ⊢x ∥∋
|
||
∥ ⊢L · ⊢M ∥⁺ = ∥ ⊢L ∥⁺ DB.· ∥ ⊢M ∥⁻
|
||
∥ ⊢↓ ⊢M ∥⁺ = ∥ ⊢M ∥⁻
|
||
|
||
∥ ⊢ƛ ⊢N ∥⁻ = DB.ƛ ∥ ⊢N ∥⁻
|
||
∥ ⊢zero ∥⁻ = DB.`zero
|
||
∥ ⊢suc ⊢M ∥⁻ = DB.`suc ∥ ⊢M ∥⁻
|
||
∥ ⊢case ⊢L ⊢M ⊢N ∥⁻ = DB.case ∥ ⊢L ∥⁺ ∥ ⊢M ∥⁻ ∥ ⊢N ∥⁻
|
||
∥ ⊢μ ⊢M ∥⁻ = DB.μ ∥ ⊢M ∥⁻
|
||
∥ ⊢↑ ⊢M refl ∥⁻ = ∥ ⊢M ∥⁺
|
||
|
||
-- Tests that erasure works.
|
||
|
||
_ : ∥ ⊢2+2 ∥⁺ ≡ DB.2+2
|
||
_ = refl
|
||
|
||
_ : ∥ ⊢2+2ᶜ ∥⁺ ≡ DB.2+2ᶜ
|
||
_ = refl
|
||
|
||
-- PLFA exercise: demonstrate that synthesis on your decorated multiplication
|
||
-- followed by erasure gives your inherently-typed multiplication.
|
||
|
||
-- PLFA exercise: extend the above to include products.
|
||
|
||
-- PLFA exercise (stretch): extend the above to include
|
||
-- the rest of the features added in More.
|
||
|
||
-- Additions by PR:
|
||
|
||
-- From Lambda, with type annotation added
|
||
|
||
data Term : Set where
|
||
`_ : Id → Term
|
||
ƛ_⇒_ : Id → Term → Term
|
||
_·_ : Term → Term → Term
|
||
`zero : Term
|
||
`suc_ : Term → Term
|
||
`case_[zero⇒_|suc_⇒_] : Term → Term → Id → Term → Term
|
||
μ_⇒_ : Id → Term → Term
|
||
_⦂_ : Term → Type → Term
|
||
|
||
-- Mutually-recursive decorators.
|
||
|
||
decorate⁻ : Term → Term⁻
|
||
decorate⁺ : Term → Term⁺
|
||
|
||
decorate⁻ (` x) = ` x ↑
|
||
decorate⁻ (ƛ x ⇒ M) = ƛ x ⇒ decorate⁻ M
|
||
decorate⁻ (M · M₁) = (decorate⁺ M) · (decorate⁻ M₁) ↑
|
||
decorate⁻ `zero = `zero
|
||
decorate⁻ (`suc M) = `suc (decorate⁻ M)
|
||
decorate⁻ `case M [zero⇒ M₁ |suc x ⇒ M₂ ]
|
||
= `case (decorate⁺ M) [zero⇒ (decorate⁻ M₁) |suc x ⇒ (decorate⁻ M₂) ]
|
||
decorate⁻ (μ x ⇒ M) = μ x ⇒ decorate⁻ M
|
||
decorate⁻ (M ⦂ x) = decorate⁻ M
|
||
|
||
decorate⁺ (` x) = ` x
|
||
decorate⁺ (ƛ x ⇒ M) = ⊥-elim impossible
|
||
where postulate impossible : ⊥
|
||
decorate⁺ (M · M₁) = (decorate⁺ M) · (decorate⁻ M₁)
|
||
decorate⁺ `zero = ⊥-elim impossible
|
||
where postulate impossible : ⊥
|
||
decorate⁺ (`suc M) = ⊥-elim impossible
|
||
where postulate impossible : ⊥
|
||
decorate⁺ `case M [zero⇒ M₁ |suc x ⇒ M₂ ] = ⊥-elim impossible
|
||
where postulate impossible : ⊥
|
||
decorate⁺ (μ x ⇒ M) = ⊥-elim impossible
|
||
where postulate impossible : ⊥
|
||
decorate⁺ (M ⦂ x) = decorate⁻ M ↓ x
|
||
|
||
ltwo : Term
|
||
ltwo = `suc `suc `zero
|
||
|
||
lplus : Term
|
||
lplus = (μ "p" ⇒ ƛ "m" ⇒ ƛ "n" ⇒
|
||
`case ` "m"
|
||
[zero⇒ ` "n"
|
||
|suc "m" ⇒ `suc (` "p" · ` "m" · ` "n") ])
|
||
⦂ (`ℕ ⇒ `ℕ ⇒ `ℕ)
|
||
|
||
l2+2 : Term
|
||
l2+2 = lplus · ltwo · ltwo
|
||
|
||
ltwoᶜ : Term
|
||
ltwoᶜ = ƛ "s" ⇒ ƛ "z" ⇒ ` "s" · (` "s" · ` "z")
|
||
|
||
lplusᶜ : Term
|
||
lplusᶜ = (ƛ "m" ⇒ ƛ "n" ⇒ ƛ "s" ⇒ ƛ "z" ⇒
|
||
` "m" · ` "s" · (` "n" · ` "s" · ` "z"))
|
||
⦂ (Ch ⇒ Ch ⇒ Ch)
|
||
|
||
lsucᶜ : Term
|
||
lsucᶜ = ƛ "x" ⇒ `suc (` "x")
|
||
|
||
l2+2ᶜ : Term
|
||
l2+2ᶜ = lplusᶜ · ltwoᶜ · ltwoᶜ · lsucᶜ · `zero
|
||
|
||
_ : decorate⁻ ltwo ≡ two
|
||
_ = refl
|
||
|
||
_ : decorate⁺ lplus ≡ plus
|
||
_ = refl
|
||
|
||
_ : decorate⁺ l2+2 ≡ 2+2
|
||
_ = refl
|
||
|
||
_ : decorate⁻ ltwoᶜ ≡ twoᶜ
|
||
_ = refl
|
||
|
||
_ : decorate⁺ lplusᶜ ≡ plusᶜ
|
||
_ = refl
|
||
|
||
_ : decorate⁻ lsucᶜ ≡ sucᶜ
|
||
_ = refl
|
||
|
||
_ : decorate⁺ l2+2ᶜ ≡ 2+2ᶜ
|
||
_ = refl
|
||
|
||
|
||
{-
|
||
Unicode used in this chapter:
|
||
|
||
↓ U+2193: DOWNWARDS ARROW (\d)
|
||
↑ U+2191: UPWARDS ARROW (\u)
|
||
∥ U+2225: PARALLEL TO (\||)
|
||
|
||
-}
|