├── .gitignore ├── AGT.agda ├── AGTCalculus.agda ├── AGTSub.agda ├── AbstractMachine.agda ├── BigStep ├── BigStepGas.agda ├── Cast.agda ├── CastBigStep.agda └── GradualGuarantee.agda ├── CastStructure.agda ├── CastStructureABT.agda ├── CastStructureOrig.agda ├── CastStructureWithBlameSafety.agda ├── CastStructureWithBlameSafetyABT.agda ├── CastStructureWithPrecision.agda ├── CastStructureWithPrecisionABT.agda ├── CoercionsS.lagda ├── CompilePresPrec.agda ├── Denot ├── CastStructureOmni.agda ├── CastStructureRegular.agda ├── CastStructureRegularInj.agda ├── ConsisOmni.agda ├── ConsisRegular.agda ├── ConsisRegularInj.agda ├── GTLC.agda ├── GroundCoercions.agda ├── GroundCoercionsOmniscient.agda ├── LazyCoercions.agda ├── LazyCoercionsOmniscient.agda ├── LazyCoercionsOmniscientOld.agda ├── LazyCoercionsOmniscientOlder.agda ├── LazyCoercionsRegular.agda ├── LazyCoercionsRegularInj.agda ├── LazyCoercionsRegularOld.agda ├── OmniGroundCoercions.agda ├── OmniLazyCoercions.agda ├── OpOmni.agda ├── OpRegular.agda ├── OpRegularInj.agda ├── ParamCC.agda ├── SoundnessLazyCoercionsRegular.agda ├── Value.agda └── ValueInj.agda ├── DenotCoercions.agda ├── DenotGTLC.agda ├── EagerCoercions.agda ├── EfficientGroundCoercions.agda ├── EfficientParamCastAux.agda ├── EfficientParamCasts.agda ├── EfficientParamCastsEF.agda ├── EquivCast.agda ├── EquivLamBLamC.agda ├── ForgetfulCast.agda ├── GTLC-materialize.agda ├── GTLC.agda ├── GTLC2CC.agda ├── GTLC2CCOrig.agda ├── GTLCPrecision.agda ├── GenericPredicate.agda ├── GroundCast.agda ├── GroundCastBlame.agda ├── GroundCastGG.agda ├── GroundCoercions.agda ├── GroundCoercionsABT.agda ├── GroundCoercionsBlame.agda ├── GroundInertX.agda ├── GroundInertXBlame.agda ├── GroundInertXGG.agda ├── GroundMachine.agda ├── HyperCoercions.agda ├── InjProj ├── CastCalculus.agda ├── CastDeterministic.agda ├── CastSafe.agda ├── Precision.agda └── Reduction.agda ├── Labels.agda ├── LambdaC └── CastCalculus.agda ├── LazyCast.agda ├── LazyCastBlame.agda ├── LazyCoercions.agda ├── LazyCoercionsABT.agda ├── LazyCoercionsBlame.agda ├── LazyGroundCast.agda ├── LazyGroundCastDenot.agda ├── LogRel ├── BindLemma.agda ├── BlogGradualGuaranteeLogRel.lagda.md ├── CompatibilityLemmas.agda ├── GradualGuarantee.agda ├── LogRel.agda ├── Makefile ├── PeterCastCalculus.lagda ├── PeterFundamental.lagda ├── PeterFundamental2.lagda ├── PeterGG.lagda ├── PeterLogRel.lagda ├── PeterLogRel2.lagda ├── PeterPrecision.lagda ├── README.md ├── README.md~ ├── extra │ └── LogRel.agda ├── junk │ ├── CastBind.agda │ ├── CastBindDir.agda │ ├── CastCompatibility.agda │ ├── CastCompatibilityDir.agda │ ├── CastFundamental.agda │ ├── CastGradualGuarantee.agda │ ├── CastLogRel.agda │ ├── CastLogRelDir.agda │ └── CastPrec.agda └── latex │ ├── LogRel │ ├── PeterFestschrift.tex │ ├── agda.sty │ ├── all.bib │ ├── eptcs.bst │ ├── eptcs.cls │ ├── eptcsalpha.bst │ ├── eptcsalphaini.bst │ ├── eptcsini.bst │ ├── generic.bib │ └── main.tex │ └── agda.sty ├── MakeCastCalculus.agda ├── Makefile ├── NewType └── CastCalculus.agda ├── ParamBlameSubtyping.agda ├── ParamBlameSubtypingABT.agda ├── ParamCCPrecision.agda ├── ParamCCPrecisionABT.agda ├── ParamCCSyntaxABT.agda ├── ParamCastAux.agda ├── ParamCastAuxABT.agda ├── ParamCastAuxOrig.agda ├── ParamCastCalculus.agda ├── ParamCastCalculusABT.agda ├── ParamCastCalculusOrig.agda ├── ParamCastDeterministic.agda ├── ParamCastReduction.agda ├── ParamCastReductionABT.agda ├── ParamCastReductionEta.agda ├── ParamCastReductionOrig.agda ├── ParamCastSubtyping.agda ├── ParamCastSubtypingABT.agda ├── ParamGradualGuarantee.agda ├── ParamGradualGuaranteeABT.agda ├── ParamGradualGuaranteeAux.agda ├── ParamGradualGuaranteeSim.agda ├── Poly ├── AlgoPrecision.agda ├── CastCalculus.agda ├── Compile.agda ├── Gradual.agda ├── PresBeta.agda ├── PresCastFun.agda ├── PresCastInst.agda ├── PresCastSeq.agda ├── PresCollapse.agda ├── PresGen.agda ├── PresReveal.agda ├── PresTypeBeta.agda ├── SetsAsPredicates.agda ├── Types.agda ├── TypesXAlpha.agda └── notes.md ├── Pow2.agda ├── PreCastStructure.agda ├── PreCastStructureWithBlameSafety.agda ├── PreCastStructureWithPrecision.agda ├── PrecisionSimulationABT.agda ├── PreserveHeight.agda ├── PreservePrecisionABT.agda ├── PrimitiveTypes.agda ├── README.md ├── RawLogRel ├── BindLemma.agda ├── BindLemma.agda~ ├── CompatibilityLemmas.agda ├── CompatibilityLemmas.agda~ ├── GradualGuarantee.agda ├── GradualGuarantee.agda~ ├── LogRel.agda └── LogRel.agda~ ├── SimpleCast.agda ├── SimpleCastBlame.agda ├── SimpleCoercions.agda ├── SimpleCoercionsBlame.agda ├── SimpleFunCast.agda ├── SimpleFunCastBlame.agda ├── SpaceEfficient.agda ├── StaticGradualGuarantee.agda ├── Subtyping.agda ├── Types.agda ├── Types2.agda ├── TypesRef.agda ├── Variables.agda ├── gradual-typing.agda-lib └── notes-poly-blame.md /.gitignore: -------------------------------------------------------------------------------- 1 | ## Agda files 2 | *.agdai 3 | .agda-stdlib.sed 4 | .links-*.sed 5 | 6 | ## Jekyll files 7 | _site/ 8 | .sass-cache/ 9 | .agda-stdlib.sed 10 | .jekyll-metadata 11 | Gemfile.lock 12 | 13 | ## LaTeX files 14 | *.aux 15 | *.bbl 16 | *.blg 17 | *.fdb_latexmk 18 | *.fls 19 | *.log 20 | *.pdf 21 | *.spl 22 | *.synctex.gz 23 | 24 | ## Emacs files 25 | auto/ -------------------------------------------------------------------------------- /AGTSub.agda: -------------------------------------------------------------------------------- 1 | module AGTSub where 2 | 3 | {- 4 | consistent subtyping 5 | ≲ 6 | -} 7 | -------------------------------------------------------------------------------- /BigStep/BigStepGas.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module BigStep.BigStepGas where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Maybe 6 | open import Data.Nat 7 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 8 | open import Data.Nat.Properties 9 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 10 | open import Data.Unit using (⊤; tt) 11 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 12 | open import Data.Empty using (⊥; ⊥-elim) 13 | open import Data.Sum using (_⊎_; inj₁; inj₂) 14 | open import Relation.Binary.PropositionalEquality as Eq 15 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 16 | open import Relation.Nullary using (¬_; Dec; yes; no) 17 | open import Var 18 | open import BigStep.Cast 19 | 20 | {- 21 | Counts function application. 22 | -} 23 | 24 | infixr 6 _⇓_#_ 25 | data _⇓_#_ : Term → Term → ℕ → Set where 26 | {- 27 | zero⇓ : ∀{M}{N} 28 | -------------- 29 | → (M ⇓ N # zero) 30 | -} 31 | 32 | lit⇓ : ∀{c}{k} 33 | ----------- 34 | → ($ c ⇓ $ c # suc k) 35 | 36 | lam⇓ : ∀{N}{k} 37 | ----------- 38 | → (ƛ N ⇓ ƛ N # suc k) 39 | 40 | app⇓ : ∀{L M N W V k} 41 | → L ⇓ ƛ N # (suc k) 42 | → M ⇓ W # (suc k) 43 | → Value W 44 | → N [ W ] ⇓ V # k 45 | → Value V 46 | ------------------- 47 | → L · M ⇓ V # (suc k) 48 | 49 | app⇓-blame-L : ∀{L M}{k} 50 | → L ⇓ blame # (suc k) 51 | ----------------------- 52 | → L · M ⇓ blame # (suc k) 53 | 54 | app⇓-blame-R : ∀{L M V}{k} 55 | → L ⇓ V # (suc k) 56 | → Value V 57 | → M ⇓ blame # (suc k) 58 | --------------------- 59 | → L · M ⇓ blame # suc k 60 | 61 | app⇓blame : ∀{L M N W k} 62 | → L ⇓ ƛ N # (suc k) 63 | → M ⇓ W # (suc k) 64 | → Value W 65 | → N [ W ] ⇓ blame # k 66 | ------------------- 67 | → L · M ⇓ blame # (suc k) 68 | 69 | inj⇓ : ∀{M V G}{k} 70 | → M ⇓ V # (suc k) 71 | → Value V 72 | ----------------------------- 73 | → M ⟨ G !⟩ ⇓ V ⟨ G !⟩ # (suc k) 74 | 75 | inj⇓-blame : ∀{M G}{k} 76 | → M ⇓ blame # (suc k) 77 | -------------------------- 78 | → M ⟨ G !⟩ ⇓ blame # (suc k) 79 | 80 | proj⇓-blame : ∀{M H}{k} 81 | → M ⇓ blame # (suc k) 82 | -------------------------- 83 | → M ⟨ H ?⟩ ⇓ blame # (suc k) 84 | 85 | collapse⇓ : ∀{M V G}{k} 86 | → M ⇓ V ⟨ G !⟩ # (suc k) 87 | ---------------------- 88 | → M ⟨ G ?⟩ ⇓ V # (suc k) 89 | 90 | collide⇓ : ∀{M V G H}{k} 91 | → M ⇓ V ⟨ G !⟩ # (suc k) 92 | → G ≢ H 93 | --------------------------- 94 | → M ⟨ H ?⟩ ⇓ blame # (suc k) 95 | 96 | blame⇓ : ∀{k} 97 | ----------------------- 98 | → blame ⇓ blame # (suc k) 99 | 100 | {- 101 | downClosed⇓ : ∀{M}{N}{k}{j} 102 | → M ⇓ N # k 103 | → j ≤ k 104 | → M ⇓ N # j 105 | downClosed⇓ {M} {N} {zero} {.zero} M⇓N z≤n = zero⇓ 106 | downClosed⇓ {M} {N} {suc k} {.zero} M⇓N z≤n = zero⇓ 107 | downClosed⇓ {.($ _)} {.($ _)} {suc k} {suc j} lit⇓ (s≤s j≤k) = lit⇓ 108 | downClosed⇓ {.(ƛ _)} {.(ƛ _)} {suc k} {suc j} lam⇓ (s≤s j≤k) = lam⇓ 109 | downClosed⇓ {.(_ · _)} {N} {suc k} {suc j} (app⇓ L⇓λN M⇓W w NW⇓V) (s≤s j≤k) = 110 | app⇓ (downClosed⇓ L⇓λN (s≤s j≤k)) (downClosed⇓ M⇓W (s≤s j≤k)) 111 | w (downClosed⇓ NW⇓V j≤k) 112 | downClosed⇓ {.(_ · _)} {.blame} {suc k} {suc j} (app⇓-blame-L M⇓N) (s≤s j≤k) = 113 | app⇓-blame-L (downClosed⇓ M⇓N (s≤s j≤k)) 114 | downClosed⇓ {.(_ · _)} {.blame} {suc k} {suc j} (app⇓-blame-R L⇓V v M⇓W) 115 | (s≤s j≤k) = 116 | app⇓-blame-R (downClosed⇓ L⇓V (s≤s j≤k)) v (downClosed⇓ M⇓W (s≤s j≤k)) 117 | downClosed⇓ {.(_ ⟨ _ !⟩)} {.(_ ⟨ _ !⟩)} {suc k} {suc j} (inj⇓ M⇓V v) 118 | (s≤s j≤k) = 119 | inj⇓ (downClosed⇓ M⇓V (s≤s j≤k)) v 120 | downClosed⇓ {.(_ ⟨ _ !⟩)} {.blame} {suc k} {suc j} (inj⇓-blame M⇓N) (s≤s j≤k) = 121 | inj⇓-blame (downClosed⇓ M⇓N (s≤s j≤k)) 122 | downClosed⇓ {.(_ ⟨ _ ?⟩)} {.blame} {suc k} {suc j} (proj⇓-blame M⇓N) (s≤s j≤k) = 123 | proj⇓-blame (downClosed⇓ M⇓N (s≤s j≤k)) 124 | downClosed⇓ {.(_ ⟨ _ ?⟩)} {N} {suc k} {suc j} (collapse⇓ M⇓N) (s≤s j≤k) = 125 | collapse⇓ (downClosed⇓ M⇓N (s≤s j≤k)) 126 | downClosed⇓ {.(_ ⟨ _ ?⟩)} {.blame} {suc k} {suc j} (collide⇓ M⇓N x) (s≤s j≤k) = 127 | collide⇓ (downClosed⇓ M⇓N (s≤s j≤k)) x 128 | downClosed⇓ {.blame} {.blame} {suc k} {suc j} blame⇓ (s≤s j≤k) = blame⇓ 129 | -} 130 | -------------------------------------------------------------------------------- /BigStep/GradualGuarantee.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module BigStep.GradualGuarantee where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Maybe 6 | open import Data.Nat 7 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 8 | open import Data.Nat.Properties 9 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 10 | open import Data.Unit using (⊤; tt) 11 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 12 | open import Data.Empty using (⊥; ⊥-elim) 13 | open import Data.Sum using (_⊎_; inj₁; inj₂) 14 | open import Relation.Binary.PropositionalEquality as Eq 15 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 16 | open import Relation.Nullary using (¬_; Dec; yes; no) 17 | open import Var 18 | open import BigStep.Cast 19 | open import BigStep.BigStepGas 20 | 21 | Val : Set 22 | Val = ∃[ V ] Value V 23 | 24 | trm : Val → Term 25 | trm (V , v) = V 26 | 27 | val : (v : Val) → Value (trm v) 28 | val (V , v) = v 29 | 30 | _⊑̬_ : Val → Val → ℕ → Set 31 | (V ⊑̬ V′) zero = ⊤ 32 | (($ c , _) ⊑̬ ($ c′ , _)) (suc k) = c ≡ c′ 33 | (($ c , _) ⊑̬ V′) (suc k) = ⊥ 34 | ((ƛ N , _) ⊑̬ (ƛ N′ , _)) (suc k) = 35 | (∀ {W W′ V′ : Val} 36 | → (W ⊑̬ W′) k → N′ [ trm W′ ] ⇓ trm V′ # k 37 | → ∃[ V ] N [ trm W ] ⇓ trm V # k × (V ⊑̬ V′) k) 38 | 39 | ((ƛ N , _) ⊑̬ V′) (suc k) = ⊥ 40 | ((V ⟨ G !⟩ , v 〈 _ 〉) ⊑̬ (V′ ⟨ H !⟩ , v′ 〈 _ 〉)) (suc k) 41 | with G ≡ᵍ H 42 | ... | yes refl = ((V , v) ⊑̬ (V′ , v′)) k 43 | ... | no neq = ⊥ 44 | ((V ⟨ G !⟩ , v 〈 _ 〉) ⊑̬ v′) (suc k) = ⊥ 45 | 46 | postulate downClosed⊑̬ : ∀{V}{V′}{k}{j} → (V ⊑̬ V′) k → j ≤ k → (V ⊑̬ V′) j 47 | 48 | ⊑̬-lam-R-inv : ∀{V : Val}{N′}{k} 49 | → (V ⊑̬ (ƛ N′ , ƛ̬ N′)) (suc k) 50 | → ∃[ N ] V ≡ (ƛ N , ƛ̬ N) × 51 | (∀ {W W′ V′ : Val} 52 | → (W ⊑̬ W′) k → N′ [ trm W′ ] ⇓ trm V′ # k 53 | → ∃[ V ] N [ trm W ] ⇓ trm V # k × (V ⊑̬ V′) k) 54 | ⊑̬-lam-R-inv {.(ƛ N) , (ƛ̬ N)} {N′} {k} V⊑λN′ = N , (refl , V⊑λN′) 55 | 56 | {- 57 | ⊑-lam-R-inv : ∀{V}{N′}{A}{B}{A′}{B′}{A⊑A′ : A ⊑ A′}{B⊑B′ : B ⊑ B′} 58 | → Value V 59 | → [] ⊩ V ⊑ ƛ N′ ⦂ fun⊑ A⊑A′ B⊑B′ 60 | → ∃[ N ] V ≡ ƛ N × (A , A′ , A⊑A′) ∷ [] ⊩ N ⊑ N′ ⦂ B⊑B′ 61 | ⊑-lam-R-inv {.(ƛ N)} (ƛ̬ N) (⊑-lam N⊑N′) = N , refl , N⊑N′ 62 | -} 63 | 64 | sim : ∀{A}{A′}{A⊑A′ : A ⊑ A′}{M}{M′}{V′ : Val}{k} 65 | → [] ⊩ M ⊑ M′ ⦂ A⊑A′ 66 | → M′ ⇓ trm V′ # k 67 | → ∃[ V ] M ⇓ trm V # k × (V ⊑̬ V′) k 68 | 69 | sim {_} {_} {.base⊑} {$ c} {$ c} ⊑-lit lit⇓ = ($ c , $̬ c) , lit⇓ , refl 70 | sim {A} {A′} {A⊑A′} {.(_ · _)} {.(_ · _)}{k = suc k} (⊑-app L⊑L′ M⊑M′) 71 | (app⇓{N = N′}{W = W′}{V = V′} L′⇓λN′ M′⇓W′ w′ NW′⇓V′ v′) 72 | with sim{V′ = (ƛ N′ , ƛ̬ N′)} L⊑L′ L′⇓λN′ | sim{V′ = (W′ , w′)} M⊑M′ M′⇓W′ 73 | ... | (λN , v) , L⇓V , V⊑λN | (W , w) , M⇓W , W⊑W′ 74 | with ⊑̬-lam-R-inv{V = (λN , v)}{N′ = N′}{k} V⊑λN 75 | ... | N , refl , body 76 | with body{(W , w)}{(W′ , w′)}{V′ , v′} 77 | (downClosed⊑̬ W⊑W′ (n≤1+n k)) NW′⇓V′ 78 | ... | (V , v) , NW⇓V , V⊑V′ = 79 | (V , v) , ((app⇓ L⇓V M⇓W w NW⇓V v) , {!V⊑V′!}) 80 | {- 81 | V⊑V′ : ((V , v) ⊑̬ (proj₁ V′₁ , v′)) k 82 | Goal: ((V , v) ⊑̬ V′₁) (suc k) 83 | -} 84 | 85 | sim {.(_ ⇒ _)} {.(_ ⇒ _)} {.(fun⊑ _ _)} {.(ƛ _)} {.(ƛ _)} (⊑-lam M⊑M′) M′⇓V′ = {!!} 86 | sim {.★} {A′} {.unk⊑} {.(_ ⟨ _ !⟩)} {M′} (⊑-inj-L M⊑M′) M′⇓V′ = {!!} 87 | sim {.★} {.★} {.unk⊑} {M} {.(_ ⟨ _ !⟩)} (⊑-inj-R M⊑M′) M′⇓V′ = {!!} 88 | sim {.(gnd⇒ty _)} {A′} {A⊑A′} {.(_ ⟨ _ ?⟩)} {M′} (⊑-proj-L M⊑M′) M′⇓V′ = {!!} 89 | sim {.★} {.(gnd⇒ty _)} {A⊑A′} {M} {.(_ ⟨ _ ?⟩)} (⊑-proj-R M⊑M′) M′⇓V′ = {!!} 90 | sim {A} {.A} {.Refl⊑} {M} {.blame} (⊑-blame x) M′⇓V′ = {!!} 91 | -------------------------------------------------------------------------------- /CastStructure.agda: -------------------------------------------------------------------------------- 1 | open import Types hiding (_⊔_) 2 | open import Variables 3 | open import PreCastStructure 4 | 5 | open import Data.Bool using (Bool; true; false) 6 | open import Data.Nat using (ℕ; _≤_; _⊔_; _+_; _*_) 7 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 8 | renaming (_,_ to ⟨_,_⟩) 9 | open import Data.Sum using (_⊎_; inj₁; inj₂) 10 | open import Data.Maybe using (Maybe; just; nothing) 11 | open import Relation.Binary.PropositionalEquality 12 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 13 | open import Relation.Nullary using (¬_) 14 | open import Pow2 15 | 16 | module CastStructure where 17 | 18 | import ParamCastCalculus 19 | import ParamCastCalculusOrig 20 | import ParamCastAux 21 | import EfficientParamCastAux 22 | 23 | {- 24 | 25 | We need a few operations to define reduction in a generic way. 26 | In particular, we need parameters that say how to reduce casts and 27 | how to eliminate values wrapped in casts. 28 | * The applyCast parameter, applies an Active cast to a value. 29 | * The funCast parameter applies a function wrapped in an inert cast 30 | to an argument. 31 | * The fstCast and sndCast parameters take the first or second part 32 | of a pair wrapped in an inert cast. 33 | * The caseCast performs a case-elimination on a value of sum type (inl or inr) 34 | that is wrapped in an inert cast. 35 | * The baseNotInert parameter ensures that every cast to a base type 36 | is not inert. 37 | 38 | We define a nested module named Reduction with these parameters 39 | because they all depend on parameters of the outer module, and it 40 | seems that Agda does not allow parameters to depend on other 41 | parameters of the same module. 42 | 43 | -} 44 | 45 | record CastStruct : Set₁ where 46 | field 47 | precast : PreCastStruct 48 | open PreCastStruct precast public 49 | open ParamCastCalculus Cast Inert 50 | open ParamCastAux precast 51 | field 52 | applyCast : ∀{Γ A B} → (M : Γ ⊢ A) → Value M → (c : Cast (A ⇒ B)) 53 | → ∀ {a : Active c} → Γ ⊢ B 54 | 55 | 56 | record EfficientCastStruct : Set₁ where 57 | field 58 | precast : PreCastStruct 59 | open PreCastStruct precast public 60 | open ParamCastCalculusOrig Cast 61 | open EfficientParamCastAux precast 62 | field 63 | applyCast : ∀{Γ A B} → (M : Γ ⊢ A) → SimpleValue M → (c : Cast (A ⇒ B)) 64 | → ∀ {a : Active c} → Γ ⊢ B 65 | compose : ∀{A B C} → (c : Cast (A ⇒ B)) → (d : Cast (B ⇒ C)) → Cast (A ⇒ C) 66 | height : ∀{A B} → (c : Cast (A ⇒ B)) → ℕ 67 | compose-height : ∀{A B C} → (c : Cast (A ⇒ B)) → (d : Cast (B ⇒ C)) 68 | → height (compose c d) ≤ (height c) ⊔ (height d) 69 | applyCastOK : ∀{Γ A B}{M : Γ ⊢ A}{c : Cast (A ⇒ B)}{n}{a} 70 | → n ∣ false ⊢ M ok → (v : SimpleValue M) 71 | → Σ[ m ∈ ℕ ] m ∣ false ⊢ applyCast M v c {a} ok × m ≤ 2 + n 72 | 73 | c-height : ∀{Γ A} (M : Γ ⊢ A) → ℕ 74 | c-height (` x) = 0 75 | c-height (ƛ M) = c-height M 76 | c-height (L · M) = c-height L ⊔ c-height M 77 | c-height ($ x) = 0 78 | c-height (if L M N) = c-height L ⊔ c-height M ⊔ c-height N 79 | c-height (cons M N) = c-height M ⊔ c-height N 80 | c-height (fst M) = c-height M 81 | c-height (snd M) = c-height M 82 | c-height (inl M) = c-height M 83 | c-height (inr M) = c-height M 84 | c-height (case L M N) = c-height L ⊔ c-height M ⊔ c-height N 85 | c-height (M ⟨ c ⟩) = c-height M ⊔ height c 86 | c-height (blame ℓ) = 0 87 | 88 | 89 | record EfficientCastStructHeight : Set₁ where 90 | field 91 | effcast : EfficientCastStruct 92 | open EfficientCastStruct effcast public 93 | open ParamCastCalculus Cast 94 | open EfficientParamCastAux precast 95 | 96 | field 97 | applyCast-height : ∀{Γ}{A B}{V}{v : SimpleValue {Γ} V}{c : Cast (A ⇒ B)} 98 | {a : Active c} 99 | → c-height (applyCast V v c {a}) ≤ c-height V ⊔ height c 100 | dom-height : ∀{A B C D}{c : Cast ((A ⇒ B) ⇒ (C ⇒ D))}.{x : Cross c} 101 | → height (dom c x) ≤ height c 102 | cod-height : ∀{A B C D}{c : Cast ((A ⇒ B) ⇒ (C ⇒ D))}.{x : Cross c} 103 | → height (cod c x) ≤ height c 104 | fst-height : ∀{A B C D}{c : Cast (A `× B ⇒ C `× D)}.{x : Cross c} 105 | → height (fstC c x) ≤ height c 106 | snd-height : ∀{A B C D}{c : Cast (A `× B ⇒ C `× D)}.{x : Cross c} 107 | → height (sndC c x) ≤ height c 108 | inlC-height : ∀{A B C D}{c : Cast (A `⊎ B ⇒ C `⊎ D)}.{x : Cross c} 109 | → height (inlC c x) ≤ height c 110 | inrC-height : ∀{A B C D}{c : Cast (A `⊎ B ⇒ C `⊎ D)}.{x : Cross c} 111 | → height (inrC c x) ≤ height c 112 | size : ∀{A B} → (c : Cast (A ⇒ B)) → ℕ 113 | size-height : Σ[ c1 ∈ ℕ ] Σ[ c2 ∈ ℕ ] 1 ≤ c2 × 114 | ∀{A B}(c : Cast (A ⇒ B)) → c1 + size c ≤ c2 * pow2 (height c) 115 | 116 | -------------------------------------------------------------------------------- /CastStructureABT.agda: -------------------------------------------------------------------------------- 1 | open import Data.Bool using (Bool; true; false) 2 | open import Data.Nat using (ℕ; _≤_; _⊔_; _+_; _*_) 3 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 4 | renaming (_,_ to ⟨_,_⟩) 5 | open import Data.Sum using (_⊎_; inj₁; inj₂) 6 | open import Data.Maybe using (Maybe; just; nothing) 7 | open import Relation.Binary.PropositionalEquality 8 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 9 | open import Relation.Nullary using (¬_) 10 | 11 | open import Types hiding (_⊔_) 12 | open import PreCastStructure 13 | open import Pow2 14 | 15 | 16 | module CastStructureABT where 17 | 18 | import ParamCastCalculusABT 19 | import ParamCastAuxABT 20 | -- import EfficientParamCastAux 21 | 22 | 23 | record CastStruct : Set₁ where 24 | field 25 | precast : PreCastStruct 26 | open PreCastStruct precast public 27 | open ParamCastCalculusABT precast 28 | open ParamCastAuxABT precast 29 | field 30 | applyCast : ∀ {Γ A B} → (V : Term) → Γ ⊢ V ⦂ A → Value V → (c : Cast (A ⇒ B)) 31 | → {a : Active c} → Term 32 | 33 | -- cast application is well-typed 34 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 35 | → (⊢V : Γ ⊢ V ⦂ A) 36 | → (v : Value V) → (a : Active c) 37 | -------------------------------- 38 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 39 | -------------------------------------------------------------------------------- /CastStructureOrig.agda: -------------------------------------------------------------------------------- 1 | open import Types hiding (_⊔_) 2 | open import Variables 3 | open import PreCastStructure 4 | 5 | open import Data.Nat using (ℕ; _≤_; _⊔_) 6 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 7 | renaming (_,_ to ⟨_,_⟩) 8 | open import Data.Sum using (_⊎_; inj₁; inj₂) 9 | open import Data.Maybe using (Maybe; just; nothing) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Relation.Nullary using (¬_) 13 | 14 | module CastStructureOrig where 15 | 16 | import ParamCastCalculusOrig 17 | import ParamCastAuxOrig 18 | import EfficientParamCastAux 19 | 20 | {- 21 | 22 | We need a few operations to define reduction in a generic way. 23 | In particular, we need parameters that say how to reduce casts and 24 | how to eliminate values wrapped in casts. 25 | * The applyCast parameter, applies an Active cast to a value. 26 | * The funCast parameter applies a function wrapped in an inert cast 27 | to an argument. 28 | * The fstCast and sndCast parameters take the first or second part 29 | of a pair wrapped in an inert cast. 30 | * The caseCast performs a case-elimination on a value of sum type (inl or inr) 31 | that is wrapped in an inert cast. 32 | * The baseNotInert parameter ensures that every cast to a base type 33 | is not inert. 34 | 35 | We define a nested module named Reduction with these parameters 36 | because they all depend on parameters of the outer module, and it 37 | seems that Agda does not allow parameters to depend on other 38 | parameters of the same module. 39 | 40 | -} 41 | 42 | record CastStruct : Set₁ where 43 | field 44 | precast : PreCastStruct 45 | open PreCastStruct precast public 46 | open ParamCastCalculusOrig Cast 47 | open ParamCastAuxOrig precast 48 | field 49 | applyCast : ∀{Γ A B} → (M : Γ ⊢ A) → Value M → (c : Cast (A ⇒ B)) 50 | → ∀ {a : Active c} → Γ ⊢ B 51 | 52 | record EfficientCastStruct : Set₁ where 53 | field 54 | precast : PreCastStruct 55 | open PreCastStruct precast public 56 | open ParamCastCalculusOrig Cast 57 | open EfficientParamCastAux precast 58 | field 59 | applyCast : ∀{Γ A B} → (M : Γ ⊢ A) → Value M → (c : Cast (A ⇒ B)) 60 | → ∀ {a : Active c} → Γ ⊢ B 61 | compose : ∀{A B C} → (c : Cast (A ⇒ B)) → (d : Cast (B ⇒ C)) → Cast (A ⇒ C) 62 | height : ∀{A B} → (c : Cast (A ⇒ B)) → ℕ 63 | compose-height : ∀{A B C} → (c : Cast (A ⇒ B)) → (d : Cast (B ⇒ C)) 64 | → height (compose c d) ≤ (height c) ⊔ (height d) 65 | -------------------------------------------------------------------------------- /CastStructureWithBlameSafety.agda: -------------------------------------------------------------------------------- 1 | open import Types 2 | open import Variables 3 | open import PreCastStructureWithBlameSafety 4 | open import CastStructure 5 | 6 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 7 | renaming (_,_ to ⟨_,_⟩) 8 | open import Data.Sum using (_⊎_; inj₁; inj₂) 9 | open import Data.Maybe using (Maybe; just; nothing) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Relation.Nullary using (¬_) 13 | 14 | 15 | module CastStructureWithBlameSafety where 16 | 17 | import ParamCastCalculus 18 | import ParamCastAux 19 | import ParamCastSubtyping 20 | import EfficientParamCastAux 21 | 22 | record CastStructWithBlameSafety : Set₁ where 23 | field 24 | pcss : PreCastStructWithBlameSafety 25 | open PreCastStructWithBlameSafety pcss public 26 | open ParamCastCalculus Cast Inert 27 | open ParamCastAux precast 28 | open ParamCastSubtyping pcss 29 | field 30 | applyCast : ∀{Γ A B} → (M : Γ ⊢ A) → Value M → (c : Cast (A ⇒ B)) 31 | → ∀ {a : Active c} → Γ ⊢ B 32 | {- The field is for blame-subtyping. -} 33 | applyCast-pres-allsafe : ∀ {Γ A B} {V : Γ ⊢ A} {vV : Value V} {c : Cast (A ⇒ B)} {ℓ} 34 | → (a : Active c) 35 | → CastBlameSafe c ℓ 36 | → CastsAllSafe V ℓ 37 | -------------------------------------- 38 | → CastsAllSafe (applyCast V vV c {a}) ℓ 39 | 40 | cs : CastStruct 41 | cs = record { precast = precast; applyCast = applyCast } 42 | -------------------------------------------------------------------------------- /CastStructureWithBlameSafetyABT.agda: -------------------------------------------------------------------------------- 1 | open import Types 2 | open import Labels 3 | open import Variables 4 | open import PreCastStructureWithBlameSafety 5 | open import CastStructureABT 6 | 7 | 8 | module CastStructureWithBlameSafetyABT where 9 | 10 | import ParamCastCalculusABT 11 | import ParamCastAuxABT 12 | import ParamCastSubtypingABT 13 | -- import EfficientParamCastAux 14 | 15 | record CastStructWithBlameSafety : Set₁ where 16 | field 17 | pcss : PreCastStructWithBlameSafety 18 | open PreCastStructWithBlameSafety pcss public 19 | open ParamCastCalculusABT precast 20 | open ParamCastAuxABT precast 21 | open ParamCastSubtypingABT pcss 22 | field 23 | {- The usual `CastStruct` fields. -} 24 | applyCast : ∀ {Γ A B} → (V : Term) → Γ ⊢ V ⦂ A → Value V → (c : Cast (A ⇒ B)) 25 | → {a : Active c} → Term 26 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 27 | → (⊢V : Γ ⊢ V ⦂ A) 28 | → (v : Value V) → (a : Active c) 29 | -------------------------------- 30 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 31 | {- This field is for blame-subtyping. -} 32 | applyCast-pres-SafeFor : ∀ {Γ A B} {V : Term} {v : Value V} {c : Cast (A ⇒ B)} {ℓ} 33 | → (⊢V : Γ ⊢ V ⦂ A) 34 | → (a : Active c) 35 | → CastBlameSafe c ℓ 36 | → V SafeFor ℓ 37 | -------------------------------------- 38 | → (applyCast V ⊢V v c {a}) SafeFor ℓ 39 | 40 | cs : CastStruct 41 | cs = record { 42 | precast = precast; 43 | applyCast-wt = applyCast-wt; 44 | applyCast = applyCast 45 | } 46 | -------------------------------------------------------------------------------- /CastStructureWithPrecision.agda: -------------------------------------------------------------------------------- 1 | open import Relation.Binary.PropositionalEquality using (_≡_;_≢_; refl; trans; sym; cong) 2 | open import Data.Product using (_×_; proj₁; proj₂; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩) 3 | 4 | open import Types 5 | open import Variables 6 | open import PreCastStructureWithPrecision 7 | open import CastStructure 8 | 9 | import ParamCastCalculus 10 | import ParamCastAux 11 | import ParamCCPrecision 12 | 13 | 14 | module CastStructureWithPrecision where 15 | 16 | import ParamCastReduction 17 | 18 | record CastStructWithPrecision : Set₁ where 19 | field 20 | pcsp : PreCastStructWithPrecision 21 | open PreCastStructWithPrecision pcsp public 22 | open ParamCastCalculus Cast Inert 23 | open ParamCastAux precast 24 | open ParamCCPrecision pcsp 25 | field 26 | applyCast : ∀{Γ A B} → (M : Γ ⊢ A) → Value M → (c : Cast (A ⇒ B)) 27 | → ∀ {a : Active c} → Γ ⊢ B 28 | 29 | cs : CastStruct 30 | cs = record { precast = precast; applyCast = applyCast } 31 | 32 | open ParamCastReduction cs 33 | field 34 | {- This field is for gradual guarantees. 35 | Because the implementation of `applyCast` is unique to each cast representation, 36 | we need to prove this lemma for each specific representation as well. -} 37 | applyCast-catchup : ∀ {Γ Γ′ A A′ B} {V : Γ ⊢ A} {V′ : Γ′ ⊢ A′} {c : Cast (A ⇒ B)} 38 | → (a : Active c) 39 | → (vV : Value V) → Value V′ 40 | → A ⊑ A′ → B ⊑ A′ 41 | → Γ , Γ′ ⊢ V ⊑ᶜ V′ 42 | ----------------------------------------------------------------------- 43 | → ∃[ W ] ((Value W) × (applyCast V vV c {a} —↠ W) × (Γ , Γ′ ⊢ W ⊑ᶜ V′)) 44 | 45 | sim-cast : ∀ {A A′ B B′} {V : ∅ ⊢ A} {V′ : ∅ ⊢ A′} {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 46 | → Value V → (v′ : Value V′) 47 | → (a′ : Active c′) 48 | → A ⊑ A′ → B ⊑ B′ 49 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 50 | ------------------------------------------------------------ 51 | → ∃[ N ] ((V ⟨ c ⟩ —↠ N) × (∅ , ∅ ⊢ N ⊑ᶜ applyCast V′ v′ c′ {a′})) 52 | sim-wrap : ∀ {A A′ B B′} {V : ∅ ⊢ A} {V′ : ∅ ⊢ A′} {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 53 | → Value V → (v′ : Value V′) 54 | → (i′ : Inert c′) 55 | → A ⊑ A′ → B ⊑ B′ 56 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 57 | ----------------------------------------------------- 58 | → ∃[ N ] ((V ⟨ c ⟩ —↠ N) × (∅ , ∅ ⊢ N ⊑ᶜ V′ ⟪ i′ ⟫)) 59 | castr-cast : ∀ {A A′ B′} {V : ∅ ⊢ A} {V′ : ∅ ⊢ A′} {c′ : Cast (A′ ⇒ B′)} 60 | → Value V → (v′ : Value V′) 61 | → (a′ : Active c′) 62 | → A ⊑ A′ → A ⊑ B′ 63 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 64 | ------------------------------------------------------------ 65 | → ∅ , ∅ ⊢ V ⊑ᶜ applyCast V′ v′ c′ {a′} 66 | castr-wrap : ∀ {A A′ B′} {V : ∅ ⊢ A} {V′ : ∅ ⊢ A′} {c′ : Cast (A′ ⇒ B′)} 67 | → Value V → (v′ : Value V′) 68 | → (i′ : Inert c′) 69 | → A ⊑ A′ → A ⊑ B′ 70 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 71 | ----------------------------------------------------- 72 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ ⟪ i′ ⟫ 73 | -------------------------------------------------------------------------------- /CastStructureWithPrecisionABT.agda: -------------------------------------------------------------------------------- 1 | open import Data.List hiding ([_]) 2 | open import Data.Product using (_×_; ∃; ∃-syntax) 3 | 4 | open import Types 5 | open import PreCastStructure 6 | open import CastStructureABT 7 | import ParamCastCalculusABT 8 | import ParamCastAuxABT 9 | import ParamCCPrecisionABT 10 | import ParamCastReductionABT 11 | 12 | 13 | module CastStructureWithPrecisionABT where 14 | 15 | record CastStructWithPrecision : Set₁ where 16 | field 17 | precast : PreCastStruct 18 | open PreCastStruct precast public 19 | open ParamCastCalculusABT precast 20 | open ParamCastAuxABT precast 21 | open ParamCCPrecisionABT precast 22 | field 23 | applyCast : ∀ {Γ A B} → (V : Term) → Γ ⊢ V ⦂ A → Value V → (c : Cast (A ⇒ B)) 24 | → {a : Active c} → Term 25 | 26 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 27 | → (⊢V : Γ ⊢ V ⦂ A) 28 | → (v : Value V) → (a : Active c) 29 | -------------------------------- 30 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 31 | 32 | 33 | cs : CastStruct 34 | cs = record { precast = precast ; applyCast = applyCast ; applyCast-wt = applyCast-wt } 35 | 36 | open ParamCastReductionABT cs 37 | field 38 | {- For gradual guarantee. 39 | Because the implementation of `applyCast` is unique to each cast representation, 40 | we need to prove this lemma for each specific representation too. -} 41 | applyCast-catchup : ∀ {A A′ B} {V V′} {c : Cast (A ⇒ B)} 42 | → (a : Active c) 43 | → (⊢V : [] ⊢ V ⦂ A) → [] ⊢ V′ ⦂ A′ 44 | → (v : Value V) → Value V′ 45 | → A ⊑ A′ → B ⊑ A′ 46 | → [] , [] ⊢ V ⊑ V′ 47 | ----------------------------------------------------------------- 48 | → ∃[ W ] Value W × (applyCast V ⊢V v c {a} —↠ W) × [] , [] ⊢ W ⊑ V′ 49 | 50 | sim-cast : ∀ {A A′ B B′} {V V′} {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 51 | → (a′ : Active c′) 52 | → [] ⊢ V ⦂ A → (⊢V′ : [] ⊢ V′ ⦂ A′) 53 | → Value V → (v′ : Value V′) 54 | → A ⊑ A′ → B ⊑ B′ 55 | → [] , [] ⊢ V ⊑ V′ 56 | ------------------------------------------------------------ 57 | → ∃[ N ] (V ⟨ c ⟩ —↠ N) × [] , [] ⊢ N ⊑ applyCast V′ ⊢V′ v′ c′ {a′} 58 | 59 | cast-castr : ∀ {A A′ B′} {V V′} {c′ : Cast (A′ ⇒ B′)} 60 | → (a′ : Active c′) 61 | → [] ⊢ V ⦂ A → (⊢V′ : [] ⊢ V′ ⦂ A′) 62 | → Value V → (v′ : Value V′) 63 | → A ⊑ A′ → A ⊑ B′ 64 | → [] , [] ⊢ V ⊑ V′ 65 | -------------------------------------- 66 | → [] , [] ⊢ V ⊑ applyCast V′ ⊢V′ v′ c′ {a′} 67 | -------------------------------------------------------------------------------- /CoercionsS.lagda: -------------------------------------------------------------------------------- 1 | Phil's revision of Jeremy's work on System S. 2 | 3 | (Original is EfficientGroundCoercions.agda) 4 | 5 | This module formalizes the λS calculus (Siek, Thiemann, Wadler 2015) 6 | and proves type safety via progress and preservation. The calculus 7 | uses Henglein's coercions to represent casts, and acheive space 8 | efficiency. 9 | 10 | This module is relatively small because it reuses the definitions 11 | and proofs from the Efficient Parameterized Cast Calculus. This 12 | module just has to provide the appropriate parameters, the most 13 | important of which is the compose function, written ⨟. 14 | 15 | ## Imports 16 | 17 | \begin{code} 18 | module CoercionsS where 19 | 20 | open import Data.Nat 21 | open import Relation.Binary.PropositionalEquality 22 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 23 | \end{code} 24 | 25 | ## Types 26 | 27 | \begin{code} 28 | infix 7 _⇒_ 29 | infix 6 `_ 30 | infix 5 _⨟_ 31 | 32 | 33 | data Type : Set where 34 | ★ : Type 35 | ι : Type 36 | _⇒_ : Type → Type → Type 37 | 38 | data Ground : Type → Set where 39 | G-Base : Ground ι 40 | G-Fun : Ground (★ ⇒ ★) 41 | 42 | data Base : Type → Set where 43 | B-Base : Base ι 44 | 45 | \end{code} 46 | 47 | ## Labels 48 | 49 | \begin{code} 50 | data Label : Set where 51 | pos : ℕ → Label 52 | neg : ℕ → Label 53 | 54 | flip : Label → Label 55 | flip (pos ℓ) = (neg ℓ) 56 | flip (neg ℓ) = (pos ℓ) 57 | \end{code} 58 | 59 | ## Syntax of casts 60 | 61 | The mutually recursive data types sCast, iCast, and gCast define a 62 | normal form for coercions, following the grammar in Figure 5 of Siek, 63 | Thiemann, and Wadler (2015). Each cast is indexed by a pair of source 64 | and target types, called SrcTrg. 65 | 66 | \begin{code} 67 | infix 6 _——→_ 68 | 69 | data SrcTrg : Set where 70 | _——→_ : Type → Type → SrcTrg 71 | 72 | data sCast : SrcTrg → Set 73 | data iCast : SrcTrg → Set 74 | data gCast : SrcTrg → Set 75 | 76 | data sCast where 77 | 78 | id★ : 79 | -------------- 80 | sCast (★ ——→ ★) 81 | 82 | _??_⨟_ : ∀{B} 83 | → (G : Type) 84 | → Label 85 | → iCast (G ——→ B) 86 | → {_ : Ground G} 87 | -------------- 88 | → sCast (★ ——→ B) 89 | 90 | `_ : ∀{A B} 91 | → iCast (A ——→ B) 92 | --------------- 93 | → sCast (A ——→ B) 94 | 95 | data iCast where 96 | 97 | _⨟_!! : ∀{A} 98 | → (G : Type) 99 | → gCast (A ——→ G) 100 | → {_ : Ground G} 101 | --------------- 102 | → iCast (A ——→ ★) 103 | 104 | `_ : ∀{A B} 105 | → gCast (A ——→ B) 106 | --------------- 107 | → iCast (A ——→ B) 108 | 109 | ⊥_⟨_⟩_ : 110 | (G : Type) 111 | → (H : Type) 112 | → Label 113 | → {_ : Ground G} 114 | → {_ : Ground H} 115 | --------------- 116 | → iCast (G ——→ H) 117 | 118 | data gCast where 119 | 120 | idι : ∀ {ι : Type} 121 | → {_ : Base ι} 122 | --------------- 123 | → gCast (ι ——→ ι) 124 | 125 | _⇒_ : ∀ {A B A′ B′} 126 | → sCast (A′ ——→ A) 127 | → sCast (B ——→ B′) 128 | ------------------------- 129 | → gCast (A ⇒ B ——→ A′ ⇒ B′) 130 | 131 | \end{code} 132 | 133 | ## Composition 134 | 135 | \begin{code} 136 | _⨟_ : ∀ {A B C} 137 | → sCast (A ——→ B) 138 | → sCast (B ——→ C) 139 | --------------- 140 | → sCast (A ——→ C) 141 | ` ` idι ⨟ ` ` idι = ` ` idι 142 | _ = {!!} 143 | \end{code} 144 | -------------------------------------------------------------------------------- /CompilePresPrec.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat using (ℕ; zero; suc) 2 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; cong) 3 | open import Data.Product using (_×_; proj₁; proj₂; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩) 4 | 5 | open import Types 6 | open import Variables 7 | open import Labels 8 | open import GTLC 9 | 10 | open import PreCastStructureWithPrecision 11 | 12 | 13 | module CompilePresPrec 14 | (pcsp : PreCastStructWithPrecision) 15 | where 16 | 17 | open PreCastStructWithPrecision pcsp 18 | open import ParamCastCalculus Cast Inert 19 | 20 | open import GTLCPrecision 21 | open import ParamCCPrecision pcsp 22 | 23 | module CompilePresPrecProof 24 | (cast : (A : Type) → (B : Type) → Label → {c : A ~ B } → Cast (A ⇒ B)) 25 | where 26 | 27 | 28 | open import GTLC2CC Cast Inert cast 29 | 30 | {- 31 | Compilation from GTLC to CC preserves precision. 32 | - We assume Γ ⊢ M ↝ f ⦂ A and Γ′ ⊢ M′ ↝ f′ ⦂ A′ . 33 | -} 34 | compile-pres-prec : ∀ {Γ Γ′ A A′} {M M′} 35 | → (⊢M : Γ ⊢G M ⦂ A) → (⊢M′ : Γ′ ⊢G M′ ⦂ A′) 36 | → Γ ⊑* Γ′ 37 | → M ⊑ᴳ M′ 38 | ------------------------------- 39 | → (A ⊑ A′) × (Γ , Γ′ ⊢ compile {Γ} {A} M ⊢M ⊑ᶜ compile {Γ′} {A′} M′ ⊢M′) 40 | compile-pres-prec ⊢lit ⊢lit lpc ⊑ᴳ-prim = ⟨ Refl⊑ , ⊑ᶜ-prim ⟩ 41 | compile-pres-prec (⊢var {x = 0} Z) (⊢var Z) (⊑*-, lp _) (⊑ᴳ-var {.0}) = ⟨ lp , ⊑ᶜ-var refl ⟩ 42 | compile-pres-prec (⊢var {x = suc x} (S ∋x)) (⊢var (S ∋x′)) (⊑*-, lp lpc) (⊑ᴳ-var {.(suc x)}) 43 | with compile-pres-prec (⊢var ∋x) (⊢var ∋x′) lpc ⊑ᴳ-var 44 | ... | ⟨ IH₁ , ⊑ᶜ-var IH₂ ⟩ = ⟨ IH₁ , (⊑ᶜ-var (cong suc IH₂)) ⟩ 45 | compile-pres-prec (⊢lam ⊢M) (⊢lam ⊢M′) lpc (⊑ᴳ-ƛ lpA lpM) = 46 | let ⟨ lpB , lpN ⟩ = compile-pres-prec ⊢M ⊢M′ (⊑*-, lpA lpc) lpM in 47 | ⟨ fun⊑ lpA lpB , ⊑ᶜ-ƛ lpA lpN ⟩ 48 | compile-pres-prec (⊢app ⊢L ⊢M m _) (⊢app ⊢L′ ⊢M′ m′ _) lpc (⊑ᴳ-· lpL lpM) = 49 | let ⟨ lpA , lpL′ ⟩ = compile-pres-prec ⊢L ⊢L′ lpc lpL in 50 | let ⟨ lpB , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 51 | let ⟨ lpA₁ , lpA₂ ⟩ = ▹⇒-pres-prec m m′ lpA in 52 | ⟨ lpA₂ , ⊑ᶜ-· (⊑ᶜ-cast lpA (fun⊑ lpA₁ lpA₂) lpL′) (⊑ᶜ-cast lpB lpA₁ lpM′) ⟩ 53 | compile-pres-prec (⊢if ⊢L ⊢M ⊢N _ aa) (⊢if ⊢L′ ⊢M′ ⊢N′ _ aa′) lpc (⊑ᴳ-if lpL lpM lpN) = 54 | let ⟨ lpB , lpL′ ⟩ = compile-pres-prec ⊢L ⊢L′ lpc lpL in 55 | let ⟨ lpA₁ , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 56 | let ⟨ lpA₂ , lpN′ ⟩ = compile-pres-prec ⊢N ⊢N′ lpc lpN in 57 | let lp⨆aa = ⨆-pres-prec aa aa′ lpA₁ lpA₂ in 58 | ⟨ lp⨆aa , ⊑ᶜ-if (⊑ᶜ-cast lpB base⊑ lpL′) (⊑ᶜ-cast lpA₁ lp⨆aa lpM′) (⊑ᶜ-cast lpA₂ lp⨆aa lpN′) ⟩ 59 | compile-pres-prec (⊢cons ⊢M ⊢N) (⊢cons ⊢M′ ⊢N′) lpc (⊑ᴳ-cons lpM lpN) = 60 | let ⟨ lpA , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 61 | let ⟨ lpB , lpN′ ⟩ = compile-pres-prec ⊢N ⊢N′ lpc lpN in 62 | ⟨ pair⊑ lpA lpB , ⊑ᶜ-cons lpM′ lpN′ ⟩ 63 | compile-pres-prec (⊢fst ⊢M m) (⊢fst ⊢M′ m′) lpc (⊑ᴳ-fst lpM) = 64 | let ⟨ lp , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 65 | let ⟨ lp₁ , lp₂ ⟩ = ▹×-pres-prec m m′ lp in 66 | ⟨ lp₁ , ⊑ᶜ-fst (⊑ᶜ-cast lp (pair⊑ lp₁ lp₂) lpM′) ⟩ 67 | compile-pres-prec (⊢snd ⊢M m) (⊢snd ⊢M′ m′) lpc (⊑ᴳ-snd lpM) = 68 | let ⟨ lp , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 69 | let ⟨ lp₁ , lp₂ ⟩ = ▹×-pres-prec m m′ lp in 70 | ⟨ lp₂ , ⊑ᶜ-snd (⊑ᶜ-cast lp (pair⊑ lp₁ lp₂) lpM′) ⟩ 71 | compile-pres-prec (⊢inl ⊢M) (⊢inl ⊢M′) lpc (⊑ᴳ-inl lpB lpM) = 72 | let ⟨ lpA , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 73 | ⟨ sum⊑ lpA lpB , ⊑ᶜ-inl lpB lpM′ ⟩ 74 | compile-pres-prec (⊢inr ⊢M) (⊢inr ⊢M′) lpc (⊑ᴳ-inr lpA lpM) = 75 | let ⟨ lpB , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ lpc lpM in 76 | ⟨ sum⊑ lpA lpB , ⊑ᶜ-inr lpA lpM′ ⟩ 77 | compile-pres-prec (⊢case ⊢L ⊢M ⊢N abc bc) (⊢case ⊢L′ ⊢M′ ⊢N′ abc′ bc′) lpc (⊑ᴳ-case lpL lp1 lp2 lpM lpN) = 78 | let ⟨ lpA , lpL′ ⟩ = compile-pres-prec ⊢L ⊢L′ lpc lpL in 79 | let ⟨ lpB , lpM′ ⟩ = compile-pres-prec ⊢M ⊢M′ (⊑*-, lp1 lpc) lpM in 80 | let ⟨ lpC , lpN′ ⟩ = compile-pres-prec ⊢N ⊢N′ (⊑*-, lp2 lpc) lpN in 81 | let lp⨆bc = ⨆-pres-prec bc bc′ lpB lpC in 82 | ⟨ lp⨆bc , ⊑ᶜ-case (⊑ᶜ-cast lpA (sum⊑ lp1 lp2) lpL′) lp1 lp2 83 | (⊑ᶜ-cast lpB lp⨆bc lpM′) (⊑ᶜ-cast lpC lp⨆bc lpN′) ⟩ 84 | -------------------------------------------------------------------------------- /Denot/CastStructureOmni.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | open import Data.Bool using (Bool; true; false) 4 | open import Data.Nat using (ℕ; zero; _≤_; _⊔_; _+_; _*_) 5 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 6 | renaming (_,_ to ⟨_,_⟩) 7 | open import Data.Sum using (_⊎_; inj₁; inj₂) 8 | open import Data.Maybe using (Maybe; just; nothing) 9 | open import Data.Unit.Polymorphic renaming (⊤ to p⊤; tt to ptt) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Relation.Nullary using (¬_) 13 | 14 | open import Types 15 | open import Labels 16 | open import PreCastStructure 17 | open import CastStructureABT 18 | open import Pow2 19 | open import Denot.Value 20 | open import Denot.OpOmni 21 | open import Primitives hiding (_⇒_) 22 | open import ScopedTuple hiding (𝒫) 23 | open import NewSigUtil 24 | open import NewDOpSig 25 | open import SetsAsPredicates 26 | open import NewDenotProperties 27 | 28 | 29 | module Denot.CastStructureOmni where 30 | 31 | import ParamCastCalculusABT 32 | import ParamCastAuxABT 33 | -- import EfficientParamCastAux 34 | 35 | 36 | record DenotCastStruct : Set₁ where 37 | field 38 | cast : CastStruct 39 | open CastStruct cast 40 | open ParamCastCalculusABT precast 41 | open ParamCastAuxABT precast 42 | field 43 | 𝒞 : ∀ {A B : Type} → Cast (A ⇒ B) → 𝒫 Val → 𝒫 Val 44 | {- add monotone field for 𝒞 -} 45 | 𝕆 : DOpSig (𝒫 Val) sig 46 | 𝕆 (op-lam A) ⟨ F , ptt ⟩ = Λ A F 47 | 𝕆 op-app ⟨ D , ⟨ E , ptt ⟩ ⟩ = D ∗ E 48 | 𝕆 (op-lit f P) ptt = ℘ P f 49 | 𝕆 op-if ⟨ D , ⟨ E₁ , ⟨ E₂ , ptt ⟩ ⟩ ⟩ = If D E₁ E₂ 50 | 𝕆 op-cons ⟨ D , ⟨ E , ptt ⟩ ⟩ = pair D E 51 | 𝕆 op-fst ⟨ D , ptt ⟩ = car D 52 | 𝕆 op-snd ⟨ D , ptt ⟩ = cdr D 53 | 𝕆 (op-inl x) ⟨ D , ptt ⟩ = inleft D 54 | 𝕆 (op-inr x) ⟨ D , ptt ⟩ = inright D 55 | 𝕆 (op-case x₁ x₂) ⟨ D , ⟨ F₁ , ⟨ F₂ , ptt ⟩ ⟩ ⟩ = cond D F₁ F₂ 56 | 𝕆 (op-cast c) ⟨ D , ptt ⟩ = 𝒞 c D 57 | 𝕆 (op-wrap c x) ⟨ D , ptt ⟩ = 𝒞 c D 58 | 𝕆 (op-blame x ℓ) Ds = ℬ ℓ 59 | {- add proof of monotonicity -} 60 | 𝕆-mono : 𝕆-monotone sig 𝕆 61 | 𝕆-mono = {! !} 62 | open import Fold2 Op sig 63 | open import NewSemantics Op sig public 64 | instance 65 | semantics : Semantics 66 | semantics = record { interp-op = 𝕆 ; 67 | mono-op = 𝕆-mono ; 68 | error = Val.blame (neg zero) } 69 | open Semantics semantics public 70 | 71 | {- possible other fields include: 72 | + denotApplyCast-wt 73 | + sound w.r.t. applyCast 74 | + adequate w.r.t. applyCast 75 | -} 76 | 77 | 78 | 79 | {- 80 | -- cast application is well-typed 81 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 82 | → (⊢V : Γ ⊢ V ⦂ A) 83 | → (v : Value V) → (a : Active c) 84 | -------------------------------- 85 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 86 | -} 87 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /Denot/CastStructureRegular.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | open import Data.Bool using (Bool; true; false) 4 | open import Data.Nat using (ℕ; zero; _≤_; _⊔_; _+_; _*_) 5 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 6 | renaming (_,_ to ⟨_,_⟩) 7 | open import Data.Sum using (_⊎_; inj₁; inj₂) 8 | open import Data.Maybe using (Maybe; just; nothing) 9 | open import Data.Unit.Polymorphic renaming (⊤ to p⊤; tt to ptt) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Relation.Nullary using (¬_) 13 | 14 | open import Types 15 | open import Labels 16 | open import PreCastStructure 17 | open import CastStructureABT 18 | open import Pow2 19 | open import Denot.Value 20 | open import Denot.OpRegular 21 | open import Primitives hiding (_⇒_) 22 | open import ScopedTuple hiding (𝒫) 23 | open import NewSigUtil 24 | open import NewDOpSig 25 | open import SetsAsPredicates 26 | open import NewDenotProperties 27 | 28 | 29 | module Denot.CastStructureRegular where 30 | 31 | import ParamCastCalculusABT 32 | import ParamCastAuxABT 33 | -- import EfficientParamCastAux 34 | 35 | 36 | record DenotCastStruct : Set₁ where 37 | field 38 | cast : CastStruct 39 | open CastStruct cast 40 | open ParamCastCalculusABT precast 41 | open ParamCastAuxABT precast 42 | field 43 | _↝⟨_∶_⟩↝_ : ∀ {A B : Type} → (v : Val) → (c : Cast (A ⇒ B)) → ⟦ v ∶ A ⟧ → (v' : Val) → Set 44 | 𝒞 : ∀ {A B : Type} → Cast (A ⇒ B) → 𝒫 Val → 𝒫 Val 45 | 𝒞 {A} c D v = Σ[ u ∈ Val ] D u × Σ[ u∶A ∈ ⟦ u ∶ A ⟧ ] u ↝⟨ c ∶ u∶A ⟩↝ v 46 | {- add monotone field for ↝⟨_∶_⟩↝ -} 47 | 𝕆 : DOpSig (𝒫 Val) sig 48 | 𝕆 (op-lam A) ⟨ F , ptt ⟩ = Λ A F 49 | 𝕆 op-app ⟨ D , ⟨ E , ptt ⟩ ⟩ = D ∗ E 50 | 𝕆 (op-lit f P) ptt = ℘ P f 51 | 𝕆 op-if ⟨ D , ⟨ E₁ , ⟨ E₂ , ptt ⟩ ⟩ ⟩ = If D E₁ E₂ 52 | 𝕆 op-cons ⟨ D , ⟨ E , ptt ⟩ ⟩ = pair D E 53 | 𝕆 op-fst ⟨ D , ptt ⟩ = car D 54 | 𝕆 op-snd ⟨ D , ptt ⟩ = cdr D 55 | 𝕆 (op-inl x) ⟨ D , ptt ⟩ = inleft D 56 | 𝕆 (op-inr x) ⟨ D , ptt ⟩ = inright D 57 | 𝕆 (op-case x₁ x₂) ⟨ D , ⟨ F₁ , ⟨ F₂ , ptt ⟩ ⟩ ⟩ = cond D F₁ F₂ 58 | 𝕆 (op-cast c) ⟨ D , ptt ⟩ = 𝒞 c D 59 | 𝕆 (op-wrap c x) ⟨ D , ptt ⟩ = 𝒞 c D 60 | 𝕆 (op-blame x ℓ) Ds = ℬ ℓ 61 | {- add proof of monotonicity -} 62 | 𝕆-mono : 𝕆-monotone sig 𝕆 63 | 𝕆-mono = {! !} 64 | open import Fold2 Op sig 65 | open import NewSemantics Op sig public 66 | instance 67 | semantics : Semantics 68 | semantics = record { interp-op = 𝕆 ; 69 | mono-op = 𝕆-mono ; 70 | error = Val.blame (neg zero) } 71 | open Semantics semantics public 72 | 73 | {- possible other fields include: 74 | + denotApplyCast-wt 75 | + sound w.r.t. applyCast 76 | + adequate w.r.t. applyCast 77 | -} 78 | 79 | 80 | 81 | {- 82 | -- cast application is well-typed 83 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 84 | → (⊢V : Γ ⊢ V ⦂ A) 85 | → (v : Value V) → (a : Active c) 86 | -------------------------------- 87 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 88 | -} 89 | 90 | 91 | 92 | -------------------------------------------------------------------------------- /Denot/CastStructureRegularInj.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | open import Data.Bool using (Bool; true; false) 4 | open import Data.Nat using (ℕ; zero; _≤_; _⊔_; _+_; _*_) 5 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 6 | renaming (_,_ to ⟨_,_⟩) 7 | open import Data.Sum using (_⊎_; inj₁; inj₂) 8 | open import Data.Maybe using (Maybe; just; nothing) 9 | open import Data.Unit.Polymorphic renaming (⊤ to p⊤; tt to ptt) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Relation.Nullary using (¬_) 13 | 14 | open import Types 15 | open import Labels 16 | open import PreCastStructure 17 | open import CastStructureABT 18 | open import Pow2 19 | open import Denot.ValueInj 20 | open import Denot.OpRegularInj 21 | open import Primitives hiding (_⇒_) 22 | open import ScopedTuple hiding (𝒫) 23 | open import NewSigUtil 24 | open import NewDOpSig 25 | open import SetsAsPredicates 26 | open import NewDenotProperties 27 | 28 | 29 | module Denot.CastStructureRegularInj where 30 | 31 | import ParamCastCalculusABT 32 | import ParamCastAuxABT 33 | -- import EfficientParamCastAux 34 | 35 | 36 | record DenotCastStruct : Set₁ where 37 | field 38 | cast : CastStruct 39 | open CastStruct cast 40 | open ParamCastCalculusABT precast 41 | open ParamCastAuxABT precast 42 | field 43 | 𝒞 : ∀ {A B : Type} → Cast (A ⇒ B) → 𝒫 Val → 𝒫 Val 44 | {- add monotone field for 𝒞 -} 45 | 𝕆 : DOpSig (𝒫 Val) sig 46 | 𝕆 (op-lam A) ⟨ F , ptt ⟩ = Λ A F 47 | 𝕆 op-app ⟨ D , ⟨ E , ptt ⟩ ⟩ = D ∗ E 48 | 𝕆 (op-lit f P) ptt = ℘ P f 49 | 𝕆 op-if ⟨ D , ⟨ E₁ , ⟨ E₂ , ptt ⟩ ⟩ ⟩ = If D E₁ E₂ 50 | 𝕆 op-cons ⟨ D , ⟨ E , ptt ⟩ ⟩ = pair D E 51 | 𝕆 op-fst ⟨ D , ptt ⟩ = car D 52 | 𝕆 op-snd ⟨ D , ptt ⟩ = cdr D 53 | 𝕆 (op-inl x) ⟨ D , ptt ⟩ = inleft D 54 | 𝕆 (op-inr x) ⟨ D , ptt ⟩ = inright D 55 | 𝕆 (op-case x₁ x₂) ⟨ D , ⟨ F₁ , ⟨ F₂ , ptt ⟩ ⟩ ⟩ = cond D F₁ F₂ 56 | 𝕆 (op-cast c) ⟨ D , ptt ⟩ = 𝒞 c D 57 | 𝕆 (op-wrap c x) ⟨ D , ptt ⟩ = 𝒞 c D 58 | 𝕆 (op-blame x ℓ) Ds = ℬ ℓ 59 | {- add proof of monotonicity -} 60 | 𝕆-mono : 𝕆-monotone sig 𝕆 61 | 𝕆-mono = {! !} 62 | open import Fold2 Op sig 63 | open import NewSemantics Op sig public 64 | instance 65 | semantics : Semantics 66 | semantics = record { interp-op = 𝕆 ; 67 | mono-op = 𝕆-mono ; 68 | error = Val.blame (neg zero) } 69 | open Semantics semantics public 70 | 71 | {- possible other fields include: 72 | + denotApplyCast-wt 73 | + sound w.r.t. applyCast 74 | + adequate w.r.t. applyCast 75 | -} 76 | 77 | 78 | 79 | {- 80 | -- cast application is well-typed 81 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 82 | → (⊢V : Γ ⊢ V ⦂ A) 83 | → (v : Value V) → (a : Active c) 84 | -------------------------------- 85 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 86 | -} 87 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /Denot/ConsisOmni.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | module Denot.ConsisOmni where 4 | 5 | open import Data.Empty using (⊥-elim; ⊥) 6 | open import Data.List using (List ; _∷_ ; []; _++_; length) 7 | open import Data.List.Membership.Propositional renaming (_∈_ to _⋵_) 8 | open import Data.List.Relation.Unary.Any using (Any; here; there; any?) 9 | open import Data.List.Relation.Unary.All using (All; []; _∷_; lookup) 10 | open import Data.Product using (_×_; _,_; Σ; Σ-syntax; proj₁; proj₂) 11 | open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_]) 12 | open import Data.Unit using (⊤; tt) 13 | open import Data.Bool using (Bool; true; false) 14 | open import Labels 15 | open import PrimitiveTypes using (Base) 16 | open import Relation.Binary.PropositionalEquality 17 | using (_≡_; _≢_; refl; sym; trans; subst) 18 | open import Relation.Nullary using (¬_; Dec; yes; no) 19 | open import Relation.Nullary.Product using (_×-dec_) 20 | open import Relation.Nullary.Implication using (_→-dec_) 21 | open import SetsAsPredicates 22 | open import Types 23 | open import Denot.Value 24 | 25 | infix 5 _∼_ 26 | infix 5 _∼₊_ 27 | 28 | _∼_ : (u : Val) → (v : Val) → Set 29 | _∼₊_ : (u : Val) → (V : List Val) → Set 30 | _≈₊_ : (U : List Val) → (V : List Val) → Set 31 | const {ι} k ∼ const {ι'} k' = Σ[ ι≡ ∈ ι ≡ ι' ] subst base-rep ι≡ k ≡ k' 32 | const k ∼ blame ℓ = ⊤ 33 | const k ∼ v = ⊥ 34 | (V ↦ w) ∼ ν = ⊤ 35 | (V ↦ w) ∼ blame ℓ = ⊤ 36 | (V ↦ w) ∼ V' ↦ w' = V ≈₊ V' × w ∼ w' ⊎ ¬ (V ≈₊ V') 37 | (V ↦ w) ∼ v = ⊥ 38 | ν ∼ ν = ⊤ 39 | ν ∼ blame ℓ = ⊤ 40 | ν ∼ (V' ↦ w') = ⊤ 41 | ν ∼ v = ⊥ 42 | fst u ∼ fst v = u ∼ v 43 | fst u ∼ snd v = ⊤ 44 | fst u ∼ blame ℓ = ⊤ 45 | fst u ∼ v = ⊥ 46 | snd u ∼ snd v = u ∼ v 47 | snd u ∼ fst v = ⊤ 48 | snd u ∼ blame ℓ = ⊤ 49 | snd u ∼ v = ⊥ 50 | inl U ∼ inl V = U ≈₊ V 51 | inl U ∼ (blame ℓ) = ⊤ 52 | inl U ∼ v = ⊥ 53 | inr U ∼ inr V = U ≈₊ V 54 | inr U ∼ blame ℓ = ⊤ 55 | inr U ∼ v = ⊥ 56 | blame ℓ ∼ v = ⊤ 57 | u ∼₊ [] = ⊤ 58 | u ∼₊ (v ∷ V) = u ∼ v × u ∼₊ V 59 | U ≈₊ V = All (_∼₊ V) U 60 | 61 | 62 | 63 | scD : 𝒫 Val → Set 64 | scD D = ∀ u v → u ∈ D → v ∈ D → u ∼ v 65 | 66 | scD-1 : (𝒫 Val → 𝒫 Val) → Set₁ 67 | scD-1 F = ∀ D → scD D → scD (F D) 68 | 69 | monoD-1 : (F F' : 𝒫 Val → 𝒫 Val) → Set₁ 70 | monoD-1 F F' = ∀ D D' → scD D' → D ⊆ D' → F D ⊆ F' D' 71 | 72 | ∼-Type : ∀ {u v A} → ⟦ u ∶ A ⟧ → u ∼ v → ⟦ v ∶ A ⟧ 73 | ∼-Type₊ : ∀ {U V A} → ⟦ U ∶ A ⟧₊ → U ≈₊ V → ⟦ V ∶ A ⟧₊ 74 | ∼-Type {const k} {v} {A} u∶A u∼v = {! !} 75 | ∼-Type {V ↦ u} {v} {A} u∶A u∼v = {! !} 76 | ∼-Type {ν} {v} {A} u∶A u∼v = {! !} 77 | ∼-Type {fst u} {v} {A} u∶A u∼v = {! !} 78 | ∼-Type {snd u} {v} {A} u∶A u∼v = {! !} 79 | ∼-Type {inl V} {v} {A} u∶A u∼v = {! !} 80 | ∼-Type {inr V} {v} {A} u∶A u∼v = {! !} 81 | ∼-Type {blame ℓ} {v} {A} u∶A u∼v = {! !} 82 | ∼-Type₊ {U}{V}{A} U∶A U∼V = {! !} 83 | 84 | data ∼-Class : Set where 85 | [bl_] : (ℓ : Label) → ∼-Class 86 | [const_] : ∀ {ι} (k : base-rep ι) → ∼-Class 87 | [_×_] : ([A] : ∼-Class) → ([B] : ∼-Class) → ∼-Class 88 | [_⊎_] : ([A] : ∼-Class) → ([B] : ∼-Class) → ∼-Class 89 | [_⇒_] : ([A] : ∼-Class) → ([B] : ∼-Class) → ∼-Class 90 | 91 | _[∼]_ : (u : Val) → ([v] : ∼-Class) → Set 92 | (blame ℓ) [∼] [bl ℓ' ] = ℓ ≡ ℓ' 93 | u [∼] [bl ℓ' ] = ⊥ 94 | u [∼] [const_] {ι'} k' = {! !} 95 | u [∼] [ [v] × [v]₁ ] = {! !} 96 | u [∼] [ [v] ⊎ [v]₁ ] = {! !} 97 | u [∼] [ [v] ⇒ [v]₁ ] = {! !} 98 | 99 | -------------------------------------------------------------------------------- /Denot/ConsisRegularInj.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | module Denot.ConsisRegularInj where 4 | 5 | open import Data.Empty using (⊥-elim; ⊥) 6 | open import Data.List using (List ; _∷_ ; []; _++_; length) 7 | open import Data.List.Membership.Propositional renaming (_∈_ to _⋵_) 8 | open import Data.List.Relation.Unary.Any using (Any; here; there; any?) 9 | open import Data.List.Relation.Unary.All using (All; []; _∷_; lookup) 10 | open import Data.Product using (_×_; _,_; Σ; Σ-syntax; proj₁; proj₂) 11 | open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_]) 12 | open import Data.Unit using (⊤; tt) 13 | open import Data.Bool using (Bool; true; false) 14 | open import Labels 15 | open import PrimitiveTypes using (Base) 16 | open import Relation.Binary.PropositionalEquality 17 | using (_≡_; _≢_; refl; sym; trans; subst) 18 | open import Relation.Nullary using (¬_; Dec; yes; no) 19 | open import Relation.Nullary.Product using (_×-dec_) 20 | open import Relation.Nullary.Implication using (_→-dec_) 21 | open import SetsAsPredicates 22 | open import Types 23 | open import Denot.ValueInj 24 | 25 | infix 5 _∼_ 26 | infix 5 _∼₊_ 27 | 28 | _∼_ : (u : Val) → (v : Val) → Set 29 | _∼₊_ : (u : Val) → (V : List Val) → Set 30 | _≈₊_ : (U : List Val) → (V : List Val) → Set 31 | inj A u ∼ inj A' v = A ≡ A' × u ∼ v 32 | inj A u ∼ v = ⊥ 33 | const {ι} k ∼ const {ι'} k' = Σ[ ι≡ ∈ ι ≡ ι' ] subst base-rep ι≡ k ≡ k' 34 | const k ∼ v = ⊥ 35 | (V ↦ w) ∼ ν = ⊤ 36 | (V ↦ w) ∼ V' ↦ w' = V ≈₊ V' × w ∼ w' ⊎ ¬ (V ≈₊ V') 37 | (V ↦ w) ∼ v = ⊥ 38 | ν ∼ ν = ⊤ 39 | ν ∼ (V' ↦ w') = ⊤ 40 | ν ∼ v = ⊥ 41 | fst u ∼ fst v = u ∼ v 42 | fst u ∼ snd v = ⊤ 43 | fst u ∼ v = ⊥ 44 | snd u ∼ snd v = u ∼ v 45 | snd u ∼ fst v = ⊤ 46 | snd u ∼ v = ⊥ 47 | inl U ∼ inl V = U ≈₊ V 48 | inl U ∼ v = ⊥ 49 | inr U ∼ inr V = U ≈₊ V 50 | inr U ∼ v = ⊥ 51 | blame ℓ ∼ blame ℓ' = ℓ ≡ ℓ' 52 | blame ℓ ∼ v = ⊥ 53 | u ∼₊ [] = ⊤ 54 | u ∼₊ (v ∷ V) = u ∼ v × u ∼₊ V 55 | U ≈₊ V = All (_∼₊ V) U 56 | 57 | 58 | 59 | scD : 𝒫 Val → Set 60 | scD D = ∀ u v → u ∈ D → v ∈ D → u ∼ v 61 | 62 | scD-1 : (𝒫 Val → 𝒫 Val) → Set₁ 63 | scD-1 F = ∀ D → scD D → scD (F D) 64 | 65 | monoD-1 : (F F' : 𝒫 Val → 𝒫 Val) → Set₁ 66 | monoD-1 F F' = ∀ D D' → scD D' → D ⊆ D' → F D ⊆ F' D' 67 | 68 | ∼-Type : ∀ {u v A} → ⟦ u ∶ A ⟧ → u ∼ v → ⟦ v ∶ A ⟧ 69 | ∼-Type₊ : ∀ {U V A} → ⟦ U ∶ A ⟧₊ → U ≈₊ V → ⟦ V ∶ A ⟧₊ 70 | ∼-Type {inj A u} {inj .A v} {⋆} u∶A (refl , u~v) = ∼-Type u∶A u~v 71 | ∼-Type {const {B} k} {const {B₁} k₁} {` x} u∶A (B≡ , k≡) with base-eq? x B₁ 72 | ... | yes refl = tt 73 | ... | no neq with base-eq? x B 74 | ... | yes refl = ⊥-elim (neq B≡) 75 | ... | no neq' = ⊥-elim u∶A 76 | ∼-Type {V ↦ u} {V₁ ↦ v} {A ⇒ A₁} u∶A (inj₁ (V~ , v~)) V₁∶A = ∼-Type (u∶A (∼-Type₊ V₁∶A {! V~ !})) v~ 77 | ∼-Type {V ↦ u} {V₁ ↦ v} {A ⇒ A₁} u∶A (inj₂ ¬V~) V₁∶A = {! !} 78 | ∼-Type {V ↦ u} {ν} {A ⇒ A₁} u∶A u~v = tt 79 | ∼-Type {ν} {v} {A} u∶A u~v = {! !} 80 | ∼-Type {fst u} {v} {A} u∶A u~v = {! !} 81 | ∼-Type {snd u} {v} {A} u∶A u~v = {! !} 82 | ∼-Type {inl V} {v} {A} u∶A u~v = {! !} 83 | ∼-Type {inr V} {v} {A} u∶A u~v = {! !} 84 | ∼-Type {blame ℓ} {v} {A} u∶A u~v = {! !} 85 | ∼-Type₊ {U}{V} U∶A U≈V = {! !} 86 | 87 | data ∼-Class : Set where 88 | [bl_] : (ℓ : Label) → ∼-Class 89 | [const_] : ∀ {ι} (k : base-rep ι) → ∼-Class 90 | [_×_] : ([A] : ∼-Class) → ([B] : ∼-Class) → ∼-Class 91 | [_⊎_] : ([A] : ∼-Class) → ([B] : ∼-Class) → ∼-Class 92 | [_⇒_] : ([A] : ∼-Class) → ([B] : ∼-Class) → ∼-Class 93 | 94 | _[∼]_ : (u : Val) → ([v] : ∼-Class) → Set 95 | (blame ℓ) [∼] [bl ℓ' ] = ℓ ≡ ℓ' 96 | u [∼] [bl ℓ' ] = ⊥ 97 | u [∼] [const_] {ι'} k' = {! !} 98 | u [∼] [ [v] × [v]₁ ] = {! !} 99 | u [∼] [ [v] ⊎ [v]₁ ] = {! !} 100 | u [∼] [ [v] ⇒ [v]₁ ] = {! !} 101 | 102 | -------------------------------------------------------------------------------- /Denot/GTLC.agda: -------------------------------------------------------------------------------- 1 | open import GTLC 2 | open import Denot.Value 3 | open import Primitives 4 | open import ScopedTuple hiding (𝒫) 5 | open import NewSigUtil 6 | open import NewDOpSig 7 | open import Utilities using (extensionality) 8 | open import SetsAsPredicates 9 | open import NewDenotProperties 10 | 11 | open import Data.Bool using (true; false) 12 | open import Data.Empty renaming (⊥ to False) 13 | open import Data.Nat using (ℕ) 14 | open import Data.Product using (_×_; Σ; Σ-syntax; ∃; ∃-syntax; proj₁; proj₂) 15 | renaming (_,_ to ⟨_,_⟩) 16 | open import Data.Sum using (_⊎_; inj₁; inj₂) 17 | open import Data.Unit using (⊤) 18 | open import Data.Unit.Polymorphic renaming (⊤ to p⊤; tt to ptt) 19 | open import Relation.Nullary using (¬_) 20 | 21 | 22 | module Denot.GTLC where 23 | 24 | 25 | 26 | {- 27 | sig : Op → List Sig 28 | sig (op-lam A) = (ν ■) ∷ [] 29 | sig (op-app ℓ) = ■ ∷ ■ ∷ [] 30 | sig (op-lit r p) = [] 31 | sig (op-if ℓ) = ■ ∷ ■ ∷ ■ ∷ [] 32 | sig op-cons = ■ ∷ ■ ∷ [] 33 | sig (op-fst ℓ) = ■ ∷ [] 34 | sig (op-snd ℓ) = ■ ∷ [] 35 | sig (op-inl B) = ■ ∷ [] 36 | sig (op-inr A) = ■ ∷ [] 37 | sig (op-case ℓ A B) = ■ ∷ (ν ■) ∷ (ν ■) ∷ [] 38 | -- mutable references not included 39 | -- op-ref (■ ∷ []) , (op-deref ℓ) (■ ∷ []) , (op-assign ℓ) (■ ∷ ■ ∷ []) 40 | -} 41 | 42 | open import Fold2 Op sig 43 | open import NewSemantics Op sig public 44 | 45 | 𝕆-GTLC : DOpSig (𝒫 Val) sig 46 | 𝕆-GTLC (op-lam x) ⟨ F , ptt ⟩ = Λ F 47 | 𝕆-GTLC (op-app x) ⟨ D , ⟨ E , ptt ⟩ ⟩ = D ∗ E 48 | 𝕆-GTLC (op-lit f P) ptt = ℘ P f 49 | 𝕆-GTLC (op-if x) ⟨ D , ⟨ E₁ , ⟨ E₂ , ptt ⟩ ⟩ ⟩ = If D E₁ E₂ 50 | 𝕆-GTLC op-cons ⟨ D , ⟨ E , ptt ⟩ ⟩ = pair D E 51 | 𝕆-GTLC (op-fst x) ⟨ D , ptt ⟩ = car D 52 | 𝕆-GTLC (op-snd x) ⟨ D , ptt ⟩ = cdr D 53 | 𝕆-GTLC (op-inl x) ⟨ D , ptt ⟩ = inleft D 54 | 𝕆-GTLC (op-inr x) ⟨ D , ptt ⟩ = inright D 55 | 𝕆-GTLC (op-case x x₁ x₂) ⟨ D , ⟨ F₁ , ⟨ F₂ , ptt ⟩ ⟩ ⟩ = cond D F₁ F₂ 56 | 57 | 𝕆-GTLC-mono : 𝕆-monotone sig 𝕆-GTLC 58 | 𝕆-GTLC-mono = {! !} 59 | 60 | instance 61 | GTLC-Semantics : Semantics 62 | GTLC-Semantics = record { interp-op = 𝕆-GTLC ; 63 | mono-op = 𝕆-GTLC-mono ; 64 | error = ERR } 65 | open Semantics {{...}} public 66 | 67 | 68 | -------------------------------------------------------------------------------- /Denot/LazyCoercions.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat 2 | open import Relation.Nullary using (¬_; Dec; yes; no) 3 | open import Relation.Nullary.Negation using (contradiction) 4 | open import Data.Sum using (_⊎_; inj₁; inj₂) 5 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 6 | renaming (_,_ to ⟨_,_⟩) 7 | open import Data.List using (List; []; _∷_) 8 | open import Relation.Binary.PropositionalEquality 9 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 10 | 11 | module Denot.LazyCoercions where 12 | 13 | open import Types 14 | open import Variables 15 | open import Labels 16 | open import CastStructureABT 17 | open import LazyCoercionsABT 18 | open import Denot.Value 19 | 20 | 21 | 22 | 23 | infix 4 _↝⟨_⟩↝_ 24 | infix 4 _↝⟨_⟩₊↝_ 25 | 26 | data _↝⟨_⟩↝_ : ∀ {A B} → (v : Val) → (c : Cast (A ⇒ B)) → (v' : Val) → Set 27 | data _↝⟨_⟩₊↝_ : ∀ {A B} → (V : List Val) → (c : Cast (A ⇒ B)) → (V' : List Val) → Set where 28 | [] : ∀ {A B}{c : Cast (A ⇒ B)} → [] ↝⟨ c ⟩₊↝ [] 29 | _∷_ : ∀ {A B}{c : Cast (A ⇒ B)}{v v' V V'} 30 | → v ↝⟨ c ⟩↝ v' → V ↝⟨ c ⟩₊↝ V' → (v ∷ V) ↝⟨ c ⟩₊↝ (v' ∷ V') 31 | data _↝⟨_⟩↝_ where 32 | ⟦id⟧ : ∀{v}{A}{a} → v ↝⟨ id {A}{a} ⟩↝ v 33 | ⟦inj⟧ : ∀{v}{A}{a} → v ↝⟨ (_!! A {a}) ⟩↝ v 34 | ⟦proj⟧-ok : ∀{v}{τ : Type}{ℓ}{a} 35 | → ⟦ v ∶ τ ⟧ → v ↝⟨ _??_ τ ℓ {a} ⟩↝ v 36 | ⟦proj⟧-fail : ∀{v}{τ : Type}{ℓ : Label}{a} 37 | → ¬ ⟦ v ∶ τ ⟧ 38 | → v ↝⟨ _??_ τ ℓ {a} ⟩↝ blame ℓ {- originally "blame! (cvt-label ℓ)", need to check -} 39 | ⟦cfun⟧ : ∀{V w V′ w′}{A B A′ B′}{c : Cast (B ⇒ A)}{d : Cast (A′ ⇒ B′)} 40 | → V′ ↝⟨ c ⟩₊↝ V → w ↝⟨ d ⟩↝ w′ 41 | → (V ↦ w) ↝⟨ c ↣ d ⟩↝ (V′ ↦ w′) 42 | ⟦cprod⟧-fst : ∀{u v}{A B A' B'}{c : Cast (A ⇒ B)}{d : Cast (A' ⇒ B')} 43 | → u ↝⟨ c ⟩↝ v 44 | → fst u ↝⟨ c `× d ⟩↝ fst v 45 | ⟦cprod⟧-snd : ∀{u v}{A B A' B'}{c : Cast (A ⇒ B)}{d : Cast (A' ⇒ B')} 46 | → u ↝⟨ d ⟩↝ v 47 | → snd u ↝⟨ c `× d ⟩↝ snd v 48 | ⟦csum⟧-inl : ∀{V V'}{A B A' B'}{c : Cast (A ⇒ B)}{d : Cast (A' ⇒ B')} 49 | → V ↝⟨ c ⟩₊↝ V' 50 | → inl V ↝⟨ c `+ d ⟩↝ inl V' 51 | ⟦csum⟧-inr : ∀{V V'}{A B A' B'}{c : Cast (A ⇒ B)}{d : Cast (A' ⇒ B')} 52 | → V ↝⟨ d ⟩₊↝ V' 53 | → inr V ↝⟨ c `+ d ⟩↝ inr V' 54 | ⟦cfail⟧ : ∀{v}{ℓ}{A}{B} 55 | → v ↝⟨ ⊥ A ⟨ ℓ ⟩ B ⟩↝ blame ℓ 56 | 57 | 58 | 59 | open import Denot.CastStructure 60 | 61 | -- This won't typecheck; LazyCoercions and GroundCoercions are written 62 | -- using CastStructureOrig instead of CasStructureABT 63 | instance 64 | dcs : DenotCastStruct 65 | dcs = record 66 | { cast = cs 67 | ; _↝⟨_⟩↝_ = _↝⟨_⟩↝_ } -------------------------------------------------------------------------------- /Denot/LazyCoercionsOmniscientOlder.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat 2 | open import Data.Empty using (⊥-elim) renaming (⊥ to False) 3 | open import Data.Unit using (tt) renaming (⊤ to True) 4 | open import Relation.Nullary using (¬_; Dec; yes; no) 5 | open import Relation.Nullary.Negation using (contradiction) 6 | open import Data.Sum using (_⊎_; inj₁; inj₂) 7 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 8 | renaming (_,_ to ⟨_,_⟩) 9 | open import Data.List using (List; []; _∷_; _++_) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | 13 | module Denot.LazyCoercionsOmniscient where 14 | 15 | open import Types 16 | open import Labels 17 | open import CastStructureABT 18 | open import LazyCoercionsABT 19 | open import Denot.Value 20 | open import SetsAsPredicates 21 | 22 | 23 | 24 | {- could add a lemma that the list of blame labels is always nonempty -} 25 | {- could also add a lemma that the list is complete... all possible blames are here. -} 26 | get-blame-label : ∀ {A B} (c : Cast (A ⇒ B)) (v : Val) 27 | → ⟦ v ∶ A ⟧ → ¬ ⟦ v ∶ B ⟧ → List Label 28 | get-blame-label₊ : ∀ {A B} (c : Cast (A ⇒ B)) (V : List Val) 29 | → ⟦ V ∶ A ⟧₊ → ¬ ⟦ V ∶ B ⟧₊ → List Label 30 | get-blame-label₊ c [] V∶A ¬V∶B = ⊥-elim (¬V∶B tt) 31 | get-blame-label₊ {A}{B} c (v ∷ V) ⟨ v∶A , V∶A ⟩ ¬V∶B with ⟦ v ∶ B ⟧? | ⟦ V ∶ B ⟧₊? 32 | ... | yes v∶B | yes V∶B = ⊥-elim (¬V∶B ⟨ v∶B , V∶B ⟩) 33 | ... | yes v∶B | no ¬V∶B = get-blame-label₊ c V V∶A ¬V∶B 34 | ... | no ¬v∶B | yes V∶B = get-blame-label c v v∶A ¬v∶B 35 | ... | no ¬v∶B | no ¬V∶B = get-blame-label c v v∶A ¬v∶B ++ get-blame-label₊ c V V∶A ¬V∶B 36 | get-blame-label {A} {.A} id v v∶A ¬v∶B = ⊥-elim (¬v∶B v∶A) 37 | get-blame-label {A} {.⋆} (.A !!) v v∶A ¬v∶B = ⊥-elim (¬v∶B tt) 38 | get-blame-label {.⋆} {B} (.B ?? ℓ) v v∶A ¬v∶B = ℓ ∷ [] 39 | get-blame-label {(A ⇒ B)} {(A' ⇒ B')} (c ↣ d) (V ↦ w) V∶A→w∶B ¬[V∶A'→w∶B'] 40 | with ⟦ V ∶ A' ⟧₊? 41 | ... | no ¬V∶A' = ⊥-elim (¬[V∶A'→w∶B'] (λ z → ⊥-elim (¬V∶A' z))) 42 | ... | yes V∶A' with ⟦ w ∶ B' ⟧? 43 | ... | yes w∶B' = ⊥-elim (¬[V∶A'→w∶B'] (λ _ → w∶B')) 44 | ... | no ¬w∶B' with ⟦ V ∶ A ⟧₊? 45 | ... | yes V∶A = get-blame-label d w (V∶A→w∶B V∶A) (λ z → ¬[V∶A'→w∶B'] (λ _ → z)) 46 | ... | no ¬V∶A = get-blame-label₊ c V V∶A' ¬V∶A 47 | get-blame-label {.(_ ⇒ _)} {.(_ ⇒ _)} (c ↣ d) ν v∶A ¬v∶B = ⊥-elim (¬v∶B tt) 48 | get-blame-label {.(_ ⇒ _)} {.(_ ⇒ _)} (c ↣ d) (blame x) v∶A ¬v∶B = ⊥-elim (¬v∶B tt) 49 | get-blame-label {.(_ `× _)} {.(_ `× _)} (c `× d) (fst v) v∶A ¬v∶B = 50 | get-blame-label c v v∶A ¬v∶B 51 | get-blame-label {.(_ `× _)} {.(_ `× _)} (c `× d) (snd v) v∶A ¬v∶B = 52 | get-blame-label d v v∶A ¬v∶B 53 | get-blame-label {.(_ `× _)} {.(_ `× _)} (c `× d) (blame x) v∶A ¬v∶B = ⊥-elim (¬v∶B tt) 54 | get-blame-label {.(_ `⊎ _)} {.(_ `⊎ _)} (c `+ d) (inl V) V∶A ¬V∶B = 55 | get-blame-label₊ c V V∶A ¬V∶B 56 | get-blame-label {.(_ `⊎ _)} {.(_ `⊎ _)} (c `+ d) (inr V) V∶A ¬V∶B = 57 | get-blame-label₊ d V V∶A ¬V∶B 58 | get-blame-label {.(_ `⊎ _)} {.(_ `⊎ _)} (c `+ d) (blame x) v∶A ¬v∶B = ⊥-elim (¬v∶B tt) 59 | get-blame-label {A} {B} (⊥ .A ⟨ ℓ ⟩ .B) v v∶A ¬v∶B = ℓ ∷ [] 60 | 61 | 62 | infix 4 _↝⟦_⟧↝_ 63 | infix 4 _↝⟦_⟧₊↝_ 64 | 65 | data _↝⟦_⟧↝_ : ∀ {A B} → Val → (c : Cast (A ⇒ B)) → Val → Set 66 | data _↝⟦_⟧₊↝_ : ∀ {A B} → List Val → (c : Cast (A ⇒ B)) → List Val → Set where 67 | [] : ∀ {A B}{c : Cast (A ⇒ B)} → [] ↝⟦ c ⟧₊↝ [] 68 | _∷_ : ∀ {v V v' V'}{A B}{c : Cast (A ⇒ B)} 69 | → v ↝⟦ c ⟧↝ v' → V ↝⟦ c ⟧₊↝ V' 70 | → (v ∷ V) ↝⟦ c ⟧₊↝ (v' ∷ V') 71 | data _↝⟦_⟧↝_ where 72 | coerce-ok : ∀ {A B}{c : Cast (A ⇒ B)}{v} 73 | → ⟦ v ∶ B ⟧ → v ↝⟦ c ⟧↝ v 74 | coerce-fail : ∀ {A B}{c : Cast (A ⇒ B)}{v} 75 | → (v∶A : ⟦ v ∶ A ⟧) (¬v∶B : ¬ ⟦ v ∶ B ⟧) 76 | → ∀ {ℓ} → ℓ ∈ mem (get-blame-label c v v∶A ¬v∶B) → v ↝⟦ c ⟧↝ Val.blame ℓ 77 | coerce-fun : ∀{v w v′ w′ : Value}{A B A′ B′ : Type}{c : Cast (B ⇒ A)}{d : Cast (A′ ⇒ B′)} 78 | → v′ ↝⟦ c ⟧↝ v → w ↝⟦ d ⟧↝ w′ 79 | → (v ↦ w) ↝⟦ c ↣ d ⟧↝ (v′ ↦ w′) 80 | 81 | 82 | coerce-fail-fst : 83 | v ↝⟦ c ⟧↝ blame ℓ 84 | fst v ↝⟦ c `× d ⟧↝ blame ℓ 85 | 86 | 87 | {- 88 | | -2 ⟩ 89 | proj Int L1 `× proj Int L2 90 | 91 | ⟨ true | 92 | proj Int L1 `× proj Int L2 93 | -} 94 | 95 | 96 | 𝒞⟦_⟧ : ∀ {A B} → (c : Cast (A ⇒ B)) → 𝒫 Val → 𝒫 Val 97 | 𝒞⟦ c ⟧ D v = Σ[ u ∈ Val ] u ∈ D × u ↝⟦ c ⟧↝ v 98 | 99 | 100 | omni-preserves-type : ∀ {A B} (c : Cast (A ⇒ B)) 101 | → ∀ u v → u ↝⟦ c ⟧↝ v → ⟦ u ∶ A ⟧ → ⟦ v ∶ B ⟧ 102 | omni-preserves-type₊ : ∀ {A B} (c : Cast (A ⇒ B)) 103 | → ∀ U V → U ↝⟦ c ⟧₊↝ V → ⟦ U ∶ A ⟧₊ → ⟦ V ∶ B ⟧₊ 104 | omni-preserves-type₊ c .[] .[] [] V∶A = tt 105 | omni-preserves-type₊ c (u ∷ U) (v ∷ V) (x ∷ U↝V) ⟨ u∶A , U∶A ⟩ = 106 | ⟨ omni-preserves-type c u v x u∶A , omni-preserves-type₊ c U V U↝V U∶A ⟩ 107 | omni-preserves-type c u .u (coerce-ok x) u∶A = x 108 | omni-preserves-type {B = B} c u .(Val.blame _) (coerce-fail v∶A ¬v∶B x) u∶A = ⟦blame∶τ⟧ B 109 | 110 | 111 | open import Denot.CastStructure 112 | 113 | 114 | instance 115 | dcs : DenotCastStruct 116 | dcs = record 117 | { cast = cs 118 | ; _↝⟨_⟩↝_ = _↝⟦_⟧↝_ } 119 | -------------------------------------------------------------------------------- /Denot/ParamCC.agda: -------------------------------------------------------------------------------- 1 | open import Denot.Value 2 | open import Primitives 3 | open import ScopedTuple hiding (𝒫) 4 | open import NewSigUtil 5 | open import NewDOpSig 6 | open import Utilities using (extensionality) 7 | open import SetsAsPredicates 8 | open import NewDenotProperties 9 | open import Types 10 | open import Labels 11 | open import PreCastStructure 12 | 13 | open import Data.Bool using (true; false) 14 | open import Data.Empty renaming (⊥ to False) 15 | open import Data.Nat using (ℕ) 16 | open import Data.Product using (_×_; Σ; Σ-syntax; ∃; ∃-syntax; proj₁; proj₂) 17 | renaming (_,_ to ⟨_,_⟩) 18 | open import Data.Sum using (_⊎_; inj₁; inj₂) 19 | open import Data.Unit using (⊤) 20 | open import Data.Unit.Polymorphic renaming (⊤ to p⊤; tt to ptt) 21 | open import Relation.Nullary using (¬_) 22 | 23 | 24 | module Denot.ParamCC (pcs : PreCastStruct) where 25 | open import ParamCastCalculusABT pcs public 26 | {-can use ParamCCSyntaxABT instead if we want just the syntax and don't need typing rules-} 27 | 28 | {- want a denotational semantics from this ABT syntax -} 29 | 30 | 31 | open import Fold2 Op sig 32 | open import NewSemantics Op sig public 33 | 34 | 𝕆-ParamCC : DOpSig (𝒫 Val) sig 35 | 𝕆-ParamCC (op-lam x) ⟨ F , ptt ⟩ = Λ F 36 | 𝕆-ParamCC op-app ⟨ D , ⟨ E , ptt ⟩ ⟩ = D ∗ E 37 | 𝕆-ParamCC (op-lit f P) ptt = ℘ P f 38 | 𝕆-ParamCC op-if ⟨ D , ⟨ E₁ , ⟨ E₂ , ptt ⟩ ⟩ ⟩ = If D E₁ E₂ 39 | 𝕆-ParamCC op-cons ⟨ D , ⟨ E , ptt ⟩ ⟩ = pair D E 40 | 𝕆-ParamCC op-fst ⟨ D , ptt ⟩ = car D 41 | 𝕆-ParamCC op-snd ⟨ D , ptt ⟩ = cdr D 42 | 𝕆-ParamCC (op-inl x) ⟨ D , ptt ⟩ = inleft D 43 | 𝕆-ParamCC (op-inr x) ⟨ D , ptt ⟩ = inright D 44 | 𝕆-ParamCC (op-case x₁ x₂) ⟨ D , ⟨ F₁ , ⟨ F₂ , ptt ⟩ ⟩ ⟩ = cond D F₁ F₂ 45 | 𝕆-ParamCC (op-cast x) Ds = {! !} 46 | 𝕆-ParamCC (op-wrap c x) Ds = {! !} 47 | 𝕆-ParamCC (op-blame x x₁) Ds = {! !} 48 | 49 | 50 | 𝕆-ParamCC-mono : 𝕆-monotone sig 𝕆-ParamCC 51 | 𝕆-ParamCC-mono = {! !} 52 | 53 | instance 54 | ParamCC-Semantics : Semantics 55 | ParamCC-Semantics = record { interp-op = 𝕆-ParamCC ; 56 | mono-op = 𝕆-ParamCC-mono ; 57 | error = ERR } 58 | open Semantics {{...}} public 59 | 60 | {- 61 | 𝑉⊢ : List Type → Var → Type → Type → Set 62 | 𝑃⊢ : (op : Op) → Vec Type (length (sig op)) → BTypes Type (sig op) → Type → Set 63 | 64 | open import ABTPredicate Op sig 𝑉⊢ 𝑃⊢ public renaming (_⊢_⦂_ to predicate) 65 | _⊢_⦂_ = predicate 66 | 67 | open import SubstPreserve Op sig Type 𝑉⊢ 𝑃⊢ (λ x → refl) (λ { refl refl → refl }) 68 | (λ x → x) (λ { refl ⊢M → ⊢M }) public 69 | using (preserve-rename; preserve-subst; preserve-substitution) 70 | 71 | open import GenericPredicate pcs 72 | open GenericPredicatePatterns 𝑉⊢ 𝑃⊢ public 73 | 74 | 75 | data _⊢_ : Context → Type → Set where 76 | 77 | 78 | pattern ƛ_˙_ A N = (op-lam A) ⦅ cons (bind (ast N)) nil ⦆ 79 | pattern _·_ L M = op-app ⦅ cons (ast L) (cons (ast M) nil) ⦆ 80 | pattern $_#_ r p = (op-lit r p) ⦅ nil ⦆ 81 | pattern if_then_else_endif L M N = op-if ⦅ cons (ast L) (cons (ast M) (cons (ast N) nil)) ⦆ 82 | pattern ⟦_,_⟧ M N = op-cons ⦅ cons (ast M) (cons (ast N) nil) ⦆ 83 | pattern fst_ M = op-fst ⦅ cons (ast M) nil ⦆ 84 | pattern snd_ M = op-snd ⦅ cons (ast M) nil ⦆ 85 | pattern inl_other_ M B = (op-inl B) ⦅ cons (ast M) nil ⦆ 86 | pattern inr_other_ M A = (op-inr A) ⦅ cons (ast M) nil ⦆ 87 | pattern case_of_⇒_∣_⇒_ L A M B N = 88 | (op-case A B) ⦅ cons (ast L) (cons (bind (ast M)) (cons (bind (ast N)) nil)) ⦆ 89 | pattern _⟨_⟩ M c = (op-cast c) ⦅ cons (ast M) nil ⦆ 90 | pattern _⟨_₍_₎⟩ M c i = (op-wrap c i) ⦅ cons (ast M) nil ⦆ 91 | pattern blame A ℓ = (op-blame A ℓ) ⦅ nil ⦆ 92 | 93 | -} -------------------------------------------------------------------------------- /EagerCoercions.agda: -------------------------------------------------------------------------------- 1 | module EagerCoercions where 2 | 3 | open import Data.Nat 4 | open import Types 5 | open import Variables 6 | open import Labels 7 | open import Relation.Nullary using (¬_; Dec; yes; no) 8 | open import Data.Sum using (_⊎_; inj₁; inj₂) 9 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 10 | renaming (_,_ to ⟨_,_⟩) 11 | open import Relation.Binary.PropositionalEquality 12 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 13 | 14 | {- 15 | 16 | n ::= 17 | I! 18 | n → n 19 | n → n; I! 20 | n → n; ⊥ 21 | ι 22 | I? 23 | I?; ⊥ 24 | I?; I! 25 | I?; n → n 26 | I?; n → n; I! 27 | I?; n → n; ⊥ 28 | 29 | 30 | -} 31 | 32 | 33 | infix 7 _↣_ 34 | infix 5 _⨟! 35 | infix 5 _??_⨟_ 36 | 37 | data gCast : Type → Set 38 | data iCast : Type → Set 39 | data nCast : Type → Set 40 | data Cast : Type → Set 41 | 42 | data gCast where 43 | idι : ∀ {ι : Base} → gCast ((` ι) ⇒ (` ι)) 44 | _↣_ : ∀ {A B A' B'} 45 | → (c : nCast (B ⇒ A)) → (d : nCast (A' ⇒ B')) 46 | ----------------------------------------- 47 | → gCast ((A ⇒ A') ⇒ (B ⇒ B')) 48 | _×'_ : ∀ {A B A' B'} 49 | → (c : nCast (A ⇒ B)) → (d : nCast (A' ⇒ B')) 50 | ----------------------------------------- 51 | → gCast ((A `× A') ⇒ (B `× B')) 52 | _+'_ : ∀ {A B A' B'} 53 | → (c : nCast (A ⇒ B)) → (d : nCast (A' ⇒ B')) 54 | ----------------------------------------- 55 | → gCast ((A `⊎ A') ⇒ (B `⊎ B')) 56 | 57 | data iCast where 58 | _⨟! : ∀{A} {G : Type} 59 | → gCast (A ⇒ G) 60 | ------------------------ 61 | → iCast (A ⇒ ⋆) 62 | `_ : ∀{A B} 63 | → gCast (A ⇒ B) 64 | → iCast (A ⇒ B) 65 | cfail : ∀{A B} (G : Type) → (H : Type) → Label → {a : A ≢ ⋆} 66 | → iCast (A ⇒ B) 67 | 68 | data nCast where 69 | id★ : nCast (⋆ ⇒ ⋆) 70 | _??_⨟_ : ∀{B} 71 | → (G : Type) → Label → iCast (G ⇒ B) 72 | ---------------------------------- 73 | → nCast (⋆ ⇒ B) 74 | _⨟! : ∀{A} {G : Type} 75 | → gCast (A ⇒ G) 76 | ------------------------ 77 | → nCast (A ⇒ ⋆) 78 | `_ : ∀{A B} 79 | → gCast (A ⇒ B) 80 | → nCast (A ⇒ B) 81 | gfail : ∀{A B} → (C : Type) → Label 82 | → gCast (A ⇒ B) 83 | → nCast (A ⇒ C) 84 | 85 | data Cast where 86 | `_ : ∀{A B} 87 | → nCast (A ⇒ B) 88 | → Cast (A ⇒ B) 89 | cfail : ∀{A B} (G : Type) → (H : Type) → Label → {a : A ≢ ⋆} 90 | → Cast (A ⇒ B) 91 | 92 | import ParamCastCalculus 93 | module CastCalc = ParamCastCalculus Cast 94 | open CastCalc 95 | 96 | 97 | {- 98 | import ParamCastReduction 99 | module PCR = ParamCastReduction Cast Inert Active ActiveOrInert 100 | open PCR 101 | -} 102 | -------------------------------------------------------------------------------- /ForgetfulCast.agda: -------------------------------------------------------------------------------- 1 | module ForgetfulCast where 2 | 3 | open import Data.Nat 4 | open import Data.Bool 5 | open import Types 6 | open import Variables 7 | open import Labels 8 | open import Relation.Nullary using (¬_; Dec; yes; no) 9 | open import Relation.Nullary.Negation using (contradiction) 10 | open import Relation.Binary.PropositionalEquality 11 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 13 | renaming (_,_ to ⟨_,_⟩) 14 | open import Data.Sum using (_⊎_; inj₁; inj₂) 15 | open import Data.Empty using (⊥; ⊥-elim) 16 | 17 | data Cast : Type → Set where 18 | _⇒_ : (A : Type) → (B : Type) → {c : A ~ B } → Cast (A ⇒ B) 19 | 20 | import ParamCastCalculus 21 | module CastCalc = ParamCastCalculus Cast 22 | open CastCalc 23 | 24 | {- 25 | 26 | Not sure about the inert/active categorization. -Jeremy 27 | 28 | -} 29 | 30 | data Inert : ∀ {A} → Cast A → Set where 31 | inert : ∀{A} → A ≢ ⋆ → (c : Cast (A ⇒ ⋆)) → Inert c 32 | 33 | data Active : ∀ {A} → Cast A → Set where 34 | activeId : ∀{A} → {a : Atomic A} → (c : Cast (A ⇒ A)) → Active c 35 | activeProj : ∀{B} → (c : Cast (⋆ ⇒ B)) → B ≢ ⋆ → Active c 36 | activeFun : ∀{A B A' B'} → (c : Cast ((A ⇒ B) ⇒ (A' ⇒ B'))) → Active c 37 | activePair : ∀{A B A' B'} → (c : Cast ((A `× B) ⇒ (A' `× B'))) → Active c 38 | activeSum : ∀{A B A' B'} → (c : Cast ((A `⊎ B) ⇒ (A' `⊎ B'))) → Active c 39 | 40 | ActiveOrInert : ∀{A} → (c : Cast A) → Active c ⊎ Inert c 41 | ActiveOrInert ((.⋆ ⇒ B) {unk~L}) with eq-unk B 42 | ... | yes eq rewrite eq = inj₁ (activeId{⋆}{A-Unk} (⋆ ⇒ ⋆)) 43 | ... | no neq = inj₁ (activeProj (⋆ ⇒ B) neq) 44 | ActiveOrInert ((A ⇒ .⋆) {unk~R}) with eq-unk A 45 | ... | yes eq rewrite eq = inj₁ (activeId{⋆}{A-Unk} (⋆ ⇒ ⋆)) 46 | ... | no neq = inj₂ (inert neq (A ⇒ ⋆)) 47 | ActiveOrInert (((` ι) ⇒ (` ι)) {base~}) = 48 | inj₁ (activeId{` ι}{A-Base} ((` ι) ⇒ (` ι))) 49 | ActiveOrInert (((A₁ ⇒ A₂) ⇒ (B₁ ⇒ B₂)) {fun~ c d}) = 50 | inj₁ (activeFun ((A₁ ⇒ A₂) ⇒ (B₁ ⇒ B₂))) 51 | ActiveOrInert (((A₁ `× A₂) ⇒ (B₁ `× B₂)) {pair~ c d}) = 52 | inj₁ (activePair ((A₁ `× A₂) ⇒ (B₁ `× B₂))) 53 | ActiveOrInert (((A₁ `⊎ A₂) ⇒ (B₁ `⊎ B₂)) {sum~ c d}) = 54 | inj₁ (activeSum ((A₁ `⊎ A₂) ⇒ (B₁ `⊎ B₂))) 55 | 56 | import EfficientParamCasts 57 | module PCR = EfficientParamCasts Cast Inert Active ActiveOrInert 58 | open PCR 59 | 60 | {- 61 | import ParamCastReduction 62 | module PCR = ParamCastReduction Cast Inert Active ActiveOrInert 63 | open PCR 64 | -} 65 | 66 | applyCast : ∀ {Γ A B} → (M : Γ ⊢ A) → (Value M) → (c : Cast (A ⇒ B)) 67 | → ∀ {a : Active c} → Γ ⊢ B 68 | {- Id -} 69 | applyCast {Γ} {A} {.A} M v ((A ⇒ .A) {c}) {activeId .(A ⇒ A)} = M 70 | {- Collapse and Conflict -} 71 | applyCast {Γ} {.⋆} {B} M v ((.⋆ ⇒ B) {c}) {activeProj .(⋆ ⇒ B) x} = {!!} 72 | {- 73 | with PCR.canonical⋆ M v 74 | ... | ⟨ A' , ⟨ M' , ⟨ _ , ⟨ _ , meq ⟩ ⟩ ⟩ ⟩ rewrite meq with A' `~ B 75 | ... | yes ap-b = M' ⟨ (A' ⇒ B) {ap-b} ⟩ 76 | ... | no ap-b = blame (pos 0) 77 | -} 78 | {- CastFun -} 79 | applyCast {Γ} {A₁ ⇒ A₂} {B₁ ⇒ B₂} M v ((.(_ ⇒ _) ⇒ .(_ ⇒ _)) {c}) 80 | {activeFun .((_ ⇒ _) ⇒ (_ ⇒ _))} = {!!} 81 | 82 | {- Cast Pair -} 83 | applyCast{Γ}{A₁ `× A₂}{B₁ `× B₂}M v ((_ ⇒ _){c}){activePair(_ ⇒ _)}= 84 | cons (fst M ⟨ (A₁ ⇒ B₁) {~×L c} ⟩) (snd M ⟨ (A₂ ⇒ B₂) {~×R c}⟩) 85 | {- Cast Sum -} 86 | applyCast{Γ}{A₁ `⊎ A₂}{B₁ `⊎ B₂}M v((_ ⇒ _){c}){activeSum .(_ ⇒ _)}= 87 | let l = inl ((` Z) ⟨ (A₁ ⇒ B₁) {~⊎L c}⟩) in 88 | let r = inr ((` Z) ⟨ (A₂ ⇒ B₂) {~⊎R c}⟩) in 89 | case M (ƛ l) (ƛ r) 90 | 91 | {- 92 | funCast : ∀ {Γ A A' B'} → Γ ⊢ A → (c : Cast (A ⇒ (A' ⇒ B'))) 93 | → ∀ {i : Inert c} → Γ ⊢ A' → Γ ⊢ B' 94 | funCast M c {()} N 95 | -} 96 | 97 | funSrc : ∀{A A' B' Γ} 98 | → (c : Cast (A ⇒ (A' ⇒ B'))) → (i : Inert c) 99 | → (M : Γ ⊢ A) → SimpleValue M 100 | → Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ ⇒ A₂ 101 | funSrc c i M V = {!!} 102 | 103 | dom : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ ⇒ A₂) ⇒ (A' ⇒ B'))) → Inert c 104 | → Cast (A' ⇒ A₁) 105 | dom c () 106 | 107 | cod : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ ⇒ A₂) ⇒ (A' ⇒ B'))) → Inert c 108 | → Cast (A₂ ⇒ B') 109 | cod c () 110 | 111 | fstCast : ∀ {Γ A A' B'} → (M : Γ ⊢ A) → SimpleValue M 112 | → (c : Cast (A ⇒ (A' `× B'))) → ∀ {i : Inert c} → Γ ⊢ A' 113 | fstCast M v c {i} = {!!} 114 | 115 | sndCast : ∀ {Γ A A' B'} → (M : Γ ⊢ A) → SimpleValue M 116 | → (c : Cast (A ⇒ (A' `× B'))) → ∀ {i : Inert c} → Γ ⊢ B' 117 | sndCast M v c {i} = {!!} 118 | 119 | caseCast : ∀ {Γ A A' B' C} → (L : Γ ⊢ A) → SimpleValue L 120 | → (c : Cast (A ⇒ (A' `⊎ B'))) 121 | → ∀ {i : Inert c} → Γ ⊢ A' ⇒ C → Γ ⊢ B' ⇒ C → Γ ⊢ C 122 | caseCast L v c {i} M N = {!!} 123 | 124 | baseNotInert : ∀ {A ι} → (c : Cast (A ⇒ ` ι)) → A ≢ ⋆ → ¬ Inert c 125 | baseNotInert c ne = {!!} 126 | 127 | compose : ∀{A B C} → Cast (A ⇒ B) → Cast (B ⇒ C) → Cast (A ⇒ C) 128 | compose = {!!} 129 | 130 | module Red = PCR.Reduction applyCast funSrc dom cod fstCast sndCast caseCast 131 | baseNotInert compose 132 | open Red 133 | 134 | import GTLC2CC 135 | module Compile = GTLC2CC Cast (λ A B ℓ {c} → (A ⇒ B) {c}) 136 | 137 | -------------------------------------------------------------------------------- /GTLC2CC.agda: -------------------------------------------------------------------------------- 1 | open import Types 2 | open import Variables 3 | open import Labels 4 | open import Data.Nat using (ℕ; zero; suc) 5 | 6 | module GTLC2CC 7 | (Cast : Type → Set) 8 | (Inert : ∀ {A} → Cast A → Set) 9 | (cast : (A : Type) → (B : Type) → Label → {c : A ~ B } → Cast (A ⇒ B)) 10 | where 11 | 12 | open import GTLC 13 | open import ParamCastCalculus Cast Inert 14 | 15 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 16 | renaming (_,_ to ⟨_,_⟩) 17 | open import Data.Sum using (_⊎_; inj₁; inj₂) 18 | open import Data.Maybe 19 | open import Relation.Binary.PropositionalEquality 20 | using (_≡_; refl; trans; sym; cong; cong-app) 21 | 22 | 23 | compile-var : ∀{Γ A}{x} → Γ ∋ x ⦂ A → Γ ∋ A 24 | compile-var Z = Z 25 | compile-var (S ∋x) = let IH = compile-var ∋x in S IH 26 | 27 | compile : ∀ {Γ A} (M : Term) → (d : Γ ⊢G M ⦂ A) → (Γ ⊢ A) 28 | compile (` x) (⊢var ∋x) = ` (compile-var ∋x) 29 | compile (ƛ A ˙ N) (⊢lam d) = ƛ (compile N d) 30 | compile (L · M at ℓ) (⊢app {A = A}{A₁}{A₂}{B} d₁ d₂ mA A1~B) = 31 | let L' = (compile L d₁) ⟨ cast A (A₁ ⇒ A₂) ℓ {consis (▹⇒⊑ mA) Refl⊑} ⟩ in 32 | let M' = (compile M d₂) ⟨ cast B A₁ ℓ {Sym~ A1~B} ⟩ in 33 | L' · M' 34 | compile ($ k # p) ⊢lit = $_ k {p} 35 | compile (if L then M else N at ℓ) (⊢if {A = A}{A'}{B} d₁ d₂ d₃ B~Bool A~A') = 36 | let L' = (compile L d₁) ⟨ cast B (` 𝔹) ℓ {B~Bool} ⟩ in 37 | let M' = (compile M d₂) ⟨ cast A (⨆ A~A') ℓ {~⨆ A~A'} ⟩ in 38 | let N' = (compile N d₃) ⟨ cast A' (⨆ A~A') ℓ {⨆~ A~A'} ⟩ in 39 | if L' M' N' 40 | compile (⟦ M , N ⟧) (⊢cons d₁ d₂) = cons (compile M d₁) (compile N d₂) 41 | compile (fst M at ℓ) (⊢fst {A = A}{A₁}{A₂} d mA) = 42 | let c = cast A (A₁ `× A₂) ℓ {consis (▹×⊑ mA) Refl⊑} in 43 | let M' = (compile M d) ⟨ c ⟩ in 44 | fst M' 45 | compile (snd M at ℓ) (⊢snd {A = A}{A₁}{A₂} d mA) = 46 | let c = cast A (A₁ `× A₂) ℓ {consis (▹×⊑ mA) Refl⊑} in 47 | let M' = (compile M d) ⟨ c ⟩ in 48 | snd M' 49 | compile (inl M other B) (⊢inl d) = inl (compile M d) 50 | compile (inr M other A) (⊢inr d) = inr (compile M d) 51 | compile (case L of B₁ ⇒ M ∣ C₁ ⇒ N at ℓ) 52 | (⊢case {A = A}{B₁}{B₂}{C₁}{C₂} d₁ d₂ d₃ A~B1C1 B2~C2) = 53 | let L' = (compile L d₁) ⟨ cast A (B₁ `⊎ C₁) ℓ {A~B1C1} ⟩ in 54 | let M' = (compile M d₂) ⟨ cast B₂ (⨆ B2~C2) ℓ {~⨆ B2~C2} ⟩ in 55 | let N' = (compile N d₃) ⟨ cast C₂ (⨆ B2~C2) ℓ {⨆~ B2~C2} ⟩ in 56 | case L' M' N' 57 | 58 | 59 | {- 60 | compile (` x) = ` x 61 | compile (ƛ A ˙ M) = ƛ (compile M) 62 | compile (_·_at_ {Γ}{A}{A₁}{A₂}{B} L M ℓ {m}{cn}) = 63 | let L' = (compile L) ⟨ cast A (A₁ ⇒ A₂) ℓ {consis (▹⇒⊑ m) Refl⊑} ⟩ in 64 | let M' = (compile M) ⟨ cast B A₁ ℓ {Sym~ cn} ⟩ in 65 | L' · M' 66 | compile ($_ k {p}) = ($ k) {p} 67 | compile (if {Γ}{A}{A'}{B} L M N ℓ {bb}{c}) = 68 | let L' = (compile L) ⟨ cast B (` 𝔹) ℓ {bb} ⟩ in 69 | let M' = (compile M) ⟨ cast A (⨆ c) ℓ {~⨆ c} ⟩ in 70 | let N' = (compile N) ⟨ cast A' (⨆ c) ℓ {⨆~ c} ⟩ in 71 | if L' M' N' 72 | compile (cons L M) = 73 | let L' = compile L in 74 | let M' = compile M in 75 | cons L' M' 76 | compile (fst {Γ}{A}{A₁}{A₂} M ℓ {m}) = 77 | let M' = (compile M) ⟨ cast A (A₁ `× A₂) ℓ {consis (▹×⊑ m) Refl⊑} ⟩ in 78 | fst M' 79 | compile (snd {Γ}{A}{A₁}{A₂} M ℓ {m}) = 80 | let M' = (compile M) ⟨ cast A (A₁ `× A₂) ℓ {consis (▹×⊑ m) Refl⊑} ⟩ in 81 | snd M' 82 | compile (inl B M) = inl (compile M) 83 | compile (inr A M) = inr (compile M) 84 | compile (case {Γ}{A}{A₁}{A₂}{B₁}{B₂}{C₁}{C₂} L M N ℓ 85 | {ma}{ab}{ac}{bc}) = 86 | let L' = (compile L) ⟨ cast A (A₁ `⊎ A₂) ℓ {consis (▹⊎⊑ ma) Refl⊑} ⟩ 87 | ⟨ cast (A₁ `⊎ A₂) (B₁ `⊎ C₁) ℓ {sum~ ab ac} ⟩ in 88 | let M' = (compile M) ⟨ cast B₂ (⨆ bc) ℓ {~⨆ bc} ⟩ in 89 | let N' = (compile N) ⟨ cast C₂ (⨆ bc) ℓ {⨆~ bc} ⟩ in 90 | case L' M' N' 91 | -} 92 | 93 | 94 | {- 95 | open import GTLC-materialize 96 | 97 | compile-mat : ∀ {Γ M A} → (Γ ⊢m M ⦂ A) → Σ[ A' ∈ Type ] Γ ⊢ A' × A' ⊑ A 98 | compile-mat d 99 | with mat-impl-trad d 100 | ... | ⟨ A' , ⟨ d' , lt ⟩ ⟩ = 101 | ⟨ A' , ⟨ (compile d') , lt ⟩ ⟩ 102 | 103 | -} 104 | -------------------------------------------------------------------------------- /GTLC2CCOrig.agda: -------------------------------------------------------------------------------- 1 | open import Types 2 | open import Variables 3 | open import Labels 4 | open import Data.Nat using (ℕ; zero; suc) 5 | 6 | module GTLC2CCOrig 7 | (Cast : Type → Set) 8 | (cast : (A : Type) → (B : Type) → Label → {c : A ~ B } → Cast (A ⇒ B)) 9 | where 10 | 11 | open import GTLC 12 | open import ParamCastCalculusOrig Cast 13 | 14 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 15 | renaming (_,_ to ⟨_,_⟩) 16 | open import Data.Sum using (_⊎_; inj₁; inj₂) 17 | open import Data.Maybe 18 | open import Relation.Binary.PropositionalEquality 19 | using (_≡_; refl; trans; sym; cong; cong-app) 20 | 21 | 22 | compile-var : ∀{Γ A}{x} → Γ ∋ x ⦂ A → Γ ∋ A 23 | compile-var Z = Z 24 | compile-var (S ∋x) = let IH = compile-var ∋x in S IH 25 | 26 | compile : ∀ {Γ A} (M : Term) → (d : Γ ⊢G M ⦂ A) → (Γ ⊢ A) 27 | compile (` x) (⊢var ∋x) = ` (compile-var ∋x) 28 | compile (ƛ A ˙ N) (⊢lam d) = ƛ (compile N d) 29 | compile (L · M at ℓ) (⊢app {A = A}{A₁}{A₂}{B} d₁ d₂ mA A1~B) = 30 | let L' = (compile L d₁) ⟨ cast A (A₁ ⇒ A₂) ℓ {consis (▹⇒⊑ mA) Refl⊑} ⟩ in 31 | let M' = (compile M d₂) ⟨ cast B A₁ ℓ {Sym~ A1~B} ⟩ in 32 | L' · M' 33 | compile ($ k # p) ⊢lit = $_ k {p} 34 | compile (if L then M else N at ℓ) (⊢if {A = A}{A'}{B} d₁ d₂ d₃ B~Bool A~A') = 35 | let L' = (compile L d₁) ⟨ cast B (` 𝔹) ℓ {B~Bool} ⟩ in 36 | let M' = (compile M d₂) ⟨ cast A (⨆ A~A') ℓ {~⨆ A~A'} ⟩ in 37 | let N' = (compile N d₃) ⟨ cast A' (⨆ A~A') ℓ {⨆~ A~A'} ⟩ in 38 | if L' M' N' 39 | compile (⟦ M , N ⟧) (⊢cons d₁ d₂) = cons (compile M d₁) (compile N d₂) 40 | compile (fst M at ℓ) (⊢fst {A = A}{A₁}{A₂} d mA) = 41 | let c = cast A (A₁ `× A₂) ℓ {consis (▹×⊑ mA) Refl⊑} in 42 | let M' = (compile M d) ⟨ c ⟩ in 43 | fst M' 44 | compile (snd M at ℓ) (⊢snd {A = A}{A₁}{A₂} d mA) = 45 | let c = cast A (A₁ `× A₂) ℓ {consis (▹×⊑ mA) Refl⊑} in 46 | let M' = (compile M d) ⟨ c ⟩ in 47 | snd M' 48 | compile (inl M other B) (⊢inl d) = inl (compile M d) 49 | compile (inr M other A) (⊢inr d) = inr (compile M d) 50 | compile (case L of B₁ ⇒ M ∣ C₁ ⇒ N at ℓ) 51 | (⊢case {A = A}{B₁}{B₂}{C₁}{C₂} d₁ d₂ d₃ A~B1C1 B2~C2) = 52 | let L' = (compile L d₁) ⟨ cast A (B₁ `⊎ C₁) ℓ {A~B1C1} ⟩ in 53 | let M' = (compile M d₂) ⟨ cast B₂ (⨆ B2~C2) ℓ {~⨆ B2~C2} ⟩ in 54 | let N' = (compile N d₃) ⟨ cast C₂ (⨆ B2~C2) ℓ {⨆~ B2~C2} ⟩ in 55 | case L' (ƛ M') (ƛ N') 56 | -------------------------------------------------------------------------------- /GTLCPrecision.agda: -------------------------------------------------------------------------------- 1 | open import Relation.Nullary using (¬_; Dec; yes; no) 2 | open import Relation.Binary.PropositionalEquality 3 | using (_≡_; _≢_; refl) 4 | open import Data.Nat using (ℕ) 5 | open import Data.Product using (_×_; proj₁; proj₂; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩) 6 | 7 | open import Types 8 | open import Variables 9 | open import Labels 10 | 11 | open import GTLC 12 | 13 | 14 | 15 | module GTLCPrecision where 16 | 17 | infix 6 _⊑ᴳ_ 18 | 19 | 20 | -- Term precision for GTLC - M₁ ⊑ᴳ M₂ means that M₂ is *more precise* than M₁ . 21 | data _⊑ᴳ_ : ∀ (M M′ : Term) → Set where 22 | 23 | ⊑ᴳ-prim : ∀ {A} {r : rep A} {p : Prim A} 24 | ------------------------------ 25 | → $ r # p ⊑ᴳ $ r # p 26 | 27 | ⊑ᴳ-var : ∀ {x : ℕ} 28 | ----------------- 29 | → ` x ⊑ᴳ ` x 30 | 31 | ⊑ᴳ-ƛ : ∀ {A A′} {N N′ : Term} 32 | → A ⊑ A′ 33 | → N ⊑ᴳ N′ 34 | --------------------- 35 | → ƛ A ˙ N ⊑ᴳ ƛ A′ ˙ N′ 36 | 37 | ⊑ᴳ-· : ∀ {L L′ M M′} {ℓ ℓ′} 38 | → L ⊑ᴳ L′ 39 | → M ⊑ᴳ M′ 40 | ---------------------------- 41 | → L · M at ℓ ⊑ᴳ L′ · M′ at ℓ′ 42 | 43 | ⊑ᴳ-if : ∀ {L L′ M M′ N N′} {ℓ ℓ′} 44 | → L ⊑ᴳ L′ 45 | → M ⊑ᴳ M′ 46 | → N ⊑ᴳ N′ 47 | ------------------------------------------------------- 48 | → if L then M else N at ℓ ⊑ᴳ if L′ then M′ else N′ at ℓ′ 49 | 50 | ⊑ᴳ-cons : ∀ {M M′ N N′} 51 | → M ⊑ᴳ M′ 52 | → N ⊑ᴳ N′ 53 | -------------------------- 54 | → ⟦ M , N ⟧ ⊑ᴳ ⟦ M′ , N′ ⟧ 55 | 56 | ⊑ᴳ-fst : ∀ {M M′} {ℓ ℓ′} 57 | → M ⊑ᴳ M′ 58 | --------------------------- 59 | → fst M at ℓ ⊑ᴳ fst M′ at ℓ′ 60 | 61 | ⊑ᴳ-snd : ∀ {M M′} {ℓ ℓ′} 62 | → M ⊑ᴳ M′ 63 | --------------------------- 64 | → snd M at ℓ ⊑ᴳ snd M′ at ℓ′ 65 | 66 | ⊑ᴳ-inl : ∀ {B B′} {M M′} 67 | → B ⊑ B′ 68 | → M ⊑ᴳ M′ 69 | ------------------------------ 70 | → inl M other B ⊑ᴳ inl M′ other B′ 71 | 72 | ⊑ᴳ-inr : ∀ {A A′} {M M′} 73 | → A ⊑ A′ 74 | → M ⊑ᴳ M′ 75 | ------------------------------ 76 | → inr M other A ⊑ᴳ inr M′ other A′ 77 | 78 | ⊑ᴳ-case : ∀ {B₁ B₁′ C₁ C₁′} {L L′ M M′ N N′} {ℓ ℓ′} 79 | → L ⊑ᴳ L′ 80 | → B₁ ⊑ B₁′ → C₁ ⊑ C₁′ 81 | → M ⊑ᴳ M′ 82 | → N ⊑ᴳ N′ 83 | ---------------------------------------------------------------------------- 84 | → case L of B₁ ⇒ M ∣ C₁ ⇒ N at ℓ ⊑ᴳ case L′ of B₁′ ⇒ M′ ∣ C₁′ ⇒ N′ at ℓ′ 85 | 86 | {- Example(s): 87 | Similar to the example in Fig. 5, Refined Criteria. -} 88 | _ : (ƛ ⋆ ˙ (` 0)) · ($ 42 # P-Base) at pos 0 ⊑ᴳ (ƛ (` Nat) ˙ (` 0)) · ($ 42 # P-Base) at pos 0 89 | _ = ⊑ᴳ-· (⊑ᴳ-ƛ unk⊑ ⊑ᴳ-var) ⊑ᴳ-prim 90 | -------------------------------------------------------------------------------- /GenericPredicate.agda: -------------------------------------------------------------------------------- 1 | open import Data.List 2 | using (List; []; _∷_; length) 3 | open import Data.Vec 4 | using (Vec) 5 | renaming ([] to []ᵥ; _∷_ to _∷ᵥ_) 6 | open import Data.Product renaming (_,_ to ⟨_,_⟩) 7 | open import Data.Unit renaming (tt to unit) 8 | import Relation.Binary.PropositionalEquality as Eq 9 | open Eq using (_≡_; refl; sym; cong) 10 | 11 | open import PreCastStructure 12 | open import Syntax 13 | 14 | module GenericPredicate (precast : PreCastStruct) where 15 | 16 | open import ParamCCSyntaxABT precast using (Op; sig) 17 | open Op 18 | 19 | module GenericPredicatePatterns {ℓ} {I : Set ℓ} 20 | (𝑉 : List I → Var → I → I → Set) 21 | (𝑃 : (op : Op) → Vec I (length (sig op)) → BTypes I (sig op) → I → Set) 22 | where 23 | 24 | open import ABTPredicate Op sig 𝑉 𝑃 25 | 26 | pattern ⊢` ∋x = var-p ∋x refl 27 | 28 | pattern ⊢ƛ A ⊢N eq = 29 | op-p {op = op-lam A} (cons-p (bind-p (ast-p ⊢N)) nil-p) eq 30 | 31 | pattern ⊢· ⊢L ⊢M eq = 32 | op-p {op = op-app} 33 | (cons-p (ast-p ⊢L) (cons-p (ast-p ⊢M) nil-p)) eq 34 | 35 | pattern ⊢$ r p eq = 36 | op-p {op = op-lit r p} nil-p eq 37 | 38 | pattern ⊢if ⊢L ⊢M ⊢N eq = 39 | op-p {op = op-if} 40 | (cons-p (ast-p ⊢L) 41 | (cons-p (ast-p ⊢M) 42 | (cons-p (ast-p ⊢N) nil-p))) eq 43 | 44 | pattern ⊢cons ⊢M ⊢N eq = 45 | op-p {op = op-cons} 46 | (cons-p (ast-p ⊢M) (cons-p (ast-p ⊢N) nil-p)) eq 47 | 48 | pattern ⊢fst ⊢M eq = 49 | op-p {op = op-fst} (cons-p (ast-p ⊢M) nil-p) eq 50 | 51 | pattern ⊢snd ⊢M eq = 52 | op-p {op = op-snd} (cons-p (ast-p ⊢M) nil-p) eq 53 | 54 | pattern ⊢inl B ⊢M eq = 55 | op-p {op = op-inl B} (cons-p (ast-p ⊢M) nil-p) eq 56 | 57 | pattern ⊢inr A ⊢M eq = 58 | op-p {op = op-inr A} (cons-p (ast-p ⊢M) nil-p) eq 59 | 60 | pattern ⊢case A B ⊢L ⊢M ⊢N eq = 61 | op-p {op = op-case A B} 62 | (cons-p (ast-p ⊢L) 63 | (cons-p (bind-p (ast-p ⊢M)) 64 | (cons-p (bind-p (ast-p ⊢N)) nil-p))) eq 65 | 66 | pattern ⊢cast c ⊢M eq = 67 | op-p {op = op-cast c} (cons-p (ast-p ⊢M) nil-p) eq 68 | 69 | pattern ⊢wrap c i ⊢M eq = 70 | op-p {op = op-wrap c i} (cons-p (ast-p ⊢M) nil-p) eq 71 | 72 | pattern ⊢blame A ℓ eq = 73 | op-p {op = op-blame A ℓ} nil-p eq 74 | -------------------------------------------------------------------------------- /GroundCoercionsABT.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | module GroundCoercionsABT where 4 | 5 | open import Data.Nat 6 | open import Types 7 | open import Labels 8 | open import Relation.Nullary using (¬_; Dec; yes; no) 9 | open import Relation.Nullary.Negation using (contradiction) 10 | open import Data.Sum using (_⊎_; inj₁; inj₂) 11 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 12 | renaming (_,_ to ⟨_,_⟩) 13 | open import Relation.Binary.PropositionalEquality 14 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 15 | 16 | open import PreCastStructure 17 | open import GroundCoercions 18 | using (pcs; id; inj; proj; cfun; cpair; csum; cseq; C-pair; C-sum; I-inj) public 19 | open PreCastStruct pcs public 20 | 21 | import ParamCastCalculusABT 22 | import ParamCastAuxABT 23 | open ParamCastCalculusABT pcs renaming (fst_ to first_; snd_ to second_; blame to mkblame) public 24 | open ParamCastAuxABT pcs public 25 | 26 | applyCast : ∀ {Γ A B} → (M : Term) → Γ ⊢ M ⦂ A → (Value M) → (c : Cast (A ⇒ B)) 27 | → ∀ {a : Active c} → Term 28 | applyCast {Γ} {A} {.A} M Γ⊢M∶A vM id {a} = M 29 | applyCast {Γ} {.⋆} {B} M Γ⊢M∶A vM (proj .B ℓ {gb}) {a} with canonical⋆ Γ⊢M∶A vM 30 | ... | ⟨ G , ⟨ V , ⟨ .(inj G) , ⟨ GroundCoercions.I-inj {G}{ga} , ⟨ q , refl ⟩ ⟩ ⟩ ⟩ ⟩ 31 | with gnd-eq? G B {ga} {gb} 32 | ... | no neq = mkblame B ℓ 33 | ... | yes refl = V 34 | applyCast {Γ} {.(_ `× _)} {.(_ `× _)} M Γ⊢M∶A vM (cpair c d) {a} = eta× M (cpair c d) C-pair 35 | applyCast {Γ} {.(_ `⊎ _)} {.(_ `⊎ _)} M Γ⊢M∶A vM (csum c d) {a} = eta⊎ M (csum c d) C-sum 36 | applyCast {Γ} {A} {B} M Γ⊢M∶A vM (cseq c d) {a} = (M ⟨ c ⟩) ⟨ d ⟩ 37 | 38 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 39 | → (⊢V : Γ ⊢ V ⦂ A) 40 | → (v : Value V) → (a : Active c) 41 | -------------------------------- 42 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 43 | applyCast-wt = {! !} 44 | 45 | 46 | open import CastStructureABT 47 | 48 | cs : CastStruct 49 | cs = record { precast = pcs 50 | ; applyCast = applyCast 51 | ; applyCast-wt = applyCast-wt } 52 | 53 | 54 | open import ParamCastReductionABT cs public 55 | 56 | 57 | {- 58 | open import ParamCastDeterministic cs public 59 | import GTLC2CC 60 | open GTLC2CC Cast Inert (λ A B ℓ {c} → coerce A B ℓ) public 61 | -} 62 | 63 | ex-id : ∀ (A : Type) {a : Ground A} → Term 64 | ex-id A = ƛ A ˙ (` zero) 65 | 66 | ex-f : ∀ (ℓ₁ : Label) (A : Type) {a : Ground A} → Term 67 | ex-f ℓ₁ A {a} = ((ex-id A {a}) ⟨ cfun (proj A ℓ₁ {a}) (inj A {a}) ⟩) ⟨ inj (⋆ ⇒ ⋆) {G-Fun} ⟩ 68 | 69 | ex-g : ∀ (ℓ₁ ℓ₂ : Label) (A : Type) {a : Ground A} → Term 70 | ex-g ℓ₁ ℓ₂ A {a} = ((ex-f ℓ₁ A {a}) ⟨ proj (⋆ ⇒ ⋆) ℓ₂ {G-Fun} ⟩) ⟨ cfun (cseq (cfun (proj A ℓ₂ {a}) (inj A {a})) (inj (⋆ ⇒ ⋆) {G-Fun})) (proj A ℓ₂ {a}) ⟩ 71 | 72 | ex-app : ∀ (ℓ₁ ℓ₂ : Label) (A : Type) {a : Ground A} → Term 73 | ex-app ℓ₁ ℓ₂ A {a} = (ex-g ℓ₁ ℓ₂ A {a}) · (ex-id A {a}) 74 | 75 | ex-reduction : ∀ ℓ₁ ℓ₂ A {a} → ex-app ℓ₁ ℓ₂ A {a} —↠ mkblame A ℓ₁ 76 | ex-reduction ℓ₁ ℓ₂ A {a} = {! !} -------------------------------------------------------------------------------- /GroundCoercionsBlame.agda: -------------------------------------------------------------------------------- 1 | module GroundCoercionsBlame where 2 | 3 | open import Data.Nat 4 | open import Data.Bool 5 | open import Relation.Nullary using (¬_; Dec; yes; no) 6 | open import Relation.Nullary.Negation using (contradiction) 7 | open import Relation.Binary.PropositionalEquality 8 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 9 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 10 | renaming (_,_ to ⟨_,_⟩) 11 | open import Data.Sum using (_⊎_; inj₁; inj₂) 12 | open import Data.Empty using (⊥; ⊥-elim) 13 | open import Data.Empty.Irrelevant renaming (⊥-elim to ⊥-elimi) 14 | 15 | open import Types 16 | open import Variables 17 | open import Labels 18 | open import GroundCoercions 19 | 20 | data CastBlameSafe : ∀ {A} → Cast A → Label → Set where 21 | 22 | safe-id : ∀ {A} {a : Atomic A} {ℓ} 23 | → CastBlameSafe (id {A} {a}) ℓ 24 | 25 | safe-inj : ∀ {A} {g : Ground A} {ℓ} 26 | → CastBlameSafe (inj A {g}) ℓ 27 | 28 | safe-proj : ∀ {B} {g : Ground B} {ℓ ℓ′} 29 | → ℓ ≢̂ ℓ′ 30 | → CastBlameSafe (proj B ℓ′ {g}) ℓ 31 | 32 | safe-cfun : ∀ {S₁ S₂ T₁ T₂} {c : Cast (T₁ ⇒ S₁)} {d : Cast (S₂ ⇒ T₂)} {ℓ} 33 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 34 | → CastBlameSafe (cfun c d) ℓ 35 | 36 | safe-cpair : ∀ {S₁ S₂ T₁ T₂} {c : Cast (S₁ ⇒ T₁)} {d : Cast (S₂ ⇒ T₂)} {ℓ} 37 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 38 | → CastBlameSafe (cpair c d) ℓ 39 | 40 | safe-csum : ∀ {S₁ S₂ T₁ T₂} {c : Cast (S₁ ⇒ T₁)} {d : Cast (S₂ ⇒ T₂)} {ℓ} 41 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 42 | → CastBlameSafe (csum c d) ℓ 43 | 44 | safe-cseq : ∀ {T₁ T₂ T₃} {c : Cast (T₁ ⇒ T₂)} {d : Cast (T₂ ⇒ T₃)} {ℓ} 45 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 46 | → CastBlameSafe (cseq c d) ℓ 47 | 48 | domBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 49 | → CastBlameSafe (dom c x) ℓ 50 | domBlameSafe (safe-cfun safe-c safe-d) C-fun = safe-c 51 | 52 | codBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 53 | → CastBlameSafe (cod c x) ℓ 54 | codBlameSafe (safe-cfun safe-c safe-d) C-fun = safe-d 55 | 56 | fstBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 57 | → CastBlameSafe (fstC c x) ℓ 58 | fstBlameSafe (safe-cpair safe-c safe-d) C-pair = safe-c 59 | 60 | sndBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 61 | → CastBlameSafe (sndC c x) ℓ 62 | sndBlameSafe (safe-cpair safe-c safe-d) C-pair = safe-d 63 | 64 | inlBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 65 | → CastBlameSafe (inlC c x) ℓ 66 | inlBlameSafe (safe-csum safe-c safe-d) C-sum = safe-c 67 | 68 | inrBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 69 | → CastBlameSafe (inrC c x) ℓ 70 | inrBlameSafe (safe-csum safe-c safe-d) C-sum = safe-d 71 | 72 | open import PreCastStructureWithBlameSafety 73 | 74 | pcss : PreCastStructWithBlameSafety 75 | pcss = record 76 | { precast = pcs 77 | ; CastBlameSafe = CastBlameSafe 78 | ; domBlameSafe = domBlameSafe 79 | ; codBlameSafe = codBlameSafe 80 | ; fstBlameSafe = fstBlameSafe 81 | ; sndBlameSafe = sndBlameSafe 82 | ; inlBlameSafe = inlBlameSafe 83 | ; inrBlameSafe = inrBlameSafe 84 | } 85 | 86 | open import ParamCastSubtyping pcss 87 | 88 | applyCast-pres-allsafe : ∀ {Γ A B} {V : Γ ⊢ A} {vV : Value V} {c : Cast (A ⇒ B)} {ℓ} 89 | → (a : Active c) 90 | → CastBlameSafe c ℓ 91 | → CastsAllSafe V ℓ 92 | → CastsAllSafe (applyCast V vV c {a}) ℓ 93 | applyCast-pres-allsafe {vV = vV} {c = proj B ℓ′ {gB}} A-proj (safe-proj ℓ≢) allsafe with canonical⋆ _ vV 94 | ... | ⟨ G , ⟨ V′ , ⟨ _ , ⟨ I-inj {G} {g} , meq ⟩ ⟩ ⟩ ⟩ rewrite meq with gnd-eq? G B {g} {gB} 95 | ... | no _ = allsafe-blame-diff-ℓ ℓ≢ 96 | ... | yes refl with allsafe 97 | ... | allsafe-wrap _ allsafe-V′ = allsafe-V′ 98 | applyCast-pres-allsafe A-pair (safe-cpair safe-c safe-d) allsafe = 99 | allsafe-cons (allsafe-cast safe-c (allsafe-fst allsafe)) (allsafe-cast safe-d (allsafe-snd allsafe)) 100 | applyCast-pres-allsafe A-sum (safe-csum safe-c safe-d) allsafe = 101 | allsafe-case allsafe (allsafe-inl (allsafe-cast safe-c allsafe-var)) 102 | (allsafe-inr (allsafe-cast safe-d allsafe-var)) 103 | applyCast-pres-allsafe A-id _ allsafe = allsafe 104 | applyCast-pres-allsafe A-seq (safe-cseq safe-c safe-d) allsafe = allsafe-cast safe-d (allsafe-cast safe-c allsafe) 105 | 106 | open import CastStructureWithBlameSafety 107 | 108 | css : CastStructWithBlameSafety 109 | css = record { pcss = pcss ; applyCast = applyCast ; applyCast-pres-allsafe = applyCast-pres-allsafe } 110 | 111 | -- Instantiate blame-subtyping theorem for `GroundCoercion`. 112 | open import ParamBlameSubtyping css using (soundness-<:) public 113 | -------------------------------------------------------------------------------- /GroundMachine.agda: -------------------------------------------------------------------------------- 1 | module GroundMachine where 2 | 3 | open import Data.Nat 4 | open import Data.Nat.Properties 5 | open import Relation.Binary.PropositionalEquality 6 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 7 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 8 | renaming (_,_ to ⟨_,_⟩) 9 | open import Data.Sum using (_⊎_; inj₁; inj₂) 10 | open import Relation.Nullary using (¬_; Dec; yes; no) 11 | open import Relation.Nullary.Negation using (contradiction) 12 | open import Data.Empty using (⊥-elim) renaming (⊥ to Bot) 13 | 14 | open import Labels 15 | open import Types 16 | open import EfficientGroundCoercions 17 | 18 | import AbstractMachine 19 | module AbsMach = AbstractMachine Cast Inert Active ActiveOrInert 20 | open AbsMach 21 | 22 | cast : ∀{A B} → Value A → (c : Cast (A ⇒ B)) → Value B ⊎ Label 23 | 24 | scast : ∀{A B} → SimpleValue A → (c : Cast (A ⇒ B)) → Active c 25 | → Value B ⊎ Label 26 | scast U .id★ A-id★ = ⊥-elim (contradiction refl (simple⋆ U)) 27 | scast U .(_ ?? _ ⨟ _) A-proj = ⊥-elim (contradiction refl (simple⋆ U)) 28 | scast (V-const k {()}) .(` (` (_ ×' _))) (A-intmd (A-gnd A-cpair)) 29 | scast (V-pair V₁ V₂) (` (` (c ×' d))) (A-intmd (A-gnd A-cpair)) 30 | with cast V₁ c | cast V₂ d 31 | ... | inj₁ V₁' | inj₁ V₂' = inj₁ (S-val (V-pair V₁' V₂')) 32 | ... | inj₁ V₁' | inj₂ ℓ = inj₂ ℓ 33 | ... | inj₂ ℓ | _ = inj₂ ℓ 34 | scast (V-const k {()}) _ (A-intmd (A-gnd A-csum)) 35 | scast (V-inl V) (` (` (c +' d))) (A-intmd (A-gnd A-csum)) 36 | with cast V c 37 | ... | inj₁ V' = inj₁ (S-val (V-inl V')) 38 | ... | inj₂ ℓ = inj₂ ℓ 39 | scast (V-inr V) (` (` (c +' d))) (A-intmd (A-gnd A-csum)) 40 | with cast V d 41 | ... | inj₁ V' = inj₁ (S-val (V-inr V')) 42 | ... | inj₂ ℓ = inj₂ ℓ 43 | scast U (` (` idι)) (A-intmd (A-gnd A-idι)) = inj₁ (S-val U) 44 | scast U (` cfail _ _ ℓ) (A-intmd A-cfail) = inj₂ ℓ 45 | 46 | scast' : ∀{A B} → SimpleValue A → (c : Cast (A ⇒ B)) → Value B ⊎ Label 47 | scast' U c 48 | with ActiveOrInert c 49 | ... | inj₁ a = scast U c a 50 | ... | inj₂ i = inj₁ (V-cast U c {i}) 51 | 52 | cast (S-val U) c = scast' U c 53 | cast (V-cast U c) d = scast' U (compose c d) 54 | 55 | funSrc' : ∀{A A' B'} 56 | → (c : Cast (A ⇒ (A' ⇒ B'))) → (i : Inert c) 57 | → SimpleValue A 58 | → Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ ⇒ A₂ 59 | funSrc' (G ?? x ⨟ x₁) () V 60 | funSrc' (` (` (c ↣ d))) (I-intmd (I-gnd (I-cfun{A}{B}{A'}{B'}))) V = 61 | ⟨ A , ⟨ A' , refl ⟩ ⟩ 62 | funSrc' (` cfail G H x) (I-intmd ()) V 63 | 64 | prodSrc : ∀{A A' B'} 65 | → (c : Cast (A ⇒ (A' `× B'))) → (i : Inert c) 66 | → SimpleValue A 67 | → Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ `× A₂ 68 | prodSrc .(` (` _)) (I-intmd (I-gnd ())) v 69 | 70 | cfst : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `× A₂) ⇒ (A' `× B'))) → Inert c 71 | → Cast (A₁ ⇒ A') 72 | cfst .(` (` _)) (I-intmd (I-gnd ())) 73 | 74 | csnd : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `× A₂) ⇒ (A' `× B'))) → Inert c 75 | → Cast (A₂ ⇒ B') 76 | csnd .(` (` _)) (I-intmd (I-gnd ())) 77 | 78 | sumSrc : ∀{A A' B'} 79 | → (c : Cast (A ⇒ (A' `⊎ B'))) → (i : Inert c) 80 | → SimpleValue A 81 | → Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ `⊎ A₂ 82 | sumSrc .(` (` _)) (I-intmd (I-gnd ())) 83 | 84 | cinl : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `⊎ A₂) ⇒ (A' `⊎ B'))) → Inert c 85 | → Cast (A₁ ⇒ A') 86 | cinl .(` (` _)) (I-intmd (I-gnd ())) 87 | 88 | cinr : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `⊎ A₂) ⇒ (A' `⊎ B'))) → Inert c 89 | → Cast (A₂ ⇒ B') 90 | cinr .(` (` _)) (I-intmd (I-gnd ())) 91 | 92 | module Mach = AbsMach.Machine cast 93 | funSrc' dom cod 94 | prodSrc cfst csnd 95 | sumSrc cinl cinr 96 | compose baseNotInert 97 | 98 | -------------------------------------------------------------------------------- /InjProj/Precision.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | 3 | open import Agda.Primitive using (lzero) 4 | open import Data.List using (List; []; _∷_; length) 5 | open import Data.Nat 6 | open import Data.Nat.Induction 7 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 8 | open import Data.List using (map) 9 | open import Data.Nat.Properties 10 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 11 | open import Data.Unit.Polymorphic using (⊤; tt) 12 | open import Data.Vec using (Vec) renaming ([] to []̌; _∷_ to _∷̌_) 13 | open import Data.Empty using (⊥; ⊥-elim) 14 | open import Data.Sum using (_⊎_; inj₁; inj₂) 15 | open import Induction using (RecStruct) 16 | open import Induction.WellFounded as WF 17 | open import Data.Product.Relation.Binary.Lex.Strict 18 | using (×-Lex; ×-wellFounded; ×-preorder) 19 | open import Relation.Binary using (Rel) 20 | open import Relation.Binary.PropositionalEquality as Eq 21 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 22 | open Eq.≡-Reasoning 23 | open import Relation.Nullary using (¬_; Dec; yes; no) 24 | open import Sig 25 | open import Var 26 | 27 | open import InjProj.CastCalculus 28 | 29 | module InjProj.Precision where 30 | 31 | {----------------------- Type Precision ------------------------} 32 | 33 | infixr 6 _⊑_ 34 | data _⊑_ : Type → Type → Set where 35 | 36 | unk⊑unk : ★ ⊑ ★ 37 | 38 | unk⊑ : ∀{G}{B} 39 | → gnd⇒ty G ⊑ B 40 | ------------- 41 | → ★ ⊑ B 42 | 43 | base⊑ : ∀{ι} 44 | ---------- 45 | → $ₜ ι ⊑ $ₜ ι 46 | 47 | fun⊑ : ∀{A B C D} 48 | → A ⊑ C → B ⊑ D 49 | --------------- 50 | → A ⇒ B ⊑ C ⇒ D 51 | 52 | Refl⊑ : ∀{A} → A ⊑ A 53 | Refl⊑ {★} = unk⊑unk 54 | Refl⊑ {$ₜ ι} = base⊑ 55 | Refl⊑ {A ⇒ B} = fun⊑ Refl⊑ Refl⊑ 56 | 57 | Trans⊑ : ∀ {A B C} → A ⊑ B → B ⊑ C → A ⊑ C 58 | Trans⊑ unk⊑unk unk⊑unk = unk⊑unk 59 | Trans⊑ unk⊑unk (unk⊑ b) = unk⊑ b 60 | Trans⊑ (unk⊑ a) unk⊑unk = unk⊑unk 61 | Trans⊑ (unk⊑ a) (unk⊑ b) = unk⊑ b 62 | Trans⊑ (unk⊑ a) base⊑ = unk⊑ a 63 | Trans⊑ (unk⊑ a) (fun⊑ b b₁) = unk⊑ (Trans⊑ a (fun⊑ b b₁)) 64 | Trans⊑ base⊑ b = b 65 | Trans⊑ (fun⊑ a a₁) (fun⊑ b b₁) = fun⊑ (Trans⊑ a b) (Trans⊑ a₁ b₁) 66 | 67 | AntiSym⊑ : ∀ {A B} → A ⊑ B → B ⊑ A → A ≡ B 68 | AntiSym⊑ unk⊑unk unk⊑unk = refl 69 | AntiSym⊑ unk⊑unk (unk⊑ b) = refl 70 | AntiSym⊑ (unk⊑ a) unk⊑unk = refl 71 | AntiSym⊑ (unk⊑ a) (unk⊑ b) = refl 72 | AntiSym⊑ base⊑ base⊑ = refl 73 | AntiSym⊑ {A ⇒ B}{A' ⇒ B'} (fun⊑ a a₁) (fun⊑ b b₁) = 74 | cong₂ (_⇒_) (AntiSym⊑ a b) (AntiSym⊑ a₁ b₁) 75 | 76 | dyn-prec-unique : ∀{A} 77 | → (c : ★ ⊑ A) 78 | → (d : ★ ⊑ A) 79 | → c ≡ d 80 | dyn-prec-unique {★} unk⊑unk unk⊑unk = refl 81 | dyn-prec-unique {★} unk⊑unk (unk⊑ {$ᵍ ι} ()) 82 | dyn-prec-unique {★} unk⊑unk (unk⊑ {★⇒★} ()) 83 | dyn-prec-unique {★} (unk⊑ {$ᵍ ι} ()) d 84 | dyn-prec-unique {★} (unk⊑ {★⇒★} ()) d 85 | dyn-prec-unique {$ₜ ι} (unk⊑ {$ᵍ .ι} base⊑) (unk⊑ {$ᵍ .ι} base⊑) = refl 86 | dyn-prec-unique {A ⇒ A₁} (unk⊑ {★⇒★} (fun⊑ c c₁)) (unk⊑ {★⇒★} (fun⊑ d d₁)) 87 | with dyn-prec-unique c d | dyn-prec-unique c₁ d₁ 88 | ... | refl | refl = refl 89 | 90 | gnd-prec-unique : ∀{G A} 91 | → (c : gnd⇒ty G ⊑ A) 92 | → (d : gnd⇒ty G ⊑ A) 93 | → c ≡ d 94 | gnd-prec-unique {$ᵍ ι} {.($ₜ ι)} base⊑ base⊑ = refl 95 | gnd-prec-unique {★⇒★} {.(_ ⇒ _)} (fun⊑ c c₁) (fun⊑ d d₁) 96 | with dyn-prec-unique c d | dyn-prec-unique c₁ d₁ 97 | ... | refl | refl = refl 98 | 99 | unk⊑gnd-inv : ∀{G} 100 | → (c : ★ ⊑ gnd⇒ty G) 101 | → ∃[ d ] c ≡ unk⊑{G}{gnd⇒ty G} d 102 | unk⊑gnd-inv {$ᵍ ι} (unk⊑ {$ᵍ .ι} base⊑) = base⊑ , refl 103 | unk⊑gnd-inv {★⇒★} (unk⊑ {★⇒★} (fun⊑ c d)) = fun⊑ c d , refl 104 | 105 | {----------------------- Term Precision ------------------------} 106 | 107 | infix 3 _⊩_⊑_⦂_ 108 | 109 | Prec : Set 110 | Prec = (∃[ A ] ∃[ B ] A ⊑ B) 111 | 112 | data _⊩_⊑_⦂_ : List Prec → Term → Term → ∀{A B : Type} → A ⊑ B → Set 113 | 114 | data _⊩_⊑_⦂_ where 115 | 116 | ⊑-var : ∀ {Γ x A⊑B} 117 | → Γ ∋ x ⦂ A⊑B 118 | ------------------------------------- 119 | → Γ ⊩ (` x) ⊑ (` x) ⦂ proj₂ (proj₂ A⊑B) 120 | 121 | ⊑-lit : ∀ {Γ c} 122 | ----------------------------------- 123 | → Γ ⊩ ($ c) ⊑ ($ c) ⦂ base⊑{typeof c} 124 | 125 | ⊑-app : ∀{Γ L M L′ M′ A B C D}{c : A ⊑ C}{d : B ⊑ D} 126 | → Γ ⊩ L ⊑ L′ ⦂ fun⊑ c d 127 | → Γ ⊩ M ⊑ M′ ⦂ c 128 | ----------------------- 129 | → Γ ⊩ L · M ⊑ L′ · M′ ⦂ d 130 | 131 | ⊑-lam : ∀{Γ N N′ A B C D}{c : A ⊑ C}{d : B ⊑ D} 132 | → (A , C , c) ∷ Γ ⊩ N ⊑ N′ ⦂ d 133 | ---------------------------- 134 | → Γ ⊩ ƛ N ⊑ ƛ N′ ⦂ fun⊑ c d 135 | 136 | ⊑-inj-L : ∀{Γ M M′}{G B}{c : (gnd⇒ty G) ⊑ B} 137 | → Γ ⊩ M ⊑ M′ ⦂ c 138 | -------------------------------- 139 | → Γ ⊩ M ⟨ G !⟩ ⊑ M′ ⦂ unk⊑{G}{B} c 140 | 141 | ⊑-inj-R : ∀{Γ M M′}{G}{c : ★ ⊑ (gnd⇒ty G)} 142 | → Γ ⊩ M ⊑ M′ ⦂ c 143 | --------------------------- 144 | → Γ ⊩ M ⊑ M′ ⟨ G !⟩ ⦂ unk⊑unk 145 | 146 | ⊑-proj-L : ∀{Γ M M′ H B}{c : (gnd⇒ty H) ⊑ B} 147 | → Γ ⊩ M ⊑ M′ ⦂ unk⊑ c 148 | --------------------- 149 | → Γ ⊩ M ⟨ H ?⟩ ⊑ M′ ⦂ c 150 | 151 | ⊑-proj-R : ∀{Γ M M′ H}{c : ★ ⊑ (gnd⇒ty H)} 152 | → Γ ⊩ M ⊑ M′ ⦂ unk⊑unk 153 | --------------------- 154 | → Γ ⊩ M ⊑ M′ ⟨ H ?⟩ ⦂ c 155 | 156 | ⊑-blame : ∀{Γ M A} 157 | → map proj₁ Γ ⊢ M ⦂ A 158 | ------------------------ 159 | → Γ ⊩ M ⊑ blame ⦂ Refl⊑{A} 160 | 161 | -------------------------------------------------------------------------------- /Labels.agda: -------------------------------------------------------------------------------- 1 | module Labels where 2 | 3 | open import Data.Nat 4 | open import Relation.Nullary using (¬_; Dec; yes; no) 5 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; cong) 6 | 7 | data Label : Set where 8 | pos : ℕ → Label 9 | neg : ℕ → Label 10 | 11 | flip : Label → Label 12 | flip (pos ℓ) = (neg ℓ) 13 | flip (neg ℓ) = (pos ℓ) 14 | 15 | label→ℕ : Label → ℕ 16 | label→ℕ (pos ℓ) = ℓ 17 | label→ℕ (neg ℓ) = ℓ 18 | 19 | {- NOTE: 20 | Polarity-unaware blame label comparison. 21 | Positive and negative labels are considered the same as long as they have the same number. 22 | -} 23 | infix 10 _≡̂_ 24 | infix 10 _≢̂_ 25 | 26 | data _≡̂_ : Label → Label → Set where 27 | refl++ : ∀ {n} → pos n ≡̂ pos n 28 | refl+- : ∀ {n} → pos n ≡̂ neg n 29 | refl-+ : ∀ {n} → neg n ≡̂ pos n 30 | refl-- : ∀ {n} → neg n ≡̂ neg n 31 | 32 | _≢̂_ : Label → Label → Set 33 | ℓ₁ ≢̂ ℓ₂ = ¬ ℓ₁ ≡̂ ℓ₂ 34 | 35 | ≡̂-refl : ∀ {ℓ} → ℓ ≡̂ ℓ 36 | ≡̂-refl {pos n} = refl++ 37 | ≡̂-refl {neg n} = refl-- 38 | 39 | ≡→≡̂ : ∀ {ℓ₁ ℓ₂} → ℓ₁ ≡ ℓ₂ → ℓ₁ ≡̂ ℓ₂ 40 | ≡→≡̂ refl = ≡̂-refl 41 | 42 | ≢̂→≢̂flip : ∀ {ℓ₁ ℓ₂} → ℓ₁ ≢̂ ℓ₂ → ℓ₁ ≢̂ flip ℓ₂ 43 | ≢̂→≢̂flip {pos n₁} {pos .n₁} neq refl+- = neq refl++ 44 | ≢̂→≢̂flip {pos n₁} {neg .n₁} neq refl++ = neq refl+- 45 | ≢̂→≢̂flip {neg n₁} {pos .n₁} neq refl-- = neq refl-+ 46 | ≢̂→≢̂flip {neg n₁} {neg .n₁} neq refl-+ = neq refl-- 47 | 48 | -- ≡̂ implies labels are numbered the same. 49 | ≡̂-inv : ∀ {ℓ₁ ℓ₂} → ℓ₁ ≡̂ ℓ₂ → (label→ℕ ℓ₁) ≡ (label→ℕ ℓ₂) 50 | ≡̂-inv refl++ = refl 51 | ≡̂-inv refl+- = refl 52 | ≡̂-inv refl-+ = refl 53 | ≡̂-inv refl-- = refl 54 | 55 | label-eq? : ∀ (ℓ₁ ℓ₂ : Label) → Dec (ℓ₁ ≡ ℓ₂) 56 | label-eq? (pos x₁) (pos x₂) with x₁ ≟ x₂ 57 | ... | yes x₁≡x₂ = yes (cong pos x₁≡x₂) 58 | ... | no x₁≢x₂ = no λ { refl → x₁≢x₂ refl } 59 | label-eq? (pos _) (neg _) = no λ () 60 | label-eq? (neg _) (pos _) = no λ () 61 | label-eq? (neg x₁) (neg x₂) with x₁ ≟ x₂ 62 | ... | yes x₁≡x₂ = yes (cong neg x₁≡x₂) 63 | ... | no x₁≢x₂ = no λ { refl → x₁≢x₂ refl } 64 | -------------------------------------------------------------------------------- /LazyCoercionsABT.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | 3 | module LazyCoercionsABT where 4 | 5 | open import Data.Nat 6 | open import Types 7 | open import Variables 8 | open import Labels 9 | open import Relation.Nullary using (¬_; Dec; yes; no) 10 | open import Relation.Nullary.Negation using (contradiction) 11 | open import Data.Sum using (_⊎_; inj₁; inj₂) 12 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 13 | renaming (_,_ to ⟨_,_⟩) 14 | open import Relation.Binary.PropositionalEquality 15 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 16 | 17 | open import PreCastStructure 18 | open import LazyCoercions using (pcs; id; _??_; _!!; _↣_; _`×_; _`+_; ⊥_⟨_⟩_; coerce; ƛ_) public 19 | open PreCastStruct pcs public 20 | 21 | import ParamCastCalculusABT 22 | import ParamCastAuxABT 23 | open ParamCastCalculusABT pcs renaming (fst_ to first_; snd_ to second_; blame to mkblame) public 24 | open ParamCastAuxABT pcs public 25 | 26 | applyCast : ∀ {Γ A B} → (M : Term) → Γ ⊢ M ⦂ A → (Value M) → (c : Cast (A ⇒ B)) 27 | → ∀ {a : Active c} → Term 28 | applyCast M Γ⊢M∶A v id {a} = M 29 | applyCast M Γ⊢M∶A v (B ?? ℓ) {a} with canonical⋆ Γ⊢M∶A v 30 | ... | ⟨ A' , ⟨ M' , ⟨ c , ⟨ _ , ⟨ q , refl ⟩ ⟩ ⟩ ⟩ ⟩ = M' ⟨ coerce A' B ℓ ⟩ 31 | applyCast {A = A ⇒ B} {B = A' ⇒ B'} M Γ⊢M∶A v (c ↣ d) {a} = 32 | ƛ A' ˙ ((rename suc M · ((` zero) ⟨ c ⟩)) ⟨ d ⟩) 33 | applyCast M Γ⊢M∶A v (c `× d) {a} = 34 | ⟦ first M ⟨ c ⟩ , second M ⟨ d ⟩ ⟧ 35 | applyCast {A = A `⊎ B} {B = A' `⊎ B'} M Γ⊢M∶A v (c `+ d) {a} = 36 | let L = inl ((` zero) ⟨ c ⟩) other B' in 37 | let R = inr ((` zero) ⟨ d ⟩) other A' in 38 | case M of A ⇒ L ∣ B ⇒ R 39 | applyCast M Γ⊢M∶A v (⊥ A ⟨ ℓ ⟩ B) {a} = mkblame B ℓ 40 | 41 | 42 | applyCast-wt : ∀ {Γ A B} {V : Term} {c : Cast (A ⇒ B)} 43 | → (⊢V : Γ ⊢ V ⦂ A) 44 | → (v : Value V) → (a : Active c) 45 | -------------------------------- 46 | → Γ ⊢ applyCast V ⊢V v c {a} ⦂ B 47 | applyCast-wt = {! !} 48 | 49 | open import CastStructureABT 50 | 51 | cs : CastStruct 52 | cs = record { precast = pcs 53 | ; applyCast = applyCast 54 | ; applyCast-wt = applyCast-wt } 55 | 56 | 57 | open import ParamCastReductionABT cs public 58 | 59 | {- 60 | open import ParamCastDeterministic cs public 61 | 62 | import GTLC2CC 63 | open GTLC2CC Cast Inert (λ A B ℓ {c} → coerce A B ℓ) public 64 | 65 | -} -------------------------------------------------------------------------------- /LogRel/BindLemma.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRel.BindLemma where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Nat 6 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 7 | open import Data.Nat.Properties 8 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 9 | open import Data.Unit using (⊤; tt) 10 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | open import Data.Sum using (_⊎_; inj₁; inj₂) 13 | open import Relation.Binary.PropositionalEquality as Eq 14 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 15 | open import Relation.Nullary using (¬_; Dec; yes; no) 16 | open import Var 17 | open import InjProj.CastCalculus 18 | open import InjProj.Precision 19 | open import InjProj.CastDeterministic 20 | open import StepIndexedLogic 21 | open import InjProj.CastSafe 22 | open import LogRel.LogRel 23 | 24 | bind-premise : Dir → PEFrame → PEFrame → Term → Term → ℕ 25 | → ∀ {B}{B′}(c : B ⊑ B′) → ∀ {A}{A′} (d : A ⊑ A′) → Set 26 | bind-premise dir F F′ M M′ i c d = 27 | (∀ j V V′ → j ≤ i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 28 | → # (dir ∣ V ⊑ᴸᴿᵥ V′ ⦂ d) j 29 | → # (dir ∣ (F ⦉ V ⦊) ⊑ᴸᴿₜ (F′ ⦉ V′ ⦊) ⦂ c) j) 30 | 31 | LRᵥ→LRₜ-down-one-≼ : ∀{B}{B′}{c : B ⊑ B′}{A}{A′}{d : A ⊑ A′} 32 | {F}{F′}{i}{M}{N}{M′} 33 | → M —→ N 34 | → (bind-premise ≼ F F′ M M′ (suc i) c d) 35 | → (bind-premise ≼ F F′ N M′ i c d) 36 | LRᵥ→LRₜ-down-one-≼ {B}{B′}{c}{A}{A′}{d}{F}{F′}{i}{M}{N}{M′} M→N LRᵥ→LRₜsi 37 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 38 | LRᵥ→LRₜsi j V V′ (≤-trans j≤i (n≤1+n i)) (M —→⟨ M→N ⟩ M→V) v M′→V′ v′ 𝒱j 39 | 40 | LRᵥ→LRₜ-down-one-≽ : ∀{B}{B′}{c : B ⊑ B′}{A}{A′}{d : A ⊑ A′} 41 | {F}{F′}{i}{M}{M′}{N′} 42 | → M′ —→ N′ 43 | → (bind-premise ≽ F F′ M M′ (suc i) c d) 44 | → (bind-premise ≽ F F′ M N′ i c d) 45 | LRᵥ→LRₜ-down-one-≽ {B}{B′}{c}{A}{A′}{d}{F}{F′}{i}{M}{N}{M′} M′→N′ LRᵥ→LRₜsi 46 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 47 | LRᵥ→LRₜsi j V V′ (≤-trans j≤i (n≤1+n i)) M→V v (N —→⟨ M′→N′ ⟩ M′→V′) v′ 𝒱j 48 | 49 | LRₜ-bind : ∀{B}{B′}{c : B ⊑ B′}{A}{A′}{d : A ⊑ A′} 50 | {F}{F′}{M}{M′}{i}{dir} 51 | → #(dir ∣ M ⊑ᴸᴿₜ M′ ⦂ d) i 52 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 53 | → #(dir ∣ V ⊑ᴸᴿᵥ V′ ⦂ d) j 54 | → #(dir ∣ (F ⦉ V ⦊) ⊑ᴸᴿₜ (F′ ⦉ V′ ⦊) ⦂ c) j) 55 | → #(dir ∣ (F ⦉ M ⦊) ⊑ᴸᴿₜ (F′ ⦉ M′ ⦊) ⦂ c) i 56 | LRₜ-bind {B}{B′}{c}{A}{A′}{d}{F} {F′} {M} {M′} {zero} {dir} ℰMM′sz LRᵥ→LRₜj = 57 | tz (dir ∣ (F ⦉ M ⦊) ⊑ᴸᴿₜ (F′ ⦉ M′ ⦊) ⦂ c) 58 | LRₜ-bind {B}{B′}{c}{A}{A′}{d}{F}{F′}{M}{M′}{suc i}{≼} ℰMM′si LRᵥ→LRₜj 59 | with ⇔-to (LRₜ-suc{dir = ≼}) ℰMM′si 60 | ... | inj₁ (N , M→N , ▷ℰNM′) = 61 | let IH = LRₜ-bind{c = c}{d = d}{F}{F′}{N}{M′}{i}{≼} ▷ℰNM′ 62 | (LRᵥ→LRₜ-down-one-≼{c = c}{d = d}{F}{F′}{i}{M}{N}{M′} 63 | M→N LRᵥ→LRₜj) in 64 | ⇔-fro (LRₜ-suc{dir = ≼}) (inj₁ ((F ⦉ N ⦊) , ξ′ F refl refl M→N , IH)) 65 | LRₜ-bind {B}{B′}{c}{A}{A′}{d}{F}{F′}{M}{M′}{suc i}{≼} ℰMM′si LRᵥ→LRₜj 66 | | inj₂ (inj₂ (m , (V′ , M′→V′ , v′ , 𝒱MV′))) = 67 | let ℰFMF′V′ = LRᵥ→LRₜj (suc i) M V′ ≤-refl (M END) m M′→V′ v′ 𝒱MV′ in 68 | anti-reduction-≼-R ℰFMF′V′ (ξ′* F′ M′→V′) 69 | LRₜ-bind {B}{B′}{c}{A}{A′}{d}{F}{F′}{M}{M′}{suc i}{≼} ℰMM′si LRᵥ→LRₜj 70 | | inj₂ (inj₁ M′→blame) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 71 | LRₜ-bind {B}{B′}{c}{A}{A′}{d}{F}{F′}{M}{M′}{suc i}{≽} ℰMM′si LRᵥ→LRₜj 72 | with ⇔-to (LRₜ-suc{dir = ≽}) ℰMM′si 73 | ... | inj₁ (N′ , M′→N′ , ▷ℰMN′) = 74 | let ℰFMFN′ : # (≽ ∣ (F ⦉ M ⦊) ⊑ᴸᴿₜ (F′ ⦉ N′ ⦊) ⦂ c) i 75 | ℰFMFN′ = LRₜ-bind{c = c}{d = d}{F}{F′}{M}{N′}{i}{≽} ▷ℰMN′ 76 | (LRᵥ→LRₜ-down-one-≽{c = c}{d = d}{F}{F′} M′→N′ LRᵥ→LRₜj) in 77 | inj₁ ((F′ ⦉ N′ ⦊) , (ξ′ F′ refl refl M′→N′) , ℰFMFN′) 78 | ... | inj₂ (inj₁ isBlame) 79 | with F′ 80 | ... | □ = inj₂ (inj₁ isBlame) 81 | ... | ` F″ = inj₁ (blame , ξ-blame F″ , LRₜ-blame-step{dir = ≽}) 82 | LRₜ-bind {B}{B′}{c}{A}{A′}{d}{F}{F′}{M}{M′}{suc i}{≽} ℰMM′si LRᵥ→LRₜj 83 | | inj₂ (inj₂ (m′ , V , M→V , v , 𝒱VM′)) = 84 | let xx = LRᵥ→LRₜj (suc i) V M′ ≤-refl M→V v (M′ END) m′ 𝒱VM′ in 85 | anti-reduction-≽-L xx (ξ′* F M→V) 86 | -------------------------------------------------------------------------------- /LogRel/GradualGuarantee.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRel.GradualGuarantee where 3 | 4 | {- 5 | 6 | This is a proof of the gradual guarantee using 7 | step-indexed logical relations by Jeremy Siek, Phil Wadler, and Peter 8 | Thiemann. 9 | 10 | The proof technique and definitions are a mixture of those used 11 | by Max New in his thesis (Chapter 10) and 12 | by Dreyer, Ahmed, and Birkedal in "Logical Step-Indexed Logical Relations". 13 | 14 | -} 15 | 16 | open import Data.List using (List; []; _∷_; length; map) 17 | open import Data.Nat 18 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 19 | open import Data.Nat.Properties 20 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 21 | open import Data.Unit using (⊤; tt) 22 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 23 | open import Data.Empty using (⊥; ⊥-elim) 24 | open import Data.Sum using (_⊎_; inj₁; inj₂) 25 | open import Relation.Binary.PropositionalEquality as Eq 26 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 27 | open import Relation.Nullary using (¬_; Dec; yes; no) 28 | open import Var 29 | open import InjProj.CastCalculus 30 | open import InjProj.Precision 31 | open import StepIndexedLogic 32 | open import LogRel.LogRel 33 | open import LogRel.CompatibilityLemmas 34 | 35 | fundamental : ∀ {Γ}{A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 36 | → Γ ⊩ M ⊑ M′ ⦂ A⊑A′ 37 | ---------------------------- 38 | → Γ ⊨ M ⊑ᴸᴿ M′ ⦂ (A , A′ , A⊑A′) 39 | fundamental {Γ} {A} {A′} {A⊑A′} .(` _) .(` _) (⊑-var ∋x) = 40 | compatibility-var ∋x 41 | fundamental {Γ} {_} {_} {base⊑} ($ c) ($ c) ⊑-lit = 42 | compatible-literal 43 | fundamental {Γ} {A} {A′} {A⊑A′} (L · M) (L′ · M′) (⊑-app ⊢L⊑L′ ⊢M⊑M′) = 44 | compatible-app{L = L}{L′}{M}{M′} (fundamental L L′ ⊢L⊑L′) 45 | (fundamental M M′ ⊢M⊑M′) 46 | fundamental {Γ} {.(_ ⇒ _)} {.(_ ⇒ _)} {.(fun⊑ _ _)} (ƛ N)(ƛ N′) (⊑-lam ⊢N⊑N′) = 47 | compatible-lambda{N = N}{N′} (fundamental N N′ ⊢N⊑N′) 48 | fundamental {Γ} {★} {A′} {unk⊑ c} (M ⟨ G !⟩) M′ (⊑-inj-L ⊢M⊑M′) = 49 | compatible-inj-L{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 50 | fundamental {Γ} {★} {★} {.unk⊑unk} M (M′ ⟨ G !⟩) (⊑-inj-R ⊢M⊑M′) = 51 | compatible-inj-R{Γ}{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 52 | fundamental {Γ} {_} {A′} {A⊑A′} (M ⟨ H ?⟩) M′ (⊑-proj-L ⊢M⊑M′) = 53 | compatible-proj-L{Γ}{H}{A′}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 54 | fundamental {Γ} {A} {.(gnd⇒ty _)} {A⊑A′} M (M′ ⟨ H′ ?⟩) (⊑-proj-R ⊢M⊑M′) = 55 | compatible-proj-R{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 56 | fundamental {Γ} {A} {.A} {.Refl⊑} M .blame (⊑-blame ⊢M∶A) = 57 | compatible-blame ⊢M∶A 58 | 59 | gradual-guarantee : ∀ {A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 60 | → [] ⊩ M ⊑ M′ ⦂ A⊑A′ 61 | --------------------------- 62 | → (M′ ⇓ → M ⇓) 63 | × (M′ ⇑ → M ⇑) 64 | × (M ⇓ → M′ ⇓ ⊎ M′ —↠ blame) 65 | × (M ⇑ → M′ ⇑⊎blame) 66 | × (M —↠ blame → M′ —↠ blame) 67 | gradual-guarantee {A}{A′}{A⊑A′} M M′ M⊑M′ = 68 | let (⊨≼M⊑ᴸᴿM′ , ⊨≽M⊑ᴸᴿM′) = fundamental M M′ M⊑M′ in 69 | LR⇒GG (⊨≼M⊑ᴸᴿM′ id id ,ᵒ ⊨≽M⊑ᴸᴿM′ id id) 70 | -------------------------------------------------------------------------------- /LogRel/Makefile: -------------------------------------------------------------------------------- 1 | 2 | main.pdf: 3 | agda --latex PeterCastCalculus.lagda 4 | agda --latex PeterPrecision.lagda 5 | agda --latex PeterLogRel.lagda 6 | agda --latex PeterFundamental.lagda 7 | agda --latex PeterGG.lagda 8 | cd latex/LogRel; /Library/TeX/texbin/pdflatex main; /Library/TeX/texbin/bibtex main 9 | cd latex/LogRel; /Library/TeX/texbin/pdflatex main; /Library/TeX/texbin/bibtex main 10 | cd latex/LogRel; /Library/TeX/texbin/pdflatex main; /Library/TeX/texbin/bibtex main 11 | -------------------------------------------------------------------------------- /LogRel/README.md: -------------------------------------------------------------------------------- 1 | 2 | This directory contains a proof of the gradual guarantee using 3 | step-indexed logical relations by Jeremy Siek, Phil Wadler, and Peter 4 | Thiemann. 5 | 6 | The proof technique and definitions are a mixture of those used 7 | by Max New in his thesis (Chapter 10) and 8 | by Dreyer, Ahmed, and Birkedal in "Logical Step-Indexed Logical Relations". 9 | -------------------------------------------------------------------------------- /LogRel/README.md~: -------------------------------------------------------------------------------- 1 | 2 | A proof of the gradual guarantee using step-indexed logical relations 3 | by Jeremy, Phil Wadler, and Peter Thiemann. 4 | 5 | The proof technique and definitions are a mixture of those used 6 | by Max New in his thesis (Chapter 10) and 7 | by Dreyer, Ahmed, and Birkedal in "Logical Step-Indexed Logical Relations". 8 | -------------------------------------------------------------------------------- /LogRel/extra/LogRel.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRel.extra.LogRel where 3 | 4 | {- 5 | 6 | Stuff that is true and might be handy in the future, but wasn't needed 7 | for the proof of the gradual guarantee. 8 | 9 | -} 10 | 11 | open import Data.List using (List; []; _∷_; length; map) 12 | open import Data.Nat 13 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 14 | open import Data.Nat.Properties 15 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 16 | open import Data.Unit using (⊤; tt) 17 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 18 | open import Data.Empty using (⊥; ⊥-elim) 19 | open import Data.Sum using (_⊎_; inj₁; inj₂) 20 | open import Relation.Binary.PropositionalEquality as Eq 21 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 22 | open import Relation.Nullary using (¬_; Dec; yes; no) 23 | open import Var 24 | open import InjProj.CastCalculus 25 | open import InjProj.CastDeterministic 26 | open import InjProj.Reduction 27 | open import InjProj.Precision 28 | open import StepIndexedLogic 29 | open import LogRel.LogRel 30 | 31 | 𝒱-dyn-any-≺ : ∀{V}{V′}{G}{A′}{d : gnd⇒ty G ⊑ A′} 32 | → 𝒱⟦ ★ , A′ , unk⊑{G}{A′} d ⟧ ≺ (V ⟨ G !⟩) V′ 33 | ≡ᵒ (Value V)ᵒ ×ᵒ (Value V′)ᵒ ×ᵒ ▷ᵒ (𝒱⟦ (gnd⇒ty G , A′ , d) ⟧ ≺ V V′) 34 | 𝒱-dyn-any-≺ {V}{V′}{G}{A′}{d} = 35 | 𝒱⟦ ★ , A′ , unk⊑ d ⟧ ≺ (V ⟨ G !⟩) V′ 36 | ⩦⟨ ≡ᵒ-refl refl ⟩ 37 | ℰ⊎𝒱 X 38 | ⩦⟨ fixpointᵒ pre-ℰ⊎𝒱 X ⟩ 39 | # (pre-ℰ⊎𝒱 X) (ℰ⊎𝒱 , ttᵖ) 40 | ⩦⟨ Goal ⟩ 41 | (Value V)ᵒ ×ᵒ (Value V′)ᵒ ×ᵒ ▷ᵒ (𝒱⟦ (gnd⇒ty G , A′ , d) ⟧ ≺ V V′) 42 | ∎ 43 | where 44 | X = inj₁ ((★ , A′ , unk⊑ d) , ≺ , (V ⟨ G !⟩) , V′) 45 | Goal : # (pre-ℰ⊎𝒱 X) (ℰ⊎𝒱 , ttᵖ) 46 | ≡ᵒ (Value V)ᵒ ×ᵒ (Value V′)ᵒ ×ᵒ ▷ᵒ (𝒱⟦ (gnd⇒ty G , A′ , d) ⟧ ≺ V V′) 47 | Goal 48 | with G ≡ᵍ G 49 | ... | yes refl = (≡ᵒ-refl refl) 50 | ... | no neq = ⊥-elim (neq refl) 51 | 52 | 𝒱-dyn-any-≻ : ∀{V}{V′}{G}{A′}{d : gnd⇒ty G ⊑ A′} 53 | → 𝒱⟦ ★ , A′ , unk⊑{G}{A′} d ⟧ ≻ (V ⟨ G !⟩) V′ 54 | ≡ᵒ (Value V)ᵒ ×ᵒ (Value V′)ᵒ ×ᵒ (𝒱⟦ (gnd⇒ty G , A′ , d) ⟧ ≻ V V′) 55 | 𝒱-dyn-any-≻ {V}{V′}{G}{A′}{d} = 56 | 𝒱⟦ ★ , A′ , unk⊑ d ⟧ ≻ (V ⟨ G !⟩) V′ 57 | ⩦⟨ ≡ᵒ-refl refl ⟩ 58 | ℰ⊎𝒱 X 59 | ⩦⟨ fixpointᵒ pre-ℰ⊎𝒱 X ⟩ 60 | # (pre-ℰ⊎𝒱 X) (ℰ⊎𝒱 , ttᵖ) 61 | ⩦⟨ Goal ⟩ 62 | (Value V)ᵒ ×ᵒ (Value V′)ᵒ ×ᵒ (𝒱⟦ (gnd⇒ty G , A′ , d) ⟧ ≻ V V′) 63 | ∎ 64 | where 65 | X = inj₁ ((★ , A′ , unk⊑ d) , ≻ , (V ⟨ G !⟩) , V′) 66 | Goal : # (pre-ℰ⊎𝒱 X) (ℰ⊎𝒱 , ttᵖ) 67 | ≡ᵒ (Value V)ᵒ ×ᵒ (Value V′)ᵒ ×ᵒ (𝒱⟦ (gnd⇒ty G , A′ , d) ⟧ ≻ V V′) 68 | Goal 69 | with G ≡ᵍ G 70 | ... | yes refl = cong-×ᵒ (≡ᵒ-refl refl) (cong-×ᵒ (≡ᵒ-refl refl) 71 | (≡ᵒ-sym (fixpointᵒ pre-ℰ⊎𝒱 72 | (inj₁ ((gnd⇒ty G , A′ , d) , ≻ , V , V′))))) 73 | ... | no neq = ⊥-elim (neq refl) 74 | 75 | reduction-≺ : ∀{c}{M}{N}{M′}{i} 76 | → #(ℰ⟦ c ⟧ ≺ M M′) (suc i) 77 | → (M→N : M —→ N) 78 | → #(ℰ⟦ c ⟧ ≺ N M′) i 79 | reduction-≺ {c} {M} {N} {M′} {zero} ℰMM′si M→N = tz (ℰ⟦ c ⟧ ≺ N M′) 80 | reduction-≺ {c} {M} {N} {M′} {suc i} ℰMM′ssi M→N 81 | with ℰMM′ssi 82 | ... | inj₁ (N₂ , M→N₂ , ▷ℰN₂M′) rewrite deterministic M→N M→N₂ = ▷ℰN₂M′ 83 | ... | inj₂ (inj₁ M′→blame) = 84 | inj₂ (inj₁ M′→blame) 85 | ... | inj₂ (inj₂ (m , _)) = 86 | ⊥-elim (value-irreducible m M→N) 87 | 88 | reduction*-≺ : ∀{c}{M}{N}{M′}{i} 89 | → (M→N : M —↠ N) 90 | → #(ℰ⟦ c ⟧ ≺ M M′) (len M→N + i) 91 | → #(ℰ⟦ c ⟧ ≺ N M′) i 92 | reduction*-≺ {c} {M} {.M} {M′} {i} (.M END) ℰMM′ = ℰMM′ 93 | reduction*-≺ {c} {M} {N} {M′} {i} (.M —→⟨ M→L ⟩ L→N) ℰMM′ = 94 | let ℰLM′ = reduction-≺ ℰMM′ M→L in 95 | reduction*-≺ L→N ℰLM′ 96 | 97 | reduction-≻ : ∀{c}{M}{N}{M′}{i} 98 | → #(ℰ⟦ c ⟧ ≻ M M′) (suc i) 99 | → (M→N : M —→ N) 100 | → #(ℰ⟦ c ⟧ ≻ N M′) i 101 | reduction-≻ {c} {M} {N} {M′} {zero} ℰMM′si M→N = tz (ℰ⟦ c ⟧ ≻ N M′) 102 | reduction-≻ {c} {M} {N} {M′} {suc i} ℰMM′si M→N 103 | with ℰMM′si 104 | ... | inj₁ (N′ , M′→N′ , ▷ℰMN′) = 105 | inj₁ (N′ , M′→N′ , reduction-≻ ▷ℰMN′ M→N) 106 | ... | inj₂ (inj₁ M′→blame) = inj₂ (inj₁ M′→blame) 107 | ... | inj₂ (inj₂ (m′ , V , (.V END) , v , 𝒱VM′)) = 108 | ⊥-elim (value-irreducible v M→N) 109 | ... | inj₂ (inj₂ (m′ , V , (.M —→⟨ M→M₁ ⟩ M₁→V) , v , 𝒱VM′)) 110 | with deterministic M→N M→M₁ 111 | ... | refl = 112 | let 𝒱VM′si = down (𝒱⟦ c ⟧ ≻ V M′) (suc (suc i)) 𝒱VM′ (suc i) (n≤1+n _) in 113 | inj₂ (inj₂ (m′ , V , M₁→V , v , 𝒱VM′si)) 114 | 115 | ℰ-reduction : ∀{c}{M}{N}{M′}{i}{dir} 116 | → #(ℰ⟦ c ⟧ dir M M′) (suc i) 117 | → (M→N : M —→ N) 118 | → #(ℰ⟦ c ⟧ dir N M′) i 119 | ℰ-reduction {c} {M} {N} {M′} {i} {≺} ℰMM′ M→N = reduction-≺ ℰMM′ M→N 120 | ℰ-reduction {c} {M} {N} {M′} {i} {≻} ℰMM′ M→N = reduction-≻ ℰMM′ M→N 121 | 122 | anti-reduction-≺ : ∀{c}{M}{N}{M′}{i} 123 | → #(ℰ⟦ c ⟧ ≺ N M′) i 124 | → (M→N : M —↠ N) 125 | → #(ℰ⟦ c ⟧ ≺ M M′) (len M→N + i) 126 | anti-reduction-≺ {c} {M} {.M} {M′} {i} ℰ≺NM′si (.M END) = ℰ≺NM′si 127 | anti-reduction-≺ {c} {M} {N} {M′} {i} ℰ≺NM′si (_—→⟨_⟩_ M {L}{N} M→L L→*N) = 128 | let IH : # (ℰ⟦ c ⟧ ≺ L M′) (len L→*N + i) 129 | IH = anti-reduction-≺ ℰ≺NM′si (L→*N) in 130 | inj₁ (L , M→L , IH) 131 | 132 | anti-reduction-≻ : ∀{c}{M}{M′}{N′}{i} 133 | → #(ℰ⟦ c ⟧ ≻ M N′) i 134 | → (M′→N′ : M′ —↠ N′) 135 | → #(ℰ⟦ c ⟧ ≻ M M′) (len M′→N′ + i) 136 | anti-reduction-≻ {c} {M} {M′} {.M′} {i} ℰ≻MN′ (.M′ END) = ℰ≻MN′ 137 | anti-reduction-≻ {c} {M} {M′}{N′} {i} ℰ≻MN′ (_—→⟨_⟩_ M′ {L′}{N′} M′→L′ L′→*N′)= 138 | let IH : # (ℰ⟦ c ⟧ ≻ M L′) (len L′→*N′ + i) 139 | IH = anti-reduction-≻ ℰ≻MN′ (L′→*N′) in 140 | inj₁ (L′ , M′→L′ , IH) 141 | -------------------------------------------------------------------------------- /LogRel/junk/CastBindDir.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRel.CastBindDir where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Nat 6 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 7 | open import Data.Nat.Properties 8 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 9 | open import Data.Unit using (⊤; tt) 10 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | open import Data.Sum using (_⊎_; inj₁; inj₂) 13 | open import Relation.Binary.PropositionalEquality as Eq 14 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 15 | open import Relation.Nullary using (¬_; Dec; yes; no) 16 | open import Var 17 | open import LogRel.Cast 18 | open import LogRel.CastDeterministic 19 | open import StepIndexedLogic 20 | open import LogRel.CastSafe 21 | open import LogRel.CastLogRelDir 22 | 23 | {- formulation of ℰ-bind with explicit step-indexing, a la Max New -} 24 | 25 | 𝒱→ℰ-down-one-≺ : ∀{c}{d}{F}{F′}{i}{M}{N}{M′} 26 | → M —→ N 27 | → (∀ j V V′ → j ≤ suc i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 28 | → # (𝒱⟦ d ⟧ ≺ V V′) j 29 | → # (ℰ⟦ c ⟧ ≺ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 30 | → (∀ j V V′ → j ≤ i → N —↠ V → Value V → M′ —↠ V′ → Value V′ 31 | → # (𝒱⟦ d ⟧ ≺ V V′) j 32 | → # (ℰ⟦ c ⟧ ≺ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 33 | 𝒱→ℰ-down-one-≺ {c}{d}{F}{F′}{i}{M}{N}{M′} M→N 𝒱→ℰsi 34 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 35 | 𝒱→ℰsi j V V′ (≤-trans j≤i (n≤1+n i)) (M —→⟨ M→N ⟩ M→V) v M′→V′ v′ 𝒱j 36 | 37 | 𝒱→ℰ-down-one-≻ : ∀{c}{d}{F}{F′}{i}{M}{M′}{N′} 38 | → M′ —→ N′ 39 | → (∀ j V V′ → j ≤ suc i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 40 | → # (𝒱⟦ d ⟧ ≻ V V′) j 41 | → # (ℰ⟦ c ⟧ ≻ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 42 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → N′ —↠ V′ → Value V′ 43 | → # (𝒱⟦ d ⟧ ≻ V V′) j 44 | → # (ℰ⟦ c ⟧ ≻ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 45 | 𝒱→ℰ-down-one-≻ {c}{d}{F}{F′}{i}{M}{N}{M′} M′→N′ 𝒱→ℰsi 46 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 47 | 𝒱→ℰsi j V V′ (≤-trans j≤i (n≤1+n i)) M→V v (N —→⟨ M′→N′ ⟩ M′→V′) v′ 𝒱j 48 | 49 | ℰ-bind-step : ∀{c}{d}{F}{F′}{M}{M′}{i}{dir} 50 | → #(ℰ⟦ d ⟧ dir M M′) i 51 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 52 | → #(𝒱⟦ d ⟧ dir V V′) j 53 | → #(ℰ⟦ c ⟧ dir (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 54 | → #(ℰ⟦ c ⟧ dir (F ⦉ M ⦊) (F′ ⦉ M′ ⦊)) i 55 | ℰ-bind-step {c}{d} {F} {F′} {M} {M′} {zero} {dir} ℰMM′sz 𝒱→ℰj = 56 | tz (ℰ⟦ c ⟧ dir (F ⦉ M ⦊) (F′ ⦉ M′ ⦊)) 57 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 58 | with ⇔-to (ℰ-suc{d}{≺}) ℰMM′si 59 | ... | inj₁ (N , M→N , ▷ℰNM′) = 60 | let IH = ℰ-bind-step{c}{d}{F}{F′}{N}{M′}{i}{≺} ▷ℰNM′ 61 | (𝒱→ℰ-down-one-≺{c}{d}{F}{F′}{i}{M}{N}{M′} M→N 𝒱→ℰj) in 62 | ⇔-fro (ℰ-suc{c}{≺}) (inj₁ ((F ⦉ N ⦊) , ξ′ F refl refl M→N , IH)) 63 | ... | inj₂ (inj₂ (m , inj₁ M′→blame)) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 64 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 65 | | inj₂ (inj₂ (m , inj₂ (V′ , M′→V′ , v′ , 𝒱MV′))) = 66 | let ℰFMF′V′ = 𝒱→ℰj (suc i) M V′ ≤-refl (M END) m M′→V′ v′ 𝒱MV′ in 67 | anti-reduction-≺-R ℰFMF′V′ (ξ′* F′ M′→V′) 68 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 69 | | inj₂ (inj₁ M′→blame) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 70 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≻} ℰMM′si 𝒱→ℰj 71 | with ⇔-to (ℰ-suc{d}{≻}) ℰMM′si 72 | ... | inj₁ (N′ , M′→N′ , ▷ℰMN′) = 73 | let ℰFMFN′ : # (ℰ⟦ c ⟧ ≻ (F ⦉ M ⦊) (F′ ⦉ N′ ⦊)) i 74 | ℰFMFN′ = ℰ-bind-step{c}{d}{F}{F′}{M}{N′}{i}{≻} ▷ℰMN′ 75 | (𝒱→ℰ-down-one-≻{c}{d}{F}{F′} M′→N′ 𝒱→ℰj) in 76 | inj₁ ((F′ ⦉ N′ ⦊) , (ξ′ F′ refl refl M′→N′) , ℰFMFN′) 77 | ... | inj₂ (inj₁ isBlame) 78 | with F′ 79 | ... | □ = inj₂ (inj₁ isBlame) 80 | ... | ` F″ = inj₁ (blame , ξ-blame F″ , ℰ-blame-step{c}{≻}) 81 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≻} ℰMM′si 𝒱→ℰj 82 | | inj₂ (inj₂ (m′ , V , M→V , v , 𝒱VM′)) = 83 | let xx = 𝒱→ℰj (suc i) V M′ ≤-refl M→V v (M′ END) m′ 𝒱VM′ in 84 | anti-reduction-≻-L xx (ξ′* F M→V) 85 | -------------------------------------------------------------------------------- /LogRel/junk/CastFundamental.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRel.CastFundamental where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Nat 6 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 7 | open import Data.Nat.Properties 8 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 9 | open import Data.Unit using (⊤; tt) 10 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | open import Data.Sum using (_⊎_; inj₁; inj₂) 13 | open import Relation.Binary.PropositionalEquality as Eq 14 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 15 | open import Relation.Nullary using (¬_; Dec; yes; no) 16 | open import Var 17 | open import LogRel.Cast 18 | open import StepIndexedLogic 19 | open import LogRel.CastLogRel 20 | open import LogRel.CastCompatibility 21 | 22 | fundamental : ∀ {Γ}{A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 23 | → Γ ⊩ M ⊑ M′ ⦂ A⊑A′ 24 | ---------------------------- 25 | → Γ ⊨ M ⊑ M′ ⦂ (A , A′ , A⊑A′) 26 | fundamental {Γ} {A} {A′} {A⊑A′} .(` _) .(` _) (⊑-var ∋x) = 27 | compatibility-var ∋x 28 | fundamental {Γ} {_} {_} {base⊑} ($ (Num n)) ($ (Num n)) ⊑-lit = 29 | compatible-nat 30 | fundamental {Γ} {_} {_} {base⊑} ($ (Bool b)) ($ (Bool b)) ⊑-lit = 31 | compatible-bool 32 | fundamental {Γ} {A} {A′} {A⊑A′} (L · M) (L′ · M′) (⊑-app ⊢L⊑L′ ⊢M⊑M′) = 33 | compatible-app{L = L}{L′}{M}{M′} (fundamental L L′ ⊢L⊑L′) 34 | (fundamental M M′ ⊢M⊑M′) 35 | fundamental {Γ} {.(_ ⇒ _)} {.(_ ⇒ _)} {.(fun⊑ _ _)} (ƛ N)(ƛ N′) (⊑-lam ⊢N⊑N′) = 36 | compatible-lambda{N = N}{N′} (fundamental N N′ ⊢N⊑N′) 37 | fundamental {Γ} {★} {A′} {unk⊑} (M ⟨ G !⟩) M′ (⊑-inj-L ⊢M⊑M′) = 38 | compatible-inj-L{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 39 | fundamental {Γ} {★} {★} {.unk⊑} M (M′ ⟨ G !⟩) (⊑-inj-R ⊢M⊑M′) = 40 | compatible-inj-R{Γ}{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 41 | fundamental {Γ} {_} {A′} {A⊑A′} (M ⟨ H ?⟩) M′ (⊑-proj-L ⊢M⊑M′) = 42 | compatible-proj-L{Γ}{H}{A′}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 43 | fundamental {Γ} {A} {.(gnd⇒ty _)} {A⊑A′} M (M′ ⟨ H′ ?⟩) (⊑-proj-R ⊢M⊑M′) = 44 | compatible-proj-R{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 45 | fundamental {Γ} {A} {.A} {.Refl⊑} M .blame (⊑-blame ⊢M∶A) = 46 | compatible-blame ⊢M∶A 47 | 48 | -------------------------------------------------------------------------------- /LogRel/junk/CastGradualGuarantee.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRel.CastGradualGuarantee where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Nat 6 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 7 | open import Data.Nat.Properties 8 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 9 | open import Data.Unit using (⊤; tt) 10 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | open import Data.Sum using (_⊎_; inj₁; inj₂) 13 | open import Relation.Binary.PropositionalEquality as Eq 14 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 15 | open import Relation.Nullary using (¬_; Dec; yes; no) 16 | open import Var 17 | open import LogRel.Cast 18 | open import LogRel.CastDeterministic 19 | open import StepIndexedLogic 20 | open import LogRel.CastLogRel 21 | 22 | {- 23 | Analogous to sem-type-safety. 24 | 25 | Think of this as expanding the ℰ relation by adding 26 | reductions into ℰ using preserve-L and preserve-R. 27 | -} 28 | 29 | ℰ-steps : ∀{c : Prec} 30 | (k : ℕ) 31 | → (M M′ : Term) 32 | → #(ℰ⟦ c ⟧ M M′) (suc k) 33 | → (∃[ V ] ∃[ V′ ] Σ[ M→V ∈ M —↠ V ] Σ[ M′→V′ ∈ M′ —↠ V′ ] 34 | (len M→V + len M′→V′ ≤ k) × ∃[ m ] #(𝒱⟦ c ⟧ V V′) (suc m)) 35 | ⊎ (M′ —↠ blame) 36 | ⊎ (∃[ N ] ∃[ N′ ] Σ[ M→N ∈ M —↠ N ] Σ[ M′→N′ ∈ M′ —↠ N′ ] 37 | {- TODO: reducible N × reducible N′ × -} 38 | len M→N + len M′→N′ ≡ k) 39 | ℰ-steps {c} zero M M′ ℰMM′sk 40 | with ⇔-to (ℰ-suc{c}{k = 0}) ℰMM′sk 41 | ... | inj₁ 𝒱MM′ = 42 | inj₁ (M , M′ , (M END) , (M′ END) , ≤-refl , zero , 𝒱MM′ ) 43 | ... | inj₂ (inj₁ ((N , M→N) , presL)) = 44 | inj₂ (inj₂ (M , M′ , (M END) , (M′ END) , refl)) 45 | ... | inj₂ (inj₂ (inj₁ ((N′ , M′→N′) , presR))) = 46 | inj₂ (inj₂ (M , M′ , (M END) , (M′ END) , refl)) 47 | ... | inj₂ (inj₂ (inj₂ isBlame)) = 48 | inj₂ (inj₁ (blame END)) 49 | ℰ-steps {c} (suc k) M M′ ℰMM′sk 50 | with ⇔-to (ℰ-suc{c}{k = suc k}) ℰMM′sk 51 | ... | inj₁ 𝒱MM′ = 52 | inj₁ (M , M′ , (M END) , (M′ END) , z≤n , suc k , 𝒱MM′) 53 | ... | inj₂ (inj₂ (inj₂ isBlame)) = 54 | inj₂ (inj₁ (blame END)) 55 | ... | inj₂ (inj₁ ((N , M→N) , presL)) 56 | with ℰ-steps k N M′ (presL N (suc (suc k)) ≤-refl M→N) 57 | ... | inj₁ (V , V′ , N→V , M′→V′ , lt , m , 𝒱VV′) = 58 | inj₁ (V , V′ , (M —→⟨ M→N ⟩ N→V) , M′→V′ , s≤s lt , m , 𝒱VV′) 59 | ... | inj₂ (inj₁ M′→blame) = inj₂ (inj₁ M′→blame) 60 | ... | inj₂ (inj₂ (L , L′ , N→L , M′→L′ , eq)) = 61 | inj₂ (inj₂ (L , L′ , (M —→⟨ M→N ⟩ N→L) , M′→L′ , cong suc eq)) 62 | ℰ-steps {c} (suc k) M M′ ℰMM′sk 63 | | inj₂ (inj₂ (inj₁ ((N′ , M′→N′) , presR))) 64 | with ℰ-steps k M N′ (presR N′ (suc (suc k)) ≤-refl M′→N′) 65 | ... | inj₁ (V , V′ , M→V , N′→V′ , lt , m , 𝒱VV′) = 66 | inj₁ (V , V′ , M→V , (M′ —→⟨ M′→N′ ⟩ N′→V′) , LT , m , 𝒱VV′) 67 | where 68 | LT : len M→V + suc (len N′→V′) ≤ suc k 69 | LT = ≤-trans (≤-reflexive (+-suc (len M→V) (len N′→V′))) (s≤s lt) 70 | ... | inj₂ (inj₁ N′→blame) = inj₂ (inj₁ (M′ —→⟨ M′→N′ ⟩ N′→blame)) 71 | ... | inj₂ (inj₂ (L , L′ , M→L , N′→L , refl)) = 72 | inj₂ (inj₂ (L , L′ , M→L , (M′ —→⟨ M′→N′ ⟩ N′→L) , 73 | +-suc (len M→L) (len N′→L) )) 74 | 75 | 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /LogRel/junk/CastPrec.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | 3 | open import Agda.Primitive using (lzero) 4 | open import Data.List using (List; []; _∷_; length) 5 | open import Data.Nat 6 | open import Data.Nat.Induction 7 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 8 | open import Data.List using (map) 9 | open import Data.Nat.Properties 10 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 11 | open import Data.Unit.Polymorphic using (⊤; tt) 12 | open import Data.Vec using (Vec) renaming ([] to []̌; _∷_ to _∷̌_) 13 | open import Data.Empty using (⊥; ⊥-elim) 14 | open import Data.Sum using (_⊎_; inj₁; inj₂) 15 | open import Induction using (RecStruct) 16 | open import Induction.WellFounded as WF 17 | open import Data.Product.Relation.Binary.Lex.Strict 18 | using (×-Lex; ×-wellFounded; ×-preorder) 19 | open import Relation.Binary using (Rel) 20 | open import Relation.Binary.PropositionalEquality as Eq 21 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 22 | open Eq.≡-Reasoning 23 | open import Relation.Nullary using (¬_; Dec; yes; no) 24 | open import Sig 25 | open import Var 26 | 27 | open import LogRel.Cast 28 | 29 | module LogRel.CastPrec where 30 | 31 | {----------------------- Type Precision ------------------------} 32 | 33 | infixr 6 _⊑_ 34 | data _⊑_ : Type → Type → Set where 35 | 36 | unk⊑ : ∀{B} → ★ ⊑ B 37 | 38 | base⊑ : ∀{ι} → $ₜ ι ⊑ $ₜ ι 39 | 40 | fun⊑ : ∀{A B C D} 41 | → A ⊑ C 42 | → B ⊑ D 43 | → A ⇒ B ⊑ C ⇒ D 44 | 45 | Refl⊑ : ∀{A} → A ⊑ A 46 | Refl⊑ {★} = unk⊑ 47 | Refl⊑ {$ₜ ι} = base⊑ 48 | Refl⊑ {A ⇒ B} = fun⊑ Refl⊑ Refl⊑ 49 | 50 | Trans⊑ : ∀ {A B C} → A ⊑ B → B ⊑ C → A ⊑ C 51 | Trans⊑ unk⊑ b = unk⊑ 52 | Trans⊑ base⊑ b = b 53 | Trans⊑ (fun⊑ a a₁) (fun⊑ b b₁) = fun⊑ (Trans⊑ a b) (Trans⊑ a₁ b₁) 54 | 55 | AntiSym⊑ : ∀ {A B} → A ⊑ B → B ⊑ A → A ≡ B 56 | AntiSym⊑ unk⊑ unk⊑ = refl 57 | AntiSym⊑ base⊑ base⊑ = refl 58 | AntiSym⊑ {A ⇒ B}{A' ⇒ B'} (fun⊑ a a₁) (fun⊑ b b₁) = 59 | cong₂ (_⇒_) (AntiSym⊑ a b) (AntiSym⊑ a₁ b₁) 60 | 61 | {----------------------- Term Precision ------------------------} 62 | 63 | infix 3 _⊩_⊑_⦂_ 64 | 65 | Prec : Set 66 | Prec = (∃[ A ] ∃[ B ] A ⊑ B) 67 | 68 | data _⊩_⊑_⦂_ : List Prec → Term → Term → ∀{A B : Type} → A ⊑ B → Set 69 | 70 | data _⊩_⊑_⦂_ where 71 | 72 | ⊑-var : ∀ {Γ x A⊑B} 73 | → Γ ∋ x ⦂ A⊑B 74 | ------------------------------------- 75 | → Γ ⊩ (` x) ⊑ (` x) ⦂ proj₂ (proj₂ A⊑B) 76 | 77 | ⊑-lit : ∀ {Γ c} 78 | ----------------------------------- 79 | → Γ ⊩ ($ c) ⊑ ($ c) ⦂ base⊑{typeof c} 80 | 81 | ⊑-app : ∀{Γ L M L′ M′ A B C D}{c : A ⊑ C}{d : B ⊑ D} 82 | → Γ ⊩ L ⊑ L′ ⦂ fun⊑ c d 83 | → Γ ⊩ M ⊑ M′ ⦂ c 84 | ----------------------- 85 | → Γ ⊩ L · M ⊑ L′ · M′ ⦂ d 86 | 87 | ⊑-lam : ∀{Γ N N′ A B C D}{c : A ⊑ C}{d : B ⊑ D} 88 | → (A , C , c) ∷ Γ ⊩ N ⊑ N′ ⦂ d 89 | ---------------------------- 90 | → Γ ⊩ ƛ N ⊑ ƛ N′ ⦂ fun⊑ c d 91 | 92 | ⊑-inj-L : ∀{Γ M M′}{G B}{c : (gnd⇒ty G) ⊑ B} 93 | → Γ ⊩ M ⊑ M′ ⦂ c 94 | --------------------------- 95 | → Γ ⊩ M ⟨ G !⟩ ⊑ M′ ⦂ unk⊑{B} 96 | 97 | ⊑-inj-R : ∀{Γ M M′}{G}{c : ★ ⊑ (gnd⇒ty G)} 98 | → Γ ⊩ M ⊑ M′ ⦂ c 99 | --------------------------- 100 | → Γ ⊩ M ⊑ M′ ⟨ G !⟩ ⦂ unk⊑{★} 101 | 102 | ⊑-proj-L : ∀{Γ M M′ H B}{c : (gnd⇒ty H) ⊑ B} 103 | → Γ ⊩ M ⊑ M′ ⦂ unk⊑{B} 104 | --------------------- 105 | → Γ ⊩ M ⟨ H ?⟩ ⊑ M′ ⦂ c 106 | 107 | ⊑-proj-R : ∀{Γ M M′ H}{c : ★ ⊑ (gnd⇒ty H)} 108 | → Γ ⊩ M ⊑ M′ ⦂ unk⊑{★} 109 | --------------------- 110 | → Γ ⊩ M ⊑ M′ ⟨ H ?⟩ ⦂ c 111 | 112 | ⊑-blame : ∀{Γ M A} 113 | → map proj₁ Γ ⊢ M ⦂ A 114 | ------------------------ 115 | → Γ ⊩ M ⊑ blame ⦂ Refl⊑{A} 116 | 117 | -------------------------------------------------------------------------------- /MakeCastCalculus.agda: -------------------------------------------------------------------------------- 1 | open import CastStructure 2 | import ParamCastCalculus 3 | import ParamCastAux 4 | import ParamCastReduction 5 | 6 | module MakeCastCalculus (C : CastStruct) where 7 | open CastStruct C 8 | open ParamCastCalculus Cast public 9 | open ParamCastAux precast public 10 | open ParamCastReduction C public 11 | 12 | 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | %.agdai: %.agda 3 | /usr/bin/env agda $< 4 | 5 | AGDA = Labels.agda Types.agda Variables.agda \ 6 | GTLC.agda GTLC2CC.agda \ 7 | PreCastStructure.agda CastStructure.agda \ 8 | ParamCastCalculus.agda ParamCastReduction.agda ParamCastDeterministic.agda \ 9 | Subtyping.agda CastStructureWithBlameSafety.agda ParamCastSubtyping.agda ParamBlameSubtyping.agda \ 10 | ParamCCPrecision.agda ParamGradualGuaranteeAux.agda ParamGradualGuaranteeSim.agda ParamGradualGuarantee.agda \ 11 | GroundCast.agda GroundCastBlame.agda GroundCastGG.agda \ 12 | GroundInertX.agda GroundInertXBlame.agda GroundInertXGG.agda \ 13 | GroundCoercions.agda GroundCoercionsBlame.agda \ 14 | SimpleCast.agda SimpleCastBlame.agda \ 15 | SimpleFunCast.agda SimpleFunCastBlame.agda \ 16 | SimpleCoercions.agda SimpleCoercionsBlame.agda \ 17 | LazyCast.agda LazyCastBlame.agda \ 18 | LazyCoercions.agda LazyCoercionsBlame.agda \ 19 | EfficientParamCasts.agda SpaceEfficient.agda PreserveHeight.agda \ 20 | EfficientGroundCoercions.agda \ 21 | HyperCoercions.agda 22 | 23 | AGDAI = $(AGDA:%.agda=%.agdai) 24 | 25 | all: ${AGDA} ${AGDAI} 26 | 27 | clean: 28 | rm -f *.agdai *~ 29 | -------------------------------------------------------------------------------- /ParamCCPrecision.agda: -------------------------------------------------------------------------------- 1 | open import Relation.Nullary using (¬_; Dec; yes; no) 2 | open import Relation.Binary.PropositionalEquality 3 | using (_≡_; _≢_; refl) 4 | open import Data.Product using (_×_; proj₁; proj₂; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩) 5 | 6 | open import Types 7 | open import Variables 8 | open import Labels 9 | open import PreCastStructureWithPrecision 10 | 11 | 12 | 13 | module ParamCCPrecision (pcsp : PreCastStructWithPrecision) where 14 | 15 | open PreCastStructWithPrecision pcsp 16 | 17 | open import ParamCastCalculus Cast Inert 18 | 19 | {- The precision relation for the cast calculus. -} 20 | infix 6 _,_⊢_⊑ᶜ_ 21 | {- The precision relation for substitution. -} 22 | infix 6 _,_,_,_⊢_⊑ˢ_ 23 | 24 | -- Term precision of CC. 25 | data _,_⊢_⊑ᶜ_ : ∀ (Γ Γ′ : Context) → {A A′ : Type} → Γ ⊢ A → Γ′ ⊢ A′ → Set where 26 | 27 | ⊑ᶜ-prim : ∀ {Γ Γ′ A} {k : rep A} {i : Prim A} 28 | ------------------------------ 29 | → Γ , Γ′ ⊢ $_ {Γ} k {i} ⊑ᶜ $_ {Γ′} k {i} 30 | 31 | ⊑ᶜ-var : ∀ {Γ Γ′ A A′} {x : Γ ∋ A} {x′ : Γ′ ∋ A′} 32 | → ∋→ℕ x ≡ ∋→ℕ x′ 33 | ----------------- 34 | → Γ , Γ′ ⊢ ` x ⊑ᶜ ` x′ 35 | 36 | ⊑ᶜ-ƛ : ∀ {Γ Γ′ A A′ B B′} {N : Γ , A ⊢ B} {N′ : Γ′ , A′ ⊢ B′} 37 | → A ⊑ A′ 38 | → (Γ , A) , (Γ′ , A′) ⊢ N ⊑ᶜ N′ 39 | ------------------------------ 40 | → Γ , Γ′ ⊢ ƛ N ⊑ᶜ ƛ N′ 41 | 42 | ⊑ᶜ-· : ∀ {Γ Γ′ A A′ B B′} {L : Γ ⊢ A ⇒ B} {L′ : Γ′ ⊢ A′ ⇒ B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} 43 | → Γ , Γ′ ⊢ L ⊑ᶜ L′ 44 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 45 | -------------------------- 46 | → Γ , Γ′ ⊢ L · M ⊑ᶜ L′ · M′ 47 | 48 | ⊑ᶜ-if : ∀ {Γ Γ′ A A′} {L : Γ ⊢ ` 𝔹} {L′ : Γ′ ⊢ ` 𝔹} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} {N : Γ ⊢ A} {N′ : Γ′ ⊢ A′} 49 | → Γ , Γ′ ⊢ L ⊑ᶜ L′ 50 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 51 | → Γ , Γ′ ⊢ N ⊑ᶜ N′ 52 | --------------------------------- 53 | → Γ , Γ′ ⊢ if L M N ⊑ᶜ if L′ M′ N′ 54 | 55 | ⊑ᶜ-cons : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} {N : Γ ⊢ B} {N′ : Γ′ ⊢ B′} 56 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 57 | → Γ , Γ′ ⊢ N ⊑ᶜ N′ 58 | -------------------------------- 59 | → Γ , Γ′ ⊢ cons M N ⊑ᶜ cons M′ N′ 60 | 61 | ⊑ᶜ-fst : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ A `× B} {M′ : Γ′ ⊢ A′ `× B′} 62 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 63 | ------------------------- 64 | → Γ , Γ′ ⊢ fst M ⊑ᶜ fst M′ 65 | 66 | ⊑ᶜ-snd : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ A `× B} {M′ : Γ′ ⊢ A′ `× B′} 67 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 68 | ------------------------- 69 | → Γ , Γ′ ⊢ snd M ⊑ᶜ snd M′ 70 | 71 | ⊑ᶜ-inl : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} 72 | → B ⊑ B′ 73 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 74 | ------------------------------------------ 75 | → Γ , Γ′ ⊢ inl {B = B} M ⊑ᶜ inl {B = B′} M′ 76 | 77 | ⊑ᶜ-inr : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ B} {M′ : Γ′ ⊢ B′} 78 | → A ⊑ A′ 79 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 80 | ------------------------------------------ 81 | → Γ , Γ′ ⊢ inr {A = A} M ⊑ᶜ inr {A = A′} M′ 82 | 83 | ⊑ᶜ-case : ∀ {Γ Γ′ A A′ B B′ C C′} {L : Γ ⊢ A `⊎ B} {L′ : Γ′ ⊢ A′ `⊎ B′} {M : Γ , A ⊢ C} {M′ : Γ′ , A′ ⊢ C′} {N : Γ , B ⊢ C} {N′ : Γ′ , B′ ⊢ C′} 84 | → Γ , Γ′ ⊢ L ⊑ᶜ L′ 85 | → A ⊑ A′ → B ⊑ B′ 86 | → (Γ , A) , (Γ′ , A′) ⊢ M ⊑ᶜ M′ 87 | → (Γ , B) , (Γ′ , B′) ⊢ N ⊑ᶜ N′ 88 | ------------------------------------- 89 | → Γ , Γ′ ⊢ case L M N ⊑ᶜ case L′ M′ N′ 90 | 91 | ⊑ᶜ-cast : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 92 | → A ⊑ A′ → B ⊑ B′ 93 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 94 | ------------------------------ 95 | → Γ , Γ′ ⊢ M ⟨ c ⟩ ⊑ᶜ M′ ⟨ c′ ⟩ 96 | 97 | ⊑ᶜ-castl : ∀ {Γ Γ′ A A′ B} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} {c : Cast (A ⇒ B)} 98 | → A ⊑ A′ → B ⊑ A′ 99 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 100 | ----------------------- 101 | → Γ , Γ′ ⊢ M ⟨ c ⟩ ⊑ᶜ M′ 102 | 103 | ⊑ᶜ-castr : ∀ {Γ Γ′ A A′ B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} {c′ : Cast (A′ ⇒ B′)} 104 | → A ⊑ A′ → A ⊑ B′ 105 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 106 | ------------------------ 107 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ ⟨ c′ ⟩ 108 | 109 | {- The cases below are for wrapped inert casts. -} 110 | ⊑ᶜ-wrap : ∀ {Γ Γ′ A A′ B B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} 111 | {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 112 | {i : Inert c} {i′ : Inert c′} 113 | → ⟪ i ⟫⊑⟪ i′ ⟫ 114 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 115 | → (B ≡ ⋆ → B′ ≡ ⋆) 116 | ------------------------------ 117 | → Γ , Γ′ ⊢ M ⟪ i ⟫ ⊑ᶜ M′ ⟪ i′ ⟫ 118 | 119 | ⊑ᶜ-wrapl : ∀ {Γ Γ′ A A′ B} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} 120 | {c : Cast (A ⇒ B)} {i : Inert c} 121 | → ⟪ i ⟫⊑ A′ 122 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 123 | -- NOTE: Not sure if we need to require Value M′ here. 124 | ----------------------- 125 | → Γ , Γ′ ⊢ M ⟪ i ⟫ ⊑ᶜ M′ 126 | 127 | ⊑ᶜ-wrapr : ∀ {Γ Γ′ A A′ B′} {M : Γ ⊢ A} {M′ : Γ′ ⊢ A′} 128 | {c′ : Cast (A′ ⇒ B′)} {i′ : Inert c′} 129 | → A ⊑⟪ i′ ⟫ 130 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ 131 | → A ≢ ⋆ 132 | ------------------------ 133 | → Γ , Γ′ ⊢ M ⊑ᶜ M′ ⟪ i′ ⟫ 134 | 135 | ⊑ᶜ-blame : ∀ {Γ Γ′ A A′} {M : Γ ⊢ A} {ℓ} 136 | → A ⊑ A′ 137 | ------------------------------- 138 | → Γ , Γ′ ⊢ M ⊑ᶜ blame {Γ′} {A′} ℓ 139 | 140 | data _,_,_,_⊢_⊑ˢ_ : (Γ Δ Γ′ Δ′ : Context) → Subst Γ Δ → Subst Γ′ Δ′ → Set where 141 | 142 | ⊑ˢ-σ₀ : ∀ {Δ Δ′ A A′} {M : Δ ⊢ A} {M′ : Δ′ ⊢ A′} 143 | → Δ , Δ′ ⊢ M ⊑ᶜ M′ 144 | ------------------------------------------ 145 | → (Δ , A) , Δ , (Δ′ , A′) , Δ′ ⊢ (subst-zero M) ⊑ˢ (subst-zero M′) 146 | 147 | ⊑ˢ-exts : ∀ {Γ Γ′ Δ Δ′ B B′} {σ : Subst Γ Δ} {σ′ : Subst Γ′ Δ′} 148 | → Γ , Δ , Γ′ , Δ′ ⊢ σ ⊑ˢ σ′ 149 | ------------------------------------------------------------------- 150 | → (Γ , B) , (Δ , B) , (Γ′ , B′) , (Δ′ , B′) ⊢ (exts σ) ⊑ˢ (exts σ′) 151 | 152 | -- Example(s): 153 | _ : ∅ , ∅ ⊢ ƛ_ {B = ⋆} {⋆} (` Z) ⊑ᶜ ƛ_ {B = ` Nat} {` Nat} (` Z) 154 | _ = ⊑ᶜ-ƛ unk⊑ (⊑ᶜ-var refl) 155 | -------------------------------------------------------------------------------- /ParamCCPrecisionABT.agda: -------------------------------------------------------------------------------- 1 | open import Data.List 2 | open import Relation.Binary.PropositionalEquality 3 | using (_≡_; _≢_; refl) 4 | open import Data.Product 5 | using (_×_; proj₁; proj₂; ∃; ∃-syntax) 6 | renaming (_,_ to ⟨_,_⟩) 7 | 8 | open import Types 9 | open import Labels 10 | open import PreCastStructure 11 | 12 | open import Syntax 13 | 14 | 15 | module ParamCCPrecisionABT (precast : PreCastStruct) where 16 | 17 | open PreCastStruct precast 18 | 19 | open import ParamCastCalculusABT precast 20 | 21 | {- The precision relation for the cast calculus. -} 22 | infix 4 _,_⊢_⊑_ 23 | 24 | data _,_⊢_⊑_ : ∀ (Γ Γ′ : List Type) → (M M′ : Term) → Set where 25 | 26 | ⊑-$ : ∀ {Γ Γ′ A} {r : rep A} {p : Prim A} 27 | -------------------------------------- 28 | → Γ , Γ′ ⊢ $ r # p ⊑ $ r # p 29 | 30 | ⊑-` : ∀ {Γ Γ′} {x : Var} 31 | --------------------- 32 | → Γ , Γ′ ⊢ ` x ⊑ ` x 33 | 34 | ⊑-ƛ : ∀ {Γ Γ′ A A′} {N N′ : Term} 35 | → A ⊑ A′ 36 | → A ∷ Γ , A′ ∷ Γ′ ⊢ N ⊑ N′ 37 | ------------------------------ 38 | → Γ , Γ′ ⊢ ƛ A ˙ N ⊑ ƛ A′ ˙ N′ 39 | 40 | ⊑-· : ∀ {Γ Γ′} {L L′ M M′ : Term} 41 | → Γ , Γ′ ⊢ L ⊑ L′ 42 | → Γ , Γ′ ⊢ M ⊑ M′ 43 | -------------------------- 44 | → Γ , Γ′ ⊢ L · M ⊑ L′ · M′ 45 | 46 | ⊑-if : ∀ {Γ Γ′} {L L′ M M′ N N′ : Term} 47 | → Γ , Γ′ ⊢ L ⊑ L′ 48 | → Γ , Γ′ ⊢ M ⊑ M′ 49 | → Γ , Γ′ ⊢ N ⊑ N′ 50 | ---------------------------------------- 51 | → Γ , Γ′ ⊢ if L then M else N endif ⊑ 52 | if L′ then M′ else N′ endif 53 | 54 | ⊑-cons : ∀ {Γ Γ′} {M M′ N N′ : Term} 55 | → Γ , Γ′ ⊢ M ⊑ M′ 56 | → Γ , Γ′ ⊢ N ⊑ N′ 57 | ---------------------------------- 58 | → Γ , Γ′ ⊢ ⟦ M , N ⟧ ⊑ ⟦ M′ , N′ ⟧ 59 | 60 | ⊑-fst : ∀ {Γ Γ′} {M M′ : Term} 61 | → Γ , Γ′ ⊢ M ⊑ M′ 62 | ------------------------- 63 | → Γ , Γ′ ⊢ fst M ⊑ fst M′ 64 | 65 | ⊑-snd : ∀ {Γ Γ′} {M M′ : Term} 66 | → Γ , Γ′ ⊢ M ⊑ M′ 67 | ------------------------- 68 | → Γ , Γ′ ⊢ snd M ⊑ snd M′ 69 | 70 | ⊑-inl : ∀ {Γ Γ′ B B′} {M M′ : Term} 71 | → B ⊑ B′ 72 | → Γ , Γ′ ⊢ M ⊑ M′ 73 | ------------------------------------------ 74 | → Γ , Γ′ ⊢ inl M other B ⊑ inl M′ other B′ 75 | 76 | ⊑-inr : ∀ {Γ Γ′ A A′} {M M′ : Term} 77 | → A ⊑ A′ 78 | → Γ , Γ′ ⊢ M ⊑ M′ 79 | ------------------------------------------ 80 | → Γ , Γ′ ⊢ inr M other A ⊑ inr M′ other A′ 81 | 82 | ⊑-case : ∀ {Γ Γ′ A A′ B B′} {L L′ M M′ N N′ : Term} 83 | → Γ , Γ′ ⊢ L ⊑ L′ 84 | → A ⊑ A′ 85 | → B ⊑ B′ 86 | → A ∷ Γ , A′ ∷ Γ′ ⊢ M ⊑ M′ 87 | → B ∷ Γ , B′ ∷ Γ′ ⊢ N ⊑ N′ 88 | ------------------------------------------ 89 | → Γ , Γ′ ⊢ case L of A ⇒ M ∣ B ⇒ N ⊑ 90 | case L′ of A′ ⇒ M′ ∣ B′ ⇒ N′ 91 | 92 | ⊑-cast : ∀ {Γ Γ′ A A′ B B′} {M M′ : Term} 93 | {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 94 | → A ⊑ A′ 95 | → B ⊑ B′ 96 | → Γ , Γ′ ⊢ M ⊑ M′ 97 | ------------------------------ 98 | → Γ , Γ′ ⊢ M ⟨ c ⟩ ⊑ M′ ⟨ c′ ⟩ 99 | 100 | ⊑-castl : ∀ {Γ Γ′ A A′ B} {M M′ : Term} 101 | {c : Cast (A ⇒ B)} 102 | → A ⊑ A′ 103 | → B ⊑ A′ 104 | → Γ′ ⊢ M′ ⦂ A′ 105 | → Γ , Γ′ ⊢ M ⊑ M′ 106 | ----------------------- 107 | → Γ , Γ′ ⊢ M ⟨ c ⟩ ⊑ M′ 108 | 109 | ⊑-castr : ∀ {Γ Γ′ A A′ B′} {M M′ : Term} 110 | {c′ : Cast (A′ ⇒ B′)} 111 | → A ⊑ A′ 112 | → A ⊑ B′ 113 | → Γ ⊢ M ⦂ A 114 | → Γ , Γ′ ⊢ M ⊑ M′ 115 | ------------------------ 116 | → Γ , Γ′ ⊢ M ⊑ M′ ⟨ c′ ⟩ 117 | 118 | ⊑-wrap : ∀ {Γ Γ′ A A′ B B′} {M M′ : Term} 119 | {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} 120 | {i : Inert c} {i′ : Inert c′} 121 | → A ⊑ A′ 122 | → B ⊑ B′ 123 | → Γ , Γ′ ⊢ M ⊑ M′ 124 | → (B ≡ ⋆ → B′ ≡ ⋆) 125 | ----------------------------------------- 126 | → Γ , Γ′ ⊢ M ⟨ c ₍ i ₎⟩ ⊑ M′ ⟨ c′ ₍ i′ ₎⟩ 127 | 128 | ⊑-wrapl : ∀ {Γ Γ′ A A′ B} {M M′ : Term} 129 | {c : Cast (A ⇒ B)} {i : Inert c} 130 | → A ⊑ A′ 131 | → B ⊑ A′ 132 | → Γ′ ⊢ M′ ⦂ A′ 133 | → Γ , Γ′ ⊢ M ⊑ M′ 134 | --------------------------- 135 | → Γ , Γ′ ⊢ M ⟨ c ₍ i ₎⟩ ⊑ M′ 136 | 137 | ⊑-wrapr : ∀ {Γ Γ′ A A′ B′} {M M′ : Term} 138 | {c′ : Cast (A′ ⇒ B′)} {i′ : Inert c′} 139 | → A ⊑ A′ 140 | → A ⊑ B′ 141 | → Γ ⊢ M ⦂ A 142 | → Γ , Γ′ ⊢ M ⊑ M′ 143 | → A ≢ ⋆ 144 | ----------------------------- 145 | → Γ , Γ′ ⊢ M ⊑ M′ ⟨ c′ ₍ i′ ₎⟩ 146 | 147 | ⊑-blame : ∀ {Γ Γ′ A A′} {M : Term} {ℓ} 148 | → Γ ⊢ M ⦂ A 149 | → A ⊑ A′ 150 | ------------------------------- 151 | → Γ , Γ′ ⊢ M ⊑ blame A′ ℓ 152 | 153 | -- Example(s): 154 | private 155 | _ : [] , [] ⊢ ƛ ⋆ ˙ (` 0) ⊑ ƛ (` Nat) ˙ (` 0) 156 | _ = ⊑-ƛ unk⊑ ⊑-` 157 | -------------------------------------------------------------------------------- /ParamCCSyntaxABT.agda: -------------------------------------------------------------------------------- 1 | open import Data.Unit using (⊤) renaming (tt to unit) 2 | open import Data.List 3 | open import Data.Vec using (Vec) renaming ([] to []ᵥ; _∷_ to _∷ᵥ_) 4 | open import Data.Product 5 | using (_×_; proj₁; proj₂; ∃; ∃-syntax; Σ; Σ-syntax) 6 | renaming (_,_ to ⟨_,_⟩ ) 7 | open import Relation.Nullary using (¬_) 8 | open import Relation.Nullary.Negation using (contradiction) 9 | open import Relation.Binary.PropositionalEquality 10 | using (_≡_; refl; trans; sym; cong; cong₂; cong-app) 11 | 12 | open import Types 13 | open import Labels 14 | open import PreCastStructure 15 | 16 | open import Syntax 17 | 18 | module ParamCCSyntaxABT (pcs : PreCastStruct) where 19 | 20 | open PreCastStruct pcs using (Cast; Inert) 21 | 22 | {- 23 | We define well-typed expressions with the following typing judgment. 24 | Compared to the STLC, there are two important new features. 25 | The cast is written M ⟨ c ⟩, where M is an expression and c 26 | is a cast (whatever that may be). We also have (blame A ℓ) for 27 | raising uncatchable exceptions. 28 | -} 29 | 30 | data Op : Set where 31 | op-lam : Type → Op 32 | op-app : Op 33 | op-lit : ∀ {A} → rep A → Prim A → Op 34 | op-if : Op 35 | op-cons : Op 36 | op-fst : Op 37 | op-snd : Op 38 | op-inl : Type → Op 39 | op-inr : Type → Op 40 | op-case : Type → Type → Op 41 | op-cast : ∀ {A B} → Cast (A ⇒ B) → Op 42 | op-wrap : ∀ {A B} → (c : Cast (A ⇒ B)) → Inert c → Op 43 | op-blame : Type → Label → Op 44 | 45 | sig : Op → List Sig 46 | sig (op-lam A) = (ν ■) ∷ [] 47 | sig op-app = ■ ∷ ■ ∷ [] 48 | sig (op-lit r p) = [] 49 | sig op-if = ■ ∷ ■ ∷ ■ ∷ [] 50 | sig op-cons = ■ ∷ ■ ∷ [] 51 | sig op-fst = ■ ∷ [] 52 | sig op-snd = ■ ∷ [] 53 | sig (op-inl B) = ■ ∷ [] 54 | sig (op-inr A) = ■ ∷ [] 55 | sig (op-case A B) = ■ ∷ (ν ■) ∷ (ν ■) ∷ [] 56 | sig (op-cast c) = ■ ∷ [] 57 | sig (op-wrap c i) = ■ ∷ [] 58 | sig (op-blame A ℓ) = [] 59 | 60 | open Syntax.OpSig Op sig 61 | renaming (ABT to Term) 62 | hiding (plug) -- we'll implement `plug` for frame 63 | public 64 | 65 | infixl 7 _·_ 66 | infix 8 _⟨_⟩ 67 | {- 68 | We use this to express "term *wrapped* with inert cast". 69 | Corresponds to `_⟪_⟫` in `ParamCastCalculus`. The later 70 | creates visual confusion with the ABT library. 71 | -} 72 | infix 9 _⟨_₍_₎⟩ 73 | 74 | pattern ƛ_˙_ A N = (op-lam A) ⦅ cons (bind (ast N)) nil ⦆ 75 | pattern _·_ L M = op-app ⦅ cons (ast L) (cons (ast M) nil) ⦆ 76 | pattern $_#_ r p = (op-lit r p) ⦅ nil ⦆ 77 | pattern if_then_else_endif L M N = op-if ⦅ cons (ast L) (cons (ast M) (cons (ast N) nil)) ⦆ 78 | pattern ⟦_,_⟧ M N = op-cons ⦅ cons (ast M) (cons (ast N) nil) ⦆ 79 | pattern fst_ M = op-fst ⦅ cons (ast M) nil ⦆ 80 | pattern snd_ M = op-snd ⦅ cons (ast M) nil ⦆ 81 | pattern inl_other_ M B = (op-inl B) ⦅ cons (ast M) nil ⦆ 82 | pattern inr_other_ M A = (op-inr A) ⦅ cons (ast M) nil ⦆ 83 | pattern case_of_⇒_∣_⇒_ L A M B N = 84 | (op-case A B) ⦅ cons (ast L) (cons (bind (ast M)) (cons (bind (ast N)) nil)) ⦆ 85 | pattern _⟨_⟩ M c = (op-cast c) ⦅ cons (ast M) nil ⦆ 86 | pattern _⟨_₍_₎⟩ M c i = (op-wrap c i) ⦅ cons (ast M) nil ⦆ 87 | pattern blame A ℓ = (op-blame A ℓ) ⦅ nil ⦆ 88 | -------------------------------------------------------------------------------- /ParamCastAuxOrig.agda: -------------------------------------------------------------------------------- 1 | open import Types 2 | open import PreCastStructure 3 | open import Labels 4 | open import Data.Nat 5 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) renaming (_,_ to ⟨_,_⟩) 6 | open import Data.Sum using (_⊎_; inj₁; inj₂) 7 | open import Data.Bool 8 | open import Variables 9 | open import Relation.Nullary using (¬_) 10 | open import Relation.Nullary.Negation using (contradiction) 11 | open import Relation.Binary.PropositionalEquality using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 12 | open import Data.Empty using (⊥; ⊥-elim) 13 | 14 | {- 15 | 16 | This modules defines reduction for the Parameterized Cast Calculus 17 | and provides a proof of progress. Preservation is guaranteed in the 18 | way the reduction relation is defined and checked by Agda. 19 | 20 | -} 21 | 22 | 23 | module ParamCastAuxOrig (pcs : PreCastStruct) where 24 | 25 | open PreCastStruct pcs 26 | 27 | import ParamCastCalculusOrig 28 | open ParamCastCalculusOrig Cast 29 | 30 | {- 31 | 32 | Before defining reduction, we first need to define Value. In cast 33 | calculi, whether a cast forms a value or not depends on the shape of 34 | the cast. But here we have parameterized over casts. So we must add 35 | more parameters to tell us whether a cast is a value-forming cast or 36 | not. So we add the parameter Inert to identify the later, and the 37 | parameter Active to identify casts that need to be reduced. Further, 38 | we require that all casts (at least, all the well-typed ones) can be 39 | categorized one of these two ways, which is given by the 40 | ActiveOrInert parameter. 41 | 42 | The following is the definition of Value. The case for casts, M ⟨ c ⟩, 43 | requires M to be a value and c to be an inert cast. 44 | 45 | -} 46 | data Value : ∀ {Γ A} → Γ ⊢ A → Set where 47 | 48 | V-ƛ : ∀ {Γ A B} {N : Γ , A ⊢ B} 49 | ----------- 50 | → Value (ƛ N) 51 | 52 | V-const : ∀ {Γ} {A : Type} {k : rep A} {f : Prim A} 53 | ------------------------ 54 | → Value {Γ} {A} (($ k){f}) 55 | 56 | V-pair : ∀ {Γ A B} {V : Γ ⊢ A} {W : Γ ⊢ B} 57 | → Value V → Value W 58 | ----------------- 59 | → Value (cons V W) 60 | 61 | V-inl : ∀ {Γ A B} {V : Γ ⊢ A} 62 | → Value V 63 | -------------------------- 64 | → Value {Γ} {A `⊎ B} (inl V) 65 | 66 | V-inr : ∀ {Γ A B} {V : Γ ⊢ B} 67 | → Value V 68 | -------------------------- 69 | → Value {Γ} {A `⊎ B} (inr V) 70 | 71 | V-cast : ∀ {Γ : Context} {A B : Type} {V : Γ ⊢ A} {c : Cast (A ⇒ B)} 72 | {i : Inert c} 73 | → Value V 74 | --------------- 75 | → Value (V ⟨ c ⟩) 76 | 77 | 78 | {- 79 | 80 | A value of type ⋆ must be of the form M ⟨ c ⟩ where c is inert cast. 81 | 82 | -} 83 | canonical⋆ : ∀ {Γ} → (M : Γ ⊢ ⋆) → (Value M) 84 | → Σ[ A ∈ Type ] Σ[ M' ∈ (Γ ⊢ A) ] Σ[ c ∈ (Cast (A ⇒ ⋆)) ] 85 | Inert c × (M ≡ (M' ⟨ c ⟩)) 86 | canonical⋆ .($ _) (V-const {k = ()}) 87 | canonical⋆ .(_ ⟨ _ ⟩) (V-cast{Γ}{A}{B}{V}{c}{i} v) = 88 | ⟨ A , ⟨ V , ⟨ c , ⟨ i , refl ⟩ ⟩ ⟩ ⟩ 89 | 90 | {- 91 | 92 | We shall use a kind of shallow evaluation context, called a Frame, 93 | to collapse all of the ξ rules into a single rule. 94 | 95 | -} 96 | 97 | data Frame : {Γ : Context} → Type → Type → Set where 98 | 99 | F-·₁ : ∀ {Γ A B} 100 | → Γ ⊢ A 101 | → Frame {Γ} (A ⇒ B) B 102 | 103 | F-·₂ : ∀ {Γ A B} 104 | → (M : Γ ⊢ A ⇒ B) → ∀{v : Value {Γ} M} 105 | → Frame {Γ} A B 106 | 107 | F-if : ∀ {Γ A} 108 | → Γ ⊢ A 109 | → Γ ⊢ A 110 | → Frame {Γ} (` 𝔹) A 111 | 112 | F-×₁ : ∀ {Γ A B} 113 | → Γ ⊢ A 114 | → Frame {Γ} B (A `× B) 115 | 116 | F-×₂ : ∀ {Γ A B} 117 | → Γ ⊢ B 118 | → Frame {Γ} A (A `× B) 119 | 120 | F-fst : ∀ {Γ A B} 121 | → Frame {Γ} (A `× B) A 122 | 123 | F-snd : ∀ {Γ A B} 124 | → Frame {Γ} (A `× B) B 125 | 126 | F-inl : ∀ {Γ A B} 127 | → Frame {Γ} A (A `⊎ B) 128 | 129 | F-inr : ∀ {Γ A B} 130 | → Frame {Γ} B (A `⊎ B) 131 | 132 | F-case : ∀ {Γ A B C} 133 | → Γ ⊢ A ⇒ C 134 | → Γ ⊢ B ⇒ C 135 | → Frame {Γ} (A `⊎ B) C 136 | 137 | F-cast : ∀ {Γ A B} 138 | → Cast (A ⇒ B) 139 | → Frame {Γ} A B 140 | 141 | {- 142 | 143 | The plug function inserts an expression into the hole of a frame. 144 | 145 | -} 146 | 147 | plug : ∀{Γ A B} → Γ ⊢ A → Frame {Γ} A B → Γ ⊢ B 148 | plug L (F-·₁ M) = L · M 149 | plug M (F-·₂ L) = L · M 150 | plug L (F-if M N) = if L M N 151 | plug L (F-×₁ M) = cons M L 152 | plug M (F-×₂ L) = cons M L 153 | plug M (F-fst) = fst M 154 | plug M (F-snd) = snd M 155 | plug M (F-inl) = inl M 156 | plug M (F-inr) = inr M 157 | plug L (F-case M N) = case L M N 158 | plug M (F-cast c) = M ⟨ c ⟩ 159 | 160 | eta⇒ : ∀ {Γ A B C D} → (M : Γ ⊢ A ⇒ B) 161 | → (c : Cast ((A ⇒ B) ⇒ (C ⇒ D))) 162 | → (x : Cross c) 163 | → Γ ⊢ C ⇒ D 164 | eta⇒ M c x = 165 | ƛ (((rename S_ M) · ((` Z) ⟨ dom c x ⟩)) ⟨ cod c x ⟩) 166 | 167 | eta× : ∀ {Γ A B C D} → (M : Γ ⊢ A `× B) 168 | → (c : Cast ((A `× B) ⇒ (C `× D))) 169 | → (x : Cross c) 170 | → Γ ⊢ C `× D 171 | eta× M c x = 172 | cons (fst M ⟨ fstC c x ⟩) (snd M ⟨ sndC c x ⟩) 173 | 174 | eta⊎ : ∀ {Γ A B C D} → (M : Γ ⊢ A `⊎ B) 175 | → (c : Cast ((A `⊎ B) ⇒ (C `⊎ D))) 176 | → (x : Cross c) 177 | → Γ ⊢ C `⊎ D 178 | eta⊎ M c x = 179 | let l = inl ((` Z) ⟨ inlC c x ⟩) in 180 | let r = inr ((` Z) ⟨ inrC c x ⟩) in 181 | case M (ƛ l) (ƛ r) 182 | 183 | -------------------------------------------------------------------------------- /ParamCastCalculusABT.agda: -------------------------------------------------------------------------------- 1 | open import Data.Unit using (⊤) renaming (tt to unit) 2 | open import Data.List 3 | open import Data.Vec using (Vec) renaming ([] to []ᵥ; _∷_ to _∷ᵥ_) 4 | open import Data.Product 5 | using (_×_; proj₁; proj₂; ∃; ∃-syntax; Σ; Σ-syntax) 6 | renaming (_,_ to ⟨_,_⟩ ) 7 | open import Relation.Nullary using (¬_) 8 | open import Relation.Nullary.Negation using (contradiction) 9 | open import Relation.Binary.PropositionalEquality 10 | using (_≡_; refl; trans; sym; cong; cong₂; cong-app) 11 | 12 | open import Types 13 | open import Labels 14 | open import PreCastStructure 15 | 16 | open import Syntax 17 | 18 | module ParamCastCalculusABT (pcs : PreCastStruct) where 19 | 20 | open import ParamCCSyntaxABT pcs public 21 | 22 | {- 23 | Here we define the Cast Calculus in a way that parameterizes over the 24 | actual casts, to enable succinct definitions and proofs of type safety 25 | for many different cast calculi. The Agda type constructor for 26 | representing casts is given by the module parameter named Cast. The 27 | Type argument to Cast is typically a function type whose domain is the 28 | source of the cast and whose codomain is the target type of the 29 | cast. However, in cast calculi with fancy types such as intersections, 30 | the type of a cast may not literally be a function type. 31 | -} 32 | 33 | 34 | 𝑉⊢ : List Type → Var → Type → Type → Set 35 | 𝑃⊢ : (op : Op) → Vec Type (length (sig op)) → BTypes Type (sig op) → Type → Set 36 | 37 | -- ⊢var : ∀ {Γ A} {x : ℕ} 38 | -- → Γ ∋ x ⦂ A 39 | -- -------------- 40 | -- → Γ ⊢ ` x ⦂ A 41 | 𝑉⊢ Γ x A B = A ≡ B 42 | 43 | -- ⊢lam : ∀ {Γ A B} {N} 44 | -- → Γ , A ⊢ N ⦂ B 45 | -- ------------------- 46 | -- → Γ ⊢ ƛ A ˙ N ⦂ A ⇒ B 47 | 𝑃⊢ (op-lam A₁) (B ∷ᵥ []ᵥ) ⟨ ⟨ A , tt ⟩ , tt ⟩ C = 48 | C ≡ A ⇒ B × A ≡ A₁ 49 | 50 | -- ⊢app : ∀ {Γ A B} {L M} 51 | -- → Γ ⊢ L ⦂ A ⇒ B 52 | -- → Γ ⊢ M ⦂ A 53 | -- -------------------- 54 | -- → Γ ⊢ L · M ⦂ B 55 | 𝑃⊢ op-app (C ∷ᵥ A ∷ᵥ []ᵥ) ⟨ tt , ⟨ tt , tt ⟩ ⟩ B = 56 | C ≡ A ⇒ B 57 | 58 | -- ⊢lit : ∀ {Γ A} {r : rep A} {p : Prim A} 59 | -- ------------------ 60 | -- → Γ ⊢ $ r # p ⦂ A 61 | 𝑃⊢ (op-lit {A₁} r p) []ᵥ tt A = A ≡ A₁ 62 | 63 | -- ⊢if : ∀ {Γ A} {L M N} 64 | -- → Γ ⊢ L ⦂ ` 𝔹 65 | -- → Γ ⊢ M ⦂ A 66 | -- → Γ ⊢ N ⦂ A 67 | -- -------------------------------------- 68 | -- → Γ ⊢ if L then M else N endif ⦂ A 69 | 𝑃⊢ op-if (B ∷ᵥ A₁ ∷ᵥ A₂ ∷ᵥ []ᵥ) ⟨ tt , ⟨ tt , ⟨ tt , tt ⟩ ⟩ ⟩ A = 70 | (A ≡ A₁ × A₁ ≡ A₂) × B ≡ ` 𝔹 71 | 72 | -- ⊢cons : ∀ {Γ A B} {M N} 73 | -- → Γ ⊢ M ⦂ A 74 | -- → Γ ⊢ N ⦂ B 75 | -- ------------------------- 76 | -- → Γ ⊢ ⟦ M , N ⟧ ⦂ A `× B 77 | 𝑃⊢ op-cons (A ∷ᵥ B ∷ᵥ []ᵥ) ⟨ tt , ⟨ tt , tt ⟩ ⟩ C = C ≡ A `× B 78 | 79 | -- ⊢fst : ∀ {Γ A B} {M} 80 | -- → Γ ⊢ M ⦂ A `× B 81 | -- --------------------- 82 | -- → Γ ⊢ fst M ⦂ A 83 | 𝑃⊢ op-fst (C ∷ᵥ []ᵥ) ⟨ tt , tt ⟩ A = ∃[ B ] C ≡ A `× B 84 | 85 | -- ⊢snd : ∀ {Γ A B} {M} 86 | -- → Γ ⊢ M ⦂ A `× B 87 | -- --------------------- 88 | -- → Γ ⊢ snd M ⦂ B 89 | 𝑃⊢ op-snd (C ∷ᵥ []ᵥ) ⟨ tt , tt ⟩ B = ∃[ A ] C ≡ A `× B 90 | 91 | -- ⊢inl : ∀ {Γ A B} {M} 92 | -- → Γ ⊢ M ⦂ A 93 | -- -------------------------- 94 | -- → Γ ⊢ inl M other B ⦂ A `⊎ B 95 | 𝑃⊢ (op-inl B) (A ∷ᵥ []ᵥ) ⟨ tt , tt ⟩ C = C ≡ A `⊎ B 96 | 97 | -- ⊢inr : ∀ {Γ A B} {M} 98 | -- → Γ ⊢ M ⦂ B 99 | -- -------------------------- 100 | -- → Γ ⊢ inr M other A ⦂ A `⊎ B 101 | 𝑃⊢ (op-inr A) (B ∷ᵥ []ᵥ) ⟨ tt , tt ⟩ C = C ≡ A `⊎ B 102 | 103 | -- ⊢case : ∀ {Γ A B C} {L M N} 104 | -- → Γ ⊢ L ⦂ A `⊎ B 105 | -- → Γ , A ⊢ M ⦂ C 106 | -- → Γ , B ⊢ N ⦂ C 107 | -- ----------------------------------------- 108 | -- → Γ ⊢ case L of A ⇒ M ∣ B ⇒ N ⦂ C 109 | 𝑃⊢ (op-case A₁ B₁) (X ∷ᵥ C₁ ∷ᵥ C₂ ∷ᵥ []ᵥ) ⟨ tt , ⟨ ⟨ A , tt ⟩ , ⟨ ⟨ B , tt ⟩ , tt ⟩ ⟩ ⟩ C = 110 | (C ≡ C₁ × C₁ ≡ C₂) × (X ≡ A `⊎ B × A ≡ A₁ × B ≡ B₁) 111 | 112 | -- ⊢cast : ∀ {Γ A B} {M} 113 | -- → Γ ⊢ M ⦂ A 114 | -- → (c : Cast (A ⇒ B)) 115 | -- -------------------- 116 | -- → Γ ⊢ M ⟨ c ⟩ ⦂ B 117 | 𝑃⊢ (op-cast {A₁} {B₁} c) (A ∷ᵥ []ᵥ) ⟨ tt , tt ⟩ B = A ≡ A₁ × B ≡ B₁ 118 | 119 | -- ⊢wrap : ∀ {Γ A B} {M} 120 | -- → Γ ⊢ M ⦂ A 121 | -- → (c : Cast (A ⇒ B)) 122 | -- → (i : Inert c) 123 | -- --------------------- 124 | -- → Γ ⊢ M ⟨ c ₍ i ₎⟩ ⦂ B 125 | 𝑃⊢ (op-wrap {A₁} {B₁} c i) (A ∷ᵥ []ᵥ) ⟨ tt , tt ⟩ B = A ≡ A₁ × B ≡ B₁ 126 | 127 | -- ⊢blame : ∀ {Γ A} {ℓ} 128 | -- ----------------- 129 | -- → Γ ⊢ blame ℓ ⦂ A 130 | 𝑃⊢ (op-blame A ℓ) []ᵥ tt C = C ≡ A 131 | 132 | pattern 𝐶⊢-ƛ = ⟨ refl , refl ⟩ 133 | pattern 𝐶⊢-· = refl 134 | pattern 𝐶⊢-$ = refl 135 | pattern 𝐶⊢-if = ⟨ ⟨ refl , refl ⟩ , refl ⟩ 136 | pattern 𝐶⊢-cons = refl 137 | pattern 𝐶⊢-fst = ⟨ _ , refl ⟩ 138 | pattern 𝐶⊢-snd = ⟨ _ , refl ⟩ 139 | pattern 𝐶⊢-inl = refl 140 | pattern 𝐶⊢-inr = refl 141 | pattern 𝐶⊢-case = ⟨ ⟨ refl , refl ⟩ , ⟨ refl , ⟨ refl , refl ⟩ ⟩ ⟩ 142 | pattern 𝐶⊢-cast = ⟨ refl , refl ⟩ 143 | pattern 𝐶⊢-wrap = ⟨ refl , refl ⟩ 144 | pattern 𝐶⊢-blame = refl 145 | 146 | infix 4 _⊢_⦂_ 147 | open import ABTPredicate Op sig 𝑉⊢ 𝑃⊢ public renaming (_⊢_⦂_ to predicate) 148 | _⊢_⦂_ = predicate 149 | 150 | open import SubstPreserve Op sig Type 𝑉⊢ 𝑃⊢ (λ x → refl) (λ { refl refl → refl }) 151 | (λ x → x) (λ { refl ⊢M → ⊢M }) public 152 | using (preserve-rename; preserve-subst; preserve-substitution) 153 | 154 | open import GenericPredicate pcs 155 | open GenericPredicatePatterns 𝑉⊢ 𝑃⊢ public 156 | -------------------------------------------------------------------------------- /ParamGradualGuaranteeAux.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat using (ℕ; zero; suc) 2 | open import Data.Nat.Properties using (suc-injective) 3 | open import Data.Bool 4 | open import Relation.Nullary using (¬_; Dec; yes; no) 5 | open import Relation.Nullary.Negation using (contradiction) 6 | open import Relation.Binary.PropositionalEquality 7 | using (_≡_; _≢_; refl; trans; sym; cong; cong₂) 8 | renaming (subst to subst-eq; subst₂ to subst₂-eq) 9 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩) 10 | open import Data.Sum using (_⊎_; inj₁; inj₂) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | 13 | open import Types 14 | open import Variables 15 | open import Labels 16 | open import PreCastStructureWithPrecision 17 | 18 | module ParamGradualGuaranteeAux (pcsp : PreCastStructWithPrecision) where 19 | 20 | open PreCastStructWithPrecision pcsp 21 | 22 | open import ParamCastCalculus Cast Inert 23 | open import ParamCastAux precast 24 | open import ParamCCPrecision pcsp 25 | 26 | {- Various inversion lemmas about `wrap` being on either or both sides. -} 27 | value-⊑-wrap-inv : ∀ {A′} {V : ∅ ⊢ ⋆} {V′ : ∅ ⊢ A′} {c′ : Cast (A′ ⇒ ⋆)} {i′ : Inert c′} 28 | → Value V → Value (V′ ⟪ i′ ⟫) 29 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ ⟪ i′ ⟫ 30 | ----------------------- 31 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 32 | value-⊑-wrap-inv v (V-wrap v′ i′) (⊑ᶜ-wrap lpii lpW imp) 33 | with lpii→⊑ lpii 34 | ... | ⟨ lp , unk⊑ ⟩ = ⊑ᶜ-wrapl (⊑→lpit _ lp unk⊑) lpW 35 | value-⊑-wrap-inv (V-wrap v i) (V-wrap v′ i′) (⊑ᶜ-wrapl lpit lpV) 36 | with lpit→⊑ lpit 37 | ... | ⟨ unk⊑ , unk⊑ ⟩ = contradiction i (idNotInert A-Unk _) 38 | value-⊑-wrap-inv v (V-wrap v′ i′) (⊑ᶜ-wrapr lpti lpV A≢⋆) = ⊥-elim (A≢⋆ refl) {- contradiction lpti (⋆-⋢-inert _) -} 39 | 40 | wrap-⊑-value-inv : ∀ {A A′} {V : ∅ ⊢ A} {V′ : ∅ ⊢ A′} {c : Cast (A ⇒ ⋆)} {i : Inert c} 41 | → A′ ≢ ⋆ 42 | → Value (V ⟪ i ⟫) → Value V′ 43 | → ∅ , ∅ ⊢ V ⟪ i ⟫ ⊑ᶜ V′ 44 | ---------------------- 45 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 46 | wrap-⊑-value-inv nd v w (⊑ᶜ-wrap lpii lpV imp) = ⊥-elim (nd (imp refl)) 47 | {- 48 | wrap-⊑-value-inv nd v w (⊑ᶜ-wrap lpii lpV) with inj-⊑-inj _ _ lpii 49 | ... | ⟨ refl , refl ⟩ = contradiction refl nd 50 | -} 51 | wrap-⊑-value-inv nd v w (⊑ᶜ-wrapl _ lpV) = lpV 52 | wrap-⊑-value-inv nd v w (⊑ᶜ-wrapr lpti lpV A≢⋆) = ⊥-elim (A≢⋆ refl) {- contradiction lpti (⋆-⋢-inert _) -} 53 | 54 | wrap-⊑-wrap-inv : ∀ {A A′} {V : ∅ ⊢ A} {V′ : ∅ ⊢ A′} {c : Cast (A ⇒ ⋆)} {c′ : Cast (A′ ⇒ ⋆)} 55 | {i : Inert c} {i′ : Inert c′} 56 | → Value (V ⟪ i ⟫) → Value (V′ ⟪ i′ ⟫) 57 | → ∅ , ∅ ⊢ V ⟪ i ⟫ ⊑ᶜ V′ ⟪ i′ ⟫ 58 | ----------------------------- 59 | → ∅ , ∅ ⊢ V ⊑ᶜ V′ 60 | wrap-⊑-wrap-inv (V-wrap v i) (V-wrap v′ i′) (⊑ᶜ-wrap _ lpV imp) = lpV 61 | wrap-⊑-wrap-inv (V-wrap v i) (V-wrap v′ i′) (⊑ᶜ-wrapl lpit lpV) 62 | with lpit→⊑ lpit 63 | ... | ⟨ unk⊑ , unk⊑ ⟩ = contradiction i (idNotInert A-Unk _) 64 | wrap-⊑-wrap-inv (V-wrap v i) (V-wrap v′ i′) (⊑ᶜ-wrapr lpti lpV A≢⋆) = ⊥-elim (A≢⋆ refl) {- contradiction lpti (⋆-⋢-inert _) -} 65 | -------------------------------------------------------------------------------- /Poly/Compile.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | 3 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 4 | open import Relation.Nullary using (¬_; Dec; yes; no) 5 | open import Relation.Binary.PropositionalEquality as Eq 6 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 7 | open Eq.≡-Reasoning 8 | 9 | open import Poly.Types 10 | open import Poly.Gradual renaming (Term to GTerm; `_ to #_) 11 | open import Poly.CastCalculus renaming (Term to CTerm) 12 | 13 | module Poly.Compile where 14 | 15 | coerce : ∀{A}{B}{𝒞} Γ → 𝒞 ⊢ A ~ B → Σ[ c ∈ CTerm ] (Γ ⊢ c ⦂ A ↝ B) 16 | coerce {.★} {.★} {𝒞} Γ unk~unk = idᶜ , wt-id 17 | coerce {.Nat} {.Nat} {𝒞} Γ nat~nat = idᶜ , wt-id 18 | coerce {^ X} {^ Y} {𝒞} Γ (var~var XY∈𝒞) = {!!} , {!!} {- problem! -} 19 | coerce {.★} {.(^ _)} {𝒞} Γ (unk~var x) = {!!} , {!!} {- problem! -} 20 | coerce {.(^ _)} {.★} {𝒞} Γ (var~unk x) = {!!} , {!!} {- problem! -} 21 | coerce {.★} {.Nat} {𝒞} Γ unk~nat = (nat ??) , wt-proj G-nat 22 | coerce {.★} {B₁ ⇒ B₂} {𝒞} Γ (unk~fun B₁~★ ★~B₂) 23 | with coerce Γ B₁~★ | coerce Γ ★~B₂ 24 | ... | c , ⊢c | d , ⊢d = 25 | ((★→★ ??) ⍮ (c ↪ d)) , wt-seq (wt-proj G-fun) (wt-fun ⊢c ⊢d) 26 | coerce {.Nat} {.★} {𝒞} Γ nat~unk = (nat !!) , wt-inj G-nat 27 | coerce {A₁ ⇒ A₂} {.★} {𝒞} Γ (fun~unk ★~A₁ A₂~★) 28 | with coerce Γ ★~A₁ | coerce Γ A₂~★ 29 | ... | c , ⊢c | d , ⊢d = 30 | ((c ↪ d) ⍮ (★→★ !!)) , wt-seq (wt-fun ⊢c ⊢d) (wt-inj G-fun) 31 | coerce {A ⇒ B} {A′ ⇒ B′} {𝒞} Γ (fun~fun A~A′ B~B′) 32 | with coerce Γ A~A′ | coerce Γ B~B′ 33 | ... | c , ⊢c | d , ⊢d = 34 | c ↪ d , wt-fun ⊢c ⊢d 35 | coerce {∀̇ A} {∀̇ B} {𝒞} Γ (all~all A~B) 36 | with coerce Γ A~B 37 | ... | c , ⊢c = ∀̰ c , wt-all ⊢c 38 | coerce {∀̇ A} {B} {𝒞} Γ (all~any A~B) 39 | with coerce Γ A~B 40 | ... | c , ⊢c = inst c , wt-inst ⊢c 41 | coerce {A} {∀̇ B} {𝒞} Γ (any~all A~B) 42 | with coerce Γ A~B 43 | ... | c , ⊢c = gen c , wt-gen ⊢c 44 | 45 | {- 46 | coerce ★ ★ unk~unk = idᶜ 47 | coerce ★ Nat = nat ?? 48 | coerce ★ (B₁ ⇒ B₂) 49 | with ★ =?ᵗ B₁ | ★ =?ᵗ B₂ 50 | ... | no no1 | _ = (★→★ ??) ⍮ coerce (★ ⇒ ★) (B₁ ⇒ B₂) 51 | ... | yes refl | no no2 = (★→★ ??) ⍮ coerce (★ ⇒ ★) (B₁ ⇒ B₂) 52 | ... | yes refl | yes refl = ★→★ ?? 53 | coerce ★ (∀̇ B) = {!!} 54 | coerce ★ (^ Y) = {!!} 55 | coerce Nat B = {!!} 56 | coerce (^ X) B = {!!} 57 | coerce (A₁ ⇒ A₂) ★ = {!!} 58 | coerce (A₁ ⇒ A₂) Nat = {!!} 59 | coerce (A₁ ⇒ A₂) (^ Y) = {!!} 60 | coerce (A₁ ⇒ A₂) = {!!} 61 | coerce (A₁ ⇒ A₂) B = {!!} 62 | coerce (A₁ ⇒ A₂) B = {!!} 63 | coerce (∀̇ A) B = {!!} 64 | -} 65 | 66 | compile : ∀{Γ}{M : GTerm}{A} → Γ ⊢ᵍ M ⦂ A → Σ[ M′ ∈ CTerm ] (Γ ⊢ M′ ⦂ A) 67 | compile (⊢ᵍ-nat n) = $ n , ⊢-nat n 68 | compile {M = # x} (⊢ᵍ-var ∋x) = (` x) , ⊢-var ∋x 69 | compile {M = λᵍ A N} (⊢ᵍ-lam Aok ⊢N) 70 | with compile ⊢N 71 | ... | N′ , ⊢N′ = ƛ N′ , ⊢-lam Aok ⊢N′ 72 | compile {Γ} (⊢ᵍ-app ⊢L ⊢M A′~A) 73 | with compile ⊢L | compile ⊢M 74 | ... | L′ , ⊢L′ | M′ , ⊢M′ 75 | with coerce Γ A′~A 76 | ... | c , ⊢c = 77 | L′ · (M′ ⟨ c ⟩) , ⊢-app ⊢L′ (⊢-cast ⊢M′ ⊢c) 78 | compile (⊢ᵍ-app★ ⊢M ⊢M₁) = {!!} 79 | compile (⊢ᵍ-tyabs x ⊢M) = {!!} 80 | compile (⊢ᵍ-tyapp ⊢M x) = {!!} 81 | compile (⊢ᵍ-tyapp★ ⊢M x) = {!!} 82 | -------------------------------------------------------------------------------- /Poly/Gradual.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | {- 3 | 4 | This gradual version of System F is similar to System F_G of 5 | Igarashi, Sekiyama, and Igarashi (ICFP 2017). 6 | 7 | todo: list the subtle differences 8 | * no monomorphic restriction on all~any, any~all, and any⊑all 9 | 10 | -} 11 | 12 | open import Agda.Primitive using (lzero) 13 | open import Data.List using (List; []; _∷_; length) 14 | open import Data.Nat 15 | open import Data.Nat.Induction 16 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 17 | open import Data.List using (map) 18 | open import Data.Nat.Properties 19 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 20 | open import Data.Unit.Polymorphic using (⊤; tt) 21 | open import Data.Vec using (Vec) renaming ([] to []̌; _∷_ to _∷̌_) 22 | open import Data.Empty using (⊥; ⊥-elim) 23 | open import Data.Sum using (_⊎_; inj₁; inj₂) 24 | open import Induction using (RecStruct) 25 | open import Induction.WellFounded as WF 26 | open import Data.Product.Relation.Binary.Lex.Strict 27 | using (×-Lex; ×-wellFounded; ×-preorder) 28 | open import Relation.Binary using (Rel) 29 | open import Relation.Binary.PropositionalEquality as Eq 30 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 31 | open Eq.≡-Reasoning 32 | open import Relation.Nullary using (¬_; Dec; yes; no) 33 | open import Sig renaming (ν to nu) 34 | open import Var using (Var) 35 | 36 | module Poly.Gradual where 37 | 38 | open import Poly.Types 39 | 40 | {------------- Terms -------------} 41 | 42 | data Op : Set where 43 | op-nat : ℕ → Op 44 | op-lam : Type → Op 45 | op-app : Op 46 | op-tyabs : Op 47 | op-tyapp : Type → Op 48 | 49 | sig : Op → List Sig 50 | sig (op-nat n) = [] 51 | sig (op-lam A) = (nu ■) ∷ [] 52 | sig op-app = ■ ∷ ■ ∷ [] 53 | sig op-tyabs = (nu ■) ∷ [] 54 | sig (op-tyapp A) = ■ ∷ [] 55 | 56 | open import rewriting.AbstractBindingTree Op sig renaming (ABT to Term) public 57 | 58 | pattern $ᵍ n = (op-nat n) ⦅ nil ⦆ 59 | pattern λᵍ A N = (op-lam A) ⦅ cons (bind (ast N)) nil ⦆ 60 | infixl 7 _˙_ 61 | pattern _˙_ L M = op-app ⦅ cons (ast L) (cons (ast M) nil) ⦆ 62 | pattern Λᵍ N = op-tyabs ⦅ cons (bind (ast N)) nil ⦆ 63 | infix 5 _◎_ 64 | pattern _◎_ L B = (op-tyapp B) ⦅ cons (ast L) nil ⦆ 65 | 66 | {----------------------- Values ------------------------} 67 | 68 | data Value : Term → Set where 69 | 70 | V-nat : ∀ {n : ℕ} 71 | ------------- 72 | → Value ($ᵍ n) 73 | 74 | V-λᵍ : ∀ {A : Type}{N : Term} 75 | --------------------------- 76 | → Value (λᵍ A N) 77 | 78 | V-Λᵍ : ∀ {N : Term} 79 | --------------------------- 80 | → Value (Λᵍ N) 81 | 82 | {------------- Type System -------------} 83 | 84 | infix 1 _⊢ᵍ_⦂_ 85 | data _⊢ᵍ_⦂_ : TyEnv → Term → Type → Set where 86 | 87 | ⊢ᵍ-nat : ∀{Γ} → ∀ n 88 | ----------------- 89 | → Γ ⊢ᵍ $ᵍ n ⦂ Nat 90 | 91 | ⊢ᵍ-var : ∀{Γ}{x}{A} 92 | → Γ ∋ x ⦂ trm A 93 | --------------- 94 | → Γ ⊢ᵍ ` x ⦂ A 95 | 96 | ⊢ᵍ-lam : ∀{Γ}{N}{A}{B} 97 | → Γ ⊢ A ok 98 | → trm A ∷ Γ ⊢ᵍ N ⦂ B 99 | ------------------- 100 | → Γ ⊢ᵍ λᵍ A N ⦂ A ⇒ B 101 | 102 | ⊢ᵍ-app : ∀{Γ}{L}{M}{A}{B}{A′} 103 | → Γ ⊢ᵍ L ⦂ A ⇒ B 104 | → Γ ⊢ᵍ M ⦂ A′ 105 | → [] ⊢ A′ ~ A 106 | ----------------- 107 | → Γ ⊢ᵍ L ˙ M ⦂ B 108 | 109 | ⊢ᵍ-app★ : ∀{Γ}{L}{M}{A} 110 | → Γ ⊢ᵍ L ⦂ ★ 111 | → Γ ⊢ᵍ M ⦂ A 112 | -------------- 113 | → Γ ⊢ᵍ L ˙ M ⦂ ★ 114 | 115 | ⊢ᵍ-tyabs : ∀{Γ}{V}{A} 116 | → Value V 117 | → typ ∷ Γ ⊢ᵍ V ⦂ A 118 | --------------- 119 | → Γ ⊢ᵍ Λᵍ V ⦂ ∀̇ A 120 | 121 | ⊢ᵍ-tyapp : ∀{Γ}{L}{A}{B} 122 | → Γ ⊢ᵍ L ⦂ ∀̇ A 123 | → Γ ⊢ B ok 124 | ------------------- 125 | → Γ ⊢ᵍ L ◎ B ⦂ A ⦗ B ⦘ 126 | 127 | ⊢ᵍ-tyapp★ : ∀{Γ}{L}{B} 128 | → Γ ⊢ᵍ L ⦂ ★ 129 | → Γ ⊢ B ok 130 | ------------- 131 | → Γ ⊢ᵍ L ◎ B ⦂ ★ 132 | 133 | -------------------------------------------------------------------------------- /Poly/PresBeta.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --allow-unsolved-metas #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresBeta where 13 | 14 | subst-pres : ∀ Γ N W A B 15 | → trm B ∷ Γ ⊢ N ⦂ A 16 | → Γ ⊢ W ⦂ B 17 | → Γ ⊢ N [ W ] ⦂ A 18 | subst-pres Γ N W A B ⊢N ⊢W = {!!} 19 | 20 | preservation-beta : ∀ {Γ}{N W : Term}{A : Type} 21 | → Γ ⊢ (ƛ N) · W ⦂ A 22 | → Γ ⊢ N [ W ] ⦂ A 23 | preservation-beta {Γ}{N}{W}{A} (⊢-app (⊢-lam{A = B}{B = A} ⊢B ⊢N) ⊢W) = 24 | subst-pres Γ N W A B ⊢N ⊢W 25 | 26 | 27 | -------------------------------------------------------------------------------- /Poly/PresCastFun.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --allow-unsolved-metas #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresCastFun where 13 | 14 | weaken-term-var : ∀ {Γ V A B} 15 | → Γ ⊢ V ⦂ A 16 | → trm B ∷ Γ ⊢ rename suc V ⦂ A 17 | weaken-term-var {Γ}{V}{A}{B} ⊢V = {!!} 18 | 19 | weaken-term-var-cast : ∀ {Γ c A B A′} 20 | → Γ ⊢ c ⦂ A ↝ A′ 21 | → trm B ∷ Γ ⊢ rename suc c ⦂ A ↝ A′ 22 | weaken-term-var-cast {Γ}{c}{A}{B}{A′} ⊢c = {!!} 23 | 24 | preservation-cast-fun : ∀ {Γ}{V : Term}{c d}{A : Type} 25 | → Γ ⊢ V ⟨ c ↪ d ⟩ ⦂ A 26 | → Γ ⊢ ƛ (((rename suc V) · (` 0 ⟨ (rename suc c) ⟩)) ⟨ (rename suc d) ⟩) ⦂ A 27 | preservation-cast-fun {Γ} {V} {c} {d} {.(_ ⇒ _)} (⊢-cast ⊢V (wt-fun ⊢c ⊢d)) = 28 | ⊢-lam {!!} (⊢-cast (⊢-app (weaken-term-var ⊢V) (⊢-cast (⊢-var trmZ) (weaken-term-var-cast ⊢c))) (weaken-term-var-cast ⊢d)) 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /Poly/PresCastInst.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --allow-unsolved-metas #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresCastInst where 13 | 14 | weaken-term : ∀ {Γ V A B} 15 | → Γ ⊢ V ⦂ A 16 | → bnd B ∷ Γ ⊢ rename suc V ⦂ (renameᵗ suc A) 17 | weaken-term {Γ}{V}{A}{B} ⊢V = {!!} 18 | 19 | preservation-cast-inst : ∀ {Γ}{V : Term}{c}{A : Type} 20 | → Γ ⊢ V ⟨ inst c ⟩ ⦂ A 21 | → Γ ⊢ (ν (rename suc V) 【 0 】 ⟨ c ⟩) ⦂ A 22 | preservation-cast-inst {Γ} {V} {c} {A} (⊢-cast ⊢V (wt-inst ⊢c)) = 23 | ⊢-ν (⊢-cast (⊢-tyapp (weaken-term ⊢V) bndZ) {!!}) 24 | 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /Poly/PresCastSeq.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresCastSeq where 13 | 14 | preservation-cast-seq : ∀ {Γ}{V : Term}{c d}{A : Type} 15 | → Γ ⊢ V ⟨ c ⍮ d ⟩ ⦂ A 16 | → Γ ⊢ V ⟨ c ⟩ ⟨ d ⟩ ⦂ A 17 | preservation-cast-seq {Γ} {V} {c} {d} {A} (⊢-cast ⊢V (wt-seq ⊢c ⊢d)) = ⊢-cast (⊢-cast ⊢V ⊢c) ⊢d 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /Poly/PresCollapse.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresCollapse where 13 | 14 | preservation-collapse : ∀ {Γ}{V : Term}{G}{A : Type} 15 | → Γ ⊢ V ⟨ G !! ⟩ ⟨ G ?? ⟩ ⦂ A 16 | → Γ ⊢ V ⦂ A 17 | preservation-collapse {Γ} {V} {G} {.(gnd⇒ty g2)} (⊢-cast (⊢-cast ⊢V (wt-inj g1)) (wt-proj g2)) 18 | rewrite unique-ground g1 g2 = ⊢V 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /Poly/PresGen.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --allow-unsolved-metas #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresGen where 13 | 14 | ty-ren-cast : ∀ Γ c α D C B 15 | → typ ∷ Γ ⊢ c ⦂ (⟪ renᵗ suc ⟫ᵗ D) ↝ C 16 | → Γ ∋ α ⦂ bnd B 17 | → Γ ⊢ c [ α ]ᵣ ⦂ D ↝ C ⦗ α ⦘ᵣ 18 | ty-ren-cast Γ c α D C B = {!!} 19 | 20 | preservation-gen : ∀ {Γ}{V : Term}{c}{α : Var}{A : Type} 21 | → Γ ⊢ V ⟨ gen c ⟩ 【 α 】 ⦂ A 22 | → Γ ⊢ V ⟨ c [ α ]ᵣ ⟩ ⦂ A 23 | preservation-gen {Γ}{V}{c}{α}{A} (⊢-tyapp{A = C}{B = B} (⊢-cast{A = D} ⊢V (wt-gen ⊢c)) ∋α) = 24 | ⊢-cast ⊢V (ty-ren-cast Γ c α D C B ⊢c ∋α) 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /Poly/PresReveal.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --allow-unsolved-metas #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresReveal where 13 | 14 | lookup-unique : ∀ {Γ α A B} 15 | → Γ ∋ α ⦂ bnd A 16 | → Γ ∋ α ⦂ bnd B 17 | → B ≡ A 18 | lookup-unique {Γ}{α}{A}{B} ∋α1 ∋α2 = {!!} 19 | 20 | preservation-reveal : ∀ {Γ}{V : Term}{α : Var}{A : Type} 21 | → Γ ⊢ V ⟨ ` α ↡ ⟩ ⟨ ` α ↟ ⟩ ⦂ A 22 | → Γ ⊢ V ⦂ A 23 | preservation-reveal {V}{α} (⊢-cast (⊢-cast ⊢V (wt-seal ∋α1)) (wt-unseal ∋α2)) 24 | rewrite lookup-unique ∋α1 ∋α2 = ⊢V 25 | 26 | -------------------------------------------------------------------------------- /Poly/PresTypeBeta.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --allow-unsolved-metas #-} 2 | 3 | open import Data.List using (List; []; _∷_; length) 4 | open import Data.Nat 5 | open import Data.Product using (_,_;_×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 6 | open import Relation.Binary.PropositionalEquality as Eq 7 | using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans) 8 | open Eq.≡-Reasoning 9 | open import Var using (Var) 10 | open import Poly.CastCalculus 11 | 12 | module Poly.PresTypeBeta where 13 | 14 | ty-ren-pres : ∀ Γ N A α B 15 | → typ ∷ Γ ⊢ N ⦂ A 16 | → Γ ∋ α ⦂ bnd B 17 | → Γ ⊢ N [ α ]ᵣ ⦂ A ⦗ α ⦘ᵣ 18 | ty-ren-pres Γ N A α B ⊢N ∋α = {!!} 19 | 20 | preservation-type-beta : ∀ {Γ}{N : Term}{α : Var}{A : Type} 21 | → Γ ⊢ (Λ N) 【 α 】 ⦂ A 22 | → Γ ⊢ N [ α ]ᵣ ⦂ A 23 | preservation-type-beta {Γ}{N}{α}{A} (⊢-tyapp{A = C}{B = B} (⊢-tyabs v ⊢V) ∋α) = 24 | ty-ren-pres Γ N C α B ⊢V ∋α 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /Poly/SetsAsPredicates.agda: -------------------------------------------------------------------------------- 1 | module Poly.SetsAsPredicates where 2 | 3 | open import Level renaming (zero to lzero) 4 | open import Data.Empty renaming (⊥ to False) 5 | open import Data.Product using (_×_; Σ; Σ-syntax; proj₁; proj₂) 6 | renaming (_,_ to ⟨_,_⟩) 7 | open import Data.Sum using (_⊎_; inj₁; inj₂) 8 | open import Relation.Binary.PropositionalEquality 9 | using (_≡_; _≢_; refl; sym; subst) 10 | open import Data.List using (List; []; _∷_; _++_) 11 | open import Data.List.Membership.Propositional renaming (_∈_ to _⋵_) 12 | open import Data.List.Relation.Unary.Any using (Any; here; there) 13 | open import Data.List.Relation.Unary.Any.Properties using (++⁺ˡ; ++⁺ʳ; ++⁻; ++↔) 14 | 15 | 𝒫 : Set → Set₁ 16 | 𝒫 V = V → Set 17 | 18 | ∅ : ∀{T} → 𝒫 T 19 | ∅ = λ v → False 20 | 21 | ⌈_⌉ : ∀ {T} → T → 𝒫 T {- the singleton set containing only v -} 22 | ⌈ v ⌉ w = w ≡ v 23 | 24 | infix 10 _∈_ 25 | _∈_ : ∀{T : Set} → T → 𝒫 T → Set 26 | v ∈ D = D v 27 | 28 | nonempty : ∀{T : Set} → 𝒫 T → Set 29 | nonempty{T} S = Σ[ x ∈ T ] x ∈ S 30 | 31 | infix 10 _⊆_ 32 | _⊆_ : ∀{T : Set} → 𝒫 T → 𝒫 T → Set 33 | D ⊆ E = ∀ d → d ∈ D → d ∈ E 34 | 35 | infix 9 _∪_ 36 | _∪_ : ∀{T : Set} → 𝒫 T → 𝒫 T → 𝒫 T 37 | (D ∪ E) d = d ∈ D ⊎ d ∈ E 38 | 39 | infix 9 _∩_ 40 | _∩_ : ∀{T : Set} → 𝒫 T → 𝒫 T → 𝒫 T 41 | (D ∩ E) d = d ∈ D × d ∈ E 42 | 43 | infix 6 _≃_ 44 | _≃_ : ∀{T : Set} → 𝒫 T → 𝒫 T → Set 45 | D₁ ≃ D₂ = D₁ ⊆ D₂ × D₂ ⊆ D₁ 46 | 47 | ≃-refl : ∀{T : Set}{D : 𝒫 T} → D ≃ D 48 | ≃-refl {D} = ⟨ (λ d z → z) , (λ d z → z) ⟩ 49 | 50 | ≃-reflexive : ∀{T : Set}{D₁ D₂ : 𝒫 T} → D₁ ≡ D₂ → D₁ ≃ D₂ 51 | ≃-reflexive refl = ⟨ (λ d z → z) , (λ d z → z) ⟩ 52 | 53 | ≃-sym : ∀{T : Set}{D₁ D₂ : 𝒫 T} → D₁ ≃ D₂ → D₂ ≃ D₁ 54 | ≃-sym ⟨ t , f ⟩ = ⟨ f , t ⟩ 55 | 56 | ≃-trans : ∀{T : Set}{D₁ D₂ D₃ : 𝒫 T} → D₁ ≃ D₂ → D₂ ≃ D₃ → D₁ ≃ D₃ 57 | ≃-trans ⟨ d12 , d21 ⟩ ⟨ d23 , d32 ⟩ = 58 | ⟨ (λ d z → d23 d (d12 d z)) , (λ d z → d21 d (d32 d z)) ⟩ 59 | 60 | module ≃-Reasoning where 61 | infixr 2 _≃⟨⟩_ 62 | _≃⟨⟩_ : ∀ {T : Set}(D₁ : 𝒫 T) {D₂ : 𝒫 T} → D₁ ≃ D₂ → D₁ ≃ D₂ 63 | D₁ ≃⟨⟩ D₁≃D₂ = D₁≃D₂ 64 | 65 | infixr 2 _≃⟨_⟩_ 66 | _≃⟨_⟩_ : ∀ {T : Set} (D₁ : 𝒫 T) {D₂ D₃ : 𝒫 T} → D₁ ≃ D₂ → D₂ ≃ D₃ → D₁ ≃ D₃ 67 | D₁ ≃⟨ D₁≃D₂ ⟩ D₂≃D₃ = ≃-trans D₁≃D₂ D₂≃D₃ 68 | 69 | infix 3 _∎ 70 | _∎ : ∀ {T : Set}(D : 𝒫 T) → D ≃ D 71 | D ∎ = ≃-refl 72 | 73 | 74 | {- Finite Sets represented by Lists -------------------------------------------} 75 | 76 | mem : ∀{T : Set} → List T → T → Set 77 | mem {T} ls x = x ⋵ ls 78 | 79 | mem++-⊆-∪ : ∀{T : Set} (t₁ t₂ : List T) → mem (t₁ ++ t₂) ⊆ (mem t₁ ∪ mem t₂) 80 | mem++-⊆-∪ {T} [] t₂ = λ d → inj₂ 81 | mem++-⊆-∪ {T} (x ∷ t₁) t₂ d (here refl) = inj₁ (here refl) 82 | mem++-⊆-∪ {T} (x ∷ t₁) t₂ d (there d∈) 83 | with ++⁻ {P = _≡_ d} t₁ d∈ 84 | ... | inj₁ xx = inj₁ (there xx) 85 | ... | inj₂ xx = inj₂ xx 86 | 87 | mem++-∪-⊆ : ∀{T : Set} (t₁ t₂ : List T) → (mem t₁ ∪ mem t₂) ⊆ mem (t₁ ++ t₂) 88 | mem++-∪-⊆ {T} [] t₂ d (inj₂ y) = y 89 | mem++-∪-⊆ {T} (x ∷ t₁) t₂ d (inj₁ (here refl)) = here refl 90 | mem++-∪-⊆ {T} (x ∷ t₁) t₂ d (inj₁ (there x₁)) = there (++⁺ˡ {P = _≡_ d} x₁) 91 | mem++-∪-⊆ {T} (x ∷ t₁) t₂ d (inj₂ y) = there (++⁺ʳ {P = _≡_ d} t₁ y) 92 | 93 | mem++-∪ : ∀{T : Set} (t₁ t₂ : List T) → mem (t₁ ++ t₂) ≃ (mem t₁ ∪ mem t₂) 94 | mem++-∪ {T} t₁ t₂ = ⟨ mem++-⊆-∪ t₁ t₂ , mem++-∪-⊆ t₁ t₂ ⟩ 95 | 96 | mem++-left : ∀{T : Set} (t₁ t₂ : List T) → mem t₁ ⊆ mem (t₁ ++ t₂) 97 | mem++-left {T} [] t₂ = λ d () 98 | mem++-left {T} (x ∷ t₁) t₂ .x (here refl) = here refl 99 | mem++-left {T} (x ∷ t₁) t₂ d (there y) = there (mem++-left t₁ t₂ d y) 100 | 101 | mem++-right : ∀{T : Set} (t₁ t₂ : List T) → mem t₂ ⊆ mem (t₁ ++ t₂) 102 | mem++-right {T} [] t₂ = λ d z → z 103 | mem++-right {T} (x ∷ t₁) t₂ d x₁ = there (mem++-right t₁ t₂ d x₁) 104 | 105 | E≢[]⇒nonempty-mem : ∀{T}{E : List T} 106 | → E ≢ [] → nonempty (mem E) 107 | E≢[]⇒nonempty-mem {T} {[]} E≢[] = ⊥-elim (E≢[] refl) 108 | E≢[]⇒nonempty-mem {T} {x ∷ E} E≢[] = ⟨ x , here refl ⟩ 109 | -------------------------------------------------------------------------------- /Pow2.agda: -------------------------------------------------------------------------------- 1 | module Pow2 where 2 | 3 | open import Data.Nat 4 | open import Data.Nat.Properties 5 | 6 | pow2 : ℕ → ℕ 7 | pow2 0 = 1 8 | pow2 (suc n) = 2 * pow2 n 9 | 10 | pow2-pos : ∀ n → 1 ≤ pow2 n 11 | pow2-pos zero = s≤s z≤n 12 | pow2-pos (suc n) = let IH = pow2-pos n in ≤-trans IH (m≤m+n _ _) 13 | 14 | pow2-mono-≤ : ∀{n m} → n ≤ m → pow2 n ≤ pow2 m 15 | pow2-mono-≤ {n}{m} z≤n = pow2-pos m 16 | pow2-mono-≤ (s≤s n≤m) = +-mono-≤ (pow2-mono-≤ n≤m) (+-mono-≤ (pow2-mono-≤ n≤m) z≤n) 17 | -------------------------------------------------------------------------------- /PreCastStructure.agda: -------------------------------------------------------------------------------- 1 | open import Types 2 | open import Labels 3 | open import Data.Sum using (_⊎_) 4 | open import Data.Product using (_×_; Σ; Σ-syntax) 5 | open import Data.Maybe using (Maybe) 6 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_) 7 | open import Relation.Nullary using (¬_) 8 | 9 | 10 | module PreCastStructure where 11 | 12 | record PreCastStruct : Set₁ where 13 | field 14 | Cast : Type → Set 15 | Inert : ∀{A} → Cast A → Set 16 | Active : ∀{A} → Cast A → Set 17 | ActiveOrInert : ∀{A} → (c : Cast A) → Active c ⊎ Inert c 18 | ActiveNotInert : ∀ {A} {c : Cast A} → Active c → ¬ Inert c 19 | Cross : ∀{A} → Cast A → Set 20 | Inert-Cross⇒ : ∀{A C D} → (c : Cast (A ⇒ (C ⇒ D))) → (i : Inert c) 21 | → Cross c × Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ ⇒ A₂ 22 | Inert-Cross× : ∀{A C D} → (c : Cast (A ⇒ (C `× D))) → (i : Inert c) 23 | → Cross c × Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ `× A₂ 24 | Inert-Cross⊎ : ∀{A C D} → (c : Cast (A ⇒ (C `⊎ D))) → (i : Inert c) 25 | → Cross c × Σ[ A₁ ∈ Type ] Σ[ A₂ ∈ Type ] A ≡ A₁ `⊎ A₂ 26 | dom : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ ⇒ A₂) ⇒ (A' ⇒ B'))) → .(Cross c) 27 | → Cast (A' ⇒ A₁) 28 | cod : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ ⇒ A₂) ⇒ (A' ⇒ B'))) → .(Cross c) 29 | → Cast (A₂ ⇒ B') 30 | fstC : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `× A₂) ⇒ (A' `× B'))) → .(Cross c) 31 | → Cast (A₁ ⇒ A') 32 | sndC : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `× A₂) ⇒ (A' `× B'))) → .(Cross c) 33 | → Cast (A₂ ⇒ B') 34 | inlC : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `⊎ A₂) ⇒ (A' `⊎ B'))) → .(Cross c) 35 | → Cast (A₁ ⇒ A') 36 | inrC : ∀{A₁ A₂ A' B'} → (c : Cast ((A₁ `⊎ A₂) ⇒ (A' `⊎ B'))) → .(Cross c) 37 | → Cast (A₂ ⇒ B') 38 | baseNotInert : ∀ {A ι} → (c : Cast (A ⇒ ` ι)) → ¬ Inert c 39 | idNotInert : ∀ {A} → Atomic A → (c : Cast (A ⇒ A)) → ¬ Inert c 40 | projNotInert : ∀ {B} → B ≢ ⋆ → (c : Cast (⋆ ⇒ B)) → ¬ Inert c 41 | InertNotRel : ∀{A}{c : Cast A} (i1 : Inert c)(i2 : Inert c) → i1 ≡ i2 42 | ActiveNotRel : ∀{A}{c : Cast A} (a1 : Active c) (a2 : Active c) → a1 ≡ a2 43 | -------------------------------------------------------------------------------- /PreCastStructureWithBlameSafety.agda: -------------------------------------------------------------------------------- 1 | open import Relation.Nullary using (¬_; Dec; yes; no) 2 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_) 3 | open import Data.Product using (_×_; Σ; Σ-syntax) 4 | 5 | open import Types 6 | open import Labels 7 | open import PreCastStructure 8 | 9 | 10 | module PreCastStructureWithBlameSafety where 11 | 12 | record PreCastStructWithBlameSafety : Set₁ where 13 | field 14 | precast : PreCastStruct 15 | open PreCastStruct precast public 16 | field 17 | {- ****** The fields below are for blame-subtyping: ****** -} 18 | CastBlameSafe : ∀ {A} → Cast A → Label → Set 19 | domBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 20 | → CastBlameSafe (dom c x) ℓ 21 | codBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 22 | → CastBlameSafe (cod c x) ℓ 23 | fstBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 24 | → CastBlameSafe (fstC c x) ℓ 25 | sndBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 26 | → CastBlameSafe (sndC c x) ℓ 27 | inlBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 28 | → CastBlameSafe (inlC c x) ℓ 29 | inrBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 30 | → CastBlameSafe (inrC c x) ℓ 31 | -------------------------------------------------------------------------------- /PreCastStructureWithPrecision.agda: -------------------------------------------------------------------------------- 1 | open import Relation.Nullary using (¬_; Dec; yes; no) 2 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_) 3 | open import Data.Product using (_×_; Σ; Σ-syntax) 4 | 5 | open import Types 6 | open import Labels 7 | open import PreCastStructure 8 | 9 | 10 | module PreCastStructureWithPrecision where 11 | 12 | {- This record contains precision relations and corresponding lemmas. -} 13 | record PreCastStructWithPrecision : Set₁ where 14 | field 15 | precast : PreCastStruct 16 | open PreCastStruct precast public 17 | infix 6 ⟪_⟫⊑⟪_⟫ 18 | infix 6 ⟪_⟫⊑_ 19 | infix 6 _⊑⟪_⟫ 20 | field 21 | {- ****** Precision relations of (inert) casts: ****** -} 22 | ⟪_⟫⊑⟪_⟫ : ∀ {A A′ B B′} → {c : Cast (A ⇒ B)} → {c′ : Cast (A′ ⇒ B′)} 23 | → (i : Inert c) → (i′ : Inert c′) → Set 24 | ⟪_⟫⊑_ : ∀ {A B} → {c : Cast (A ⇒ B)} → Inert c → Type → Set 25 | _⊑⟪_⟫ : ∀ {A′ B′} → {c′ : Cast (A′ ⇒ B′)} → Type → Inert c′ → Set 26 | 27 | {- ****** The definitions above need to satisfy the following lemmas: ****** -} 28 | {- If an inert injection is less precise than another inert cast, 29 | the latter must also be an injection from the same type. -} 30 | {- 31 | inj-⊑-inj : ∀ {A A′ B′} {c : Cast (A ⇒ ⋆)} {c′ : Cast (A′ ⇒ B′)} 32 | → (i : Inert c) → (i′ : Inert c′) 33 | → ⟪ i ⟫⊑⟪ i′ ⟫ 34 | -------------------- 35 | → (A′ ≡ A) × (B′ ≡ ⋆) 36 | -} 37 | {- Dynamic type ⋆ is never less precise than any inert cast. -} 38 | {- 39 | ⋆-⋢-inert : ∀ {A′ B′} {c′ : Cast (A′ ⇒ B′)} 40 | → (i′ : Inert c′) 41 | ---------------- 42 | → ¬ (⋆ ⊑⟪ i′ ⟫) 43 | -} 44 | {- Lemmas about precision, suppose all casts are inert: 45 | 1. It implies ⟨ A ⇒ B ⟩ ⊑ A′ if A ⊑ A′ and B ⊑ B′. -} 46 | ⊑→lpit : ∀ {A B A′} {c : Cast (A ⇒ B)} 47 | → (i : Inert c) → A ⊑ A′ → B ⊑ A′ → ⟪ i ⟫⊑ A′ 48 | {- 2. It implies A ⊑ A′ and B ⊑ B′ if ⟨ A ⇒ B ⟩ ⊑ ⟨ A′ ⇒ B′ ⟩ . -} 49 | lpii→⊑ : ∀ {A A′ B B′} {c : Cast (A ⇒ B)} {c′ : Cast (A′ ⇒ B′)} {i : Inert c} {i′ : Inert c′} 50 | → ⟪ i ⟫⊑⟪ i′ ⟫ → (A ⊑ A′) × (B ⊑ B′) 51 | {- 3. It implies A ⊑ A′ and B ⊑ A′ if ⟨ A ⇒ B ⟩ ⊑ A′ . -} 52 | lpit→⊑ : ∀ {A A′ B} {c : Cast (A ⇒ B)} {i : Inert c} 53 | → ⟪ i ⟫⊑ A′ → (A ⊑ A′) × (B ⊑ A′) 54 | {- 4. It implies A ⊑ A′ and A ⊑ B′ if A ⊑ ⟨ A′ ⇒ B′ ⟩ . -} 55 | lpti→⊑ : ∀ {A A′ B′} {c′ : Cast (A′ ⇒ B′)} {i′ : Inert c′} 56 | → A ⊑⟪ i′ ⟫ → (A ⊑ A′) × (A ⊑ B′) 57 | -------------------------------------------------------------------------------- /PrimitiveTypes.agda: -------------------------------------------------------------------------------- 1 | import Relation.Binary.PropositionalEquality as Eq 2 | open Eq using (_≡_; refl; sym; cong; cong₂; cong-app) 3 | open import Relation.Nullary using (¬_; Dec; yes; no) 4 | 5 | module PrimitiveTypes where 6 | 7 | open import Data.Bool using (Bool) renaming (_≟_ to _=?_) 8 | open import Data.Nat using (ℕ; _≟_) 9 | open import Data.Integer using (ℤ) renaming (_≟_ to _=int_) 10 | open import Data.Unit using (tt) renaming (⊤ to Top) 11 | open import Data.Empty using () renaming (⊥ to Bot) 12 | open import Labels 13 | 14 | data Base : Set where 15 | Nat : Base 16 | Int : Base 17 | 𝔹 : Base 18 | Unit : Base 19 | 20 | data Prim : Set where 21 | base : Base → Prim 22 | _⇒_ : Base → Prim → Prim 23 | 24 | base-rep : Base → Set 25 | base-rep Nat = ℕ 26 | base-rep Int = ℤ 27 | base-rep 𝔹 = Bool 28 | base-rep Unit = Top 29 | 30 | rep : Prim → Set 31 | rep (base b) = base-rep b 32 | rep (b ⇒ p) = base-rep b → rep p 33 | 34 | base-eq? : (B : Base) → (B' : Base) → Dec (B ≡ B') 35 | base-eq? Nat Nat = yes refl 36 | base-eq? Nat Int = no (λ ()) 37 | base-eq? Nat 𝔹 = no (λ ()) 38 | base-eq? Nat Unit = no (λ ()) 39 | base-eq? Int Nat = no (λ ()) 40 | base-eq? Int Int = yes refl 41 | base-eq? Int 𝔹 = no (λ ()) 42 | base-eq? Int Unit = no (λ ()) 43 | base-eq? 𝔹 Nat = no (λ ()) 44 | base-eq? 𝔹 Int = no (λ ()) 45 | base-eq? 𝔹 𝔹 = yes refl 46 | base-eq? 𝔹 Unit = no (λ ()) 47 | base-eq? Unit Nat = no (λ ()) 48 | base-eq? Unit Int = no (λ ()) 49 | base-eq? Unit 𝔹 = no (λ ()) 50 | base-eq? Unit Unit = yes refl 51 | 52 | base-rep-eq? : ∀{B} → (k : base-rep B) (k′ : base-rep B) → Dec (k ≡ k′) 53 | base-rep-eq? {Nat} k k′ = k ≟ k′ 54 | base-rep-eq? {Int} k k′ = k =int k′ 55 | base-rep-eq? {𝔹} k k′ = k =? k′ 56 | base-rep-eq? {Unit} tt tt = yes refl 57 | 58 | -------------------------------------------------------------------------------- /RawLogRel/BindLemma.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module RawLogRel.BindLemma where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Nat 6 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 7 | open import Data.Nat.Properties 8 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 9 | open import Data.Unit using (⊤; tt) 10 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | open import Data.Sum using (_⊎_; inj₁; inj₂) 13 | open import Relation.Binary.PropositionalEquality as Eq 14 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 15 | open import Relation.Nullary using (¬_; Dec; yes; no) 16 | open import Var 17 | open import InjProj.CastCalculus 18 | open import InjProj.CastDeterministic 19 | open import StepIndexedLogic 20 | open import InjProj.CastSafe 21 | open import RawLogRel.LogRel 22 | 23 | {- formulation of ℰ-bind with explicit step-indexing, a la Max New -} 24 | 25 | 𝒱→ℰ-down-one-≺ : ∀{c}{d}{F}{F′}{i}{M}{N}{M′} 26 | → M —→ N 27 | → (∀ j V V′ → j ≤ suc i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 28 | → # (𝒱⟦ d ⟧ ≺ V V′) j 29 | → # (ℰ⟦ c ⟧ ≺ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 30 | → (∀ j V V′ → j ≤ i → N —↠ V → Value V → M′ —↠ V′ → Value V′ 31 | → # (𝒱⟦ d ⟧ ≺ V V′) j 32 | → # (ℰ⟦ c ⟧ ≺ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 33 | 𝒱→ℰ-down-one-≺ {c}{d}{F}{F′}{i}{M}{N}{M′} M→N 𝒱→ℰsi 34 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 35 | 𝒱→ℰsi j V V′ (≤-trans j≤i (n≤1+n i)) (M —→⟨ M→N ⟩ M→V) v M′→V′ v′ 𝒱j 36 | 37 | 𝒱→ℰ-down-one-≻ : ∀{c}{d}{F}{F′}{i}{M}{M′}{N′} 38 | → M′ —→ N′ 39 | → (∀ j V V′ → j ≤ suc i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 40 | → # (𝒱⟦ d ⟧ ≻ V V′) j 41 | → # (ℰ⟦ c ⟧ ≻ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 42 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → N′ —↠ V′ → Value V′ 43 | → # (𝒱⟦ d ⟧ ≻ V V′) j 44 | → # (ℰ⟦ c ⟧ ≻ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 45 | 𝒱→ℰ-down-one-≻ {c}{d}{F}{F′}{i}{M}{N}{M′} M′→N′ 𝒱→ℰsi 46 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 47 | 𝒱→ℰsi j V V′ (≤-trans j≤i (n≤1+n i)) M→V v (N —→⟨ M′→N′ ⟩ M′→V′) v′ 𝒱j 48 | 49 | ℰ-bind-step : ∀{c}{d}{F}{F′}{M}{M′}{i}{dir} 50 | → #(ℰ⟦ d ⟧ dir M M′) i 51 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 52 | → #(𝒱⟦ d ⟧ dir V V′) j 53 | → #(ℰ⟦ c ⟧ dir (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 54 | → #(ℰ⟦ c ⟧ dir (F ⦉ M ⦊) (F′ ⦉ M′ ⦊)) i 55 | ℰ-bind-step {c}{d} {F} {F′} {M} {M′} {zero} {dir} ℰMM′sz 𝒱→ℰj = 56 | tz (ℰ⟦ c ⟧ dir (F ⦉ M ⦊) (F′ ⦉ M′ ⦊)) 57 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 58 | with ⇔-to (ℰ-suc{d}{≺}) ℰMM′si 59 | ... | inj₁ (N , M→N , ▷ℰNM′) = 60 | let IH = ℰ-bind-step{c}{d}{F}{F′}{N}{M′}{i}{≺} ▷ℰNM′ 61 | (𝒱→ℰ-down-one-≺{c}{d}{F}{F′}{i}{M}{N}{M′} M→N 𝒱→ℰj) in 62 | ⇔-fro (ℰ-suc{c}{≺}) (inj₁ ((F ⦉ N ⦊) , ξ′ F refl refl M→N , IH)) 63 | ... | inj₂ (inj₂ (m , inj₁ M′→blame)) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 64 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 65 | | inj₂ (inj₂ (m , inj₂ (V′ , M′→V′ , v′ , 𝒱MV′))) = 66 | let ℰFMF′V′ = 𝒱→ℰj (suc i) M V′ ≤-refl (M END) m M′→V′ v′ 𝒱MV′ in 67 | anti-reduction-≺-R ℰFMF′V′ (ξ′* F′ M′→V′) 68 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 69 | | inj₂ (inj₁ M′→blame) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 70 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≻} ℰMM′si 𝒱→ℰj 71 | with ⇔-to (ℰ-suc{d}{≻}) ℰMM′si 72 | ... | inj₁ (N′ , M′→N′ , ▷ℰMN′) = 73 | let ℰFMFN′ : # (ℰ⟦ c ⟧ ≻ (F ⦉ M ⦊) (F′ ⦉ N′ ⦊)) i 74 | ℰFMFN′ = ℰ-bind-step{c}{d}{F}{F′}{M}{N′}{i}{≻} ▷ℰMN′ 75 | (𝒱→ℰ-down-one-≻{c}{d}{F}{F′} M′→N′ 𝒱→ℰj) in 76 | inj₁ ((F′ ⦉ N′ ⦊) , (ξ′ F′ refl refl M′→N′) , ℰFMFN′) 77 | ... | inj₂ (inj₁ isBlame) 78 | with F′ 79 | ... | □ = inj₂ (inj₁ isBlame) 80 | ... | ` F″ = inj₁ (blame , ξ-blame F″ , ℰ-blame-step{c}{≻}) 81 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≻} ℰMM′si 𝒱→ℰj 82 | | inj₂ (inj₂ (m′ , V , M→V , v , 𝒱VM′)) = 83 | let xx = 𝒱→ℰj (suc i) V M′ ≤-refl M→V v (M′ END) m′ 𝒱VM′ in 84 | anti-reduction-≻-L xx (ξ′* F M→V) 85 | -------------------------------------------------------------------------------- /RawLogRel/BindLemma.agda~: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRelLogic.BindLemma where 3 | 4 | open import Data.List using (List; []; _∷_; length; map) 5 | open import Data.Nat 6 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 7 | open import Data.Nat.Properties 8 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 9 | open import Data.Unit using (⊤; tt) 10 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 11 | open import Data.Empty using (⊥; ⊥-elim) 12 | open import Data.Sum using (_⊎_; inj₁; inj₂) 13 | open import Relation.Binary.PropositionalEquality as Eq 14 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 15 | open import Relation.Nullary using (¬_; Dec; yes; no) 16 | open import Var 17 | open import InjProj.CastCalculus 18 | open import InjProj.CastDeterministic 19 | open import StepIndexedLogic 20 | open import InjProj.CastSafe 21 | open import LogRelLogic.LogRel 22 | 23 | {- formulation of ℰ-bind with explicit step-indexing, a la Max New -} 24 | 25 | 𝒱→ℰ-down-one-≺ : ∀{c}{d}{F}{F′}{i}{M}{N}{M′} 26 | → M —→ N 27 | → (∀ j V V′ → j ≤ suc i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 28 | → # (𝒱⟦ d ⟧ ≺ V V′) j 29 | → # (ℰ⟦ c ⟧ ≺ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 30 | → (∀ j V V′ → j ≤ i → N —↠ V → Value V → M′ —↠ V′ → Value V′ 31 | → # (𝒱⟦ d ⟧ ≺ V V′) j 32 | → # (ℰ⟦ c ⟧ ≺ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 33 | 𝒱→ℰ-down-one-≺ {c}{d}{F}{F′}{i}{M}{N}{M′} M→N 𝒱→ℰsi 34 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 35 | 𝒱→ℰsi j V V′ (≤-trans j≤i (n≤1+n i)) (M —→⟨ M→N ⟩ M→V) v M′→V′ v′ 𝒱j 36 | 37 | 𝒱→ℰ-down-one-≻ : ∀{c}{d}{F}{F′}{i}{M}{M′}{N′} 38 | → M′ —→ N′ 39 | → (∀ j V V′ → j ≤ suc i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 40 | → # (𝒱⟦ d ⟧ ≻ V V′) j 41 | → # (ℰ⟦ c ⟧ ≻ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 42 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → N′ —↠ V′ → Value V′ 43 | → # (𝒱⟦ d ⟧ ≻ V V′) j 44 | → # (ℰ⟦ c ⟧ ≻ (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 45 | 𝒱→ℰ-down-one-≻ {c}{d}{F}{F′}{i}{M}{N}{M′} M′→N′ 𝒱→ℰsi 46 | j V V′ j≤i M→V v M′→V′ v′ 𝒱j = 47 | 𝒱→ℰsi j V V′ (≤-trans j≤i (n≤1+n i)) M→V v (N —→⟨ M′→N′ ⟩ M′→V′) v′ 𝒱j 48 | 49 | ℰ-bind-step : ∀{c}{d}{F}{F′}{M}{M′}{i}{dir} 50 | → #(ℰ⟦ d ⟧ dir M M′) i 51 | → (∀ j V V′ → j ≤ i → M —↠ V → Value V → M′ —↠ V′ → Value V′ 52 | → #(𝒱⟦ d ⟧ dir V V′) j 53 | → #(ℰ⟦ c ⟧ dir (F ⦉ V ⦊) (F′ ⦉ V′ ⦊)) j) 54 | → #(ℰ⟦ c ⟧ dir (F ⦉ M ⦊) (F′ ⦉ M′ ⦊)) i 55 | ℰ-bind-step {c}{d} {F} {F′} {M} {M′} {zero} {dir} ℰMM′sz 𝒱→ℰj = 56 | tz (ℰ⟦ c ⟧ dir (F ⦉ M ⦊) (F′ ⦉ M′ ⦊)) 57 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 58 | with ⇔-to (ℰ-suc{d}{≺}) ℰMM′si 59 | ... | inj₁ (N , M→N , ▷ℰNM′) = 60 | let IH = ℰ-bind-step{c}{d}{F}{F′}{N}{M′}{i}{≺} ▷ℰNM′ 61 | (𝒱→ℰ-down-one-≺{c}{d}{F}{F′}{i}{M}{N}{M′} M→N 𝒱→ℰj) in 62 | ⇔-fro (ℰ-suc{c}{≺}) (inj₁ ((F ⦉ N ⦊) , ξ′ F refl refl M→N , IH)) 63 | ... | inj₂ (inj₂ (m , inj₁ M′→blame)) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 64 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 65 | | inj₂ (inj₂ (m , inj₂ (V′ , M′→V′ , v′ , 𝒱MV′))) = 66 | let ℰFMF′V′ = 𝒱→ℰj (suc i) M V′ ≤-refl (M END) m M′→V′ v′ 𝒱MV′ in 67 | anti-reduction-≺-R ℰFMF′V′ (ξ′* F′ M′→V′) 68 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≺} ℰMM′si 𝒱→ℰj 69 | | inj₂ (inj₁ M′→blame) = inj₂ (inj₁ (ξ-blame₃ F′ M′→blame refl)) 70 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≻} ℰMM′si 𝒱→ℰj 71 | with ⇔-to (ℰ-suc{d}{≻}) ℰMM′si 72 | ... | inj₁ (N′ , M′→N′ , ▷ℰMN′) = 73 | let ℰFMFN′ : # (ℰ⟦ c ⟧ ≻ (F ⦉ M ⦊) (F′ ⦉ N′ ⦊)) i 74 | ℰFMFN′ = ℰ-bind-step{c}{d}{F}{F′}{M}{N′}{i}{≻} ▷ℰMN′ 75 | (𝒱→ℰ-down-one-≻{c}{d}{F}{F′} M′→N′ 𝒱→ℰj) in 76 | inj₁ ((F′ ⦉ N′ ⦊) , (ξ′ F′ refl refl M′→N′) , ℰFMFN′) 77 | ... | inj₂ (inj₁ isBlame) 78 | with F′ 79 | ... | □ = inj₂ (inj₁ isBlame) 80 | ... | ` F″ = inj₁ (blame , ξ-blame F″ , ℰ-blame-step{c}{≻}) 81 | ℰ-bind-step {c}{d}{F}{F′}{M}{M′}{suc i}{≻} ℰMM′si 𝒱→ℰj 82 | | inj₂ (inj₂ (m′ , V , M→V , v , 𝒱VM′)) = 83 | let xx = 𝒱→ℰj (suc i) V M′ ≤-refl M→V v (M′ END) m′ 𝒱VM′ in 84 | anti-reduction-≻-L xx (ξ′* F M→V) 85 | -------------------------------------------------------------------------------- /RawLogRel/GradualGuarantee.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module RawLogRel.GradualGuarantee where 3 | 4 | {- 5 | 6 | This is a proof of the gradual guarantee using 7 | step-indexed logical relations by Jeremy Siek, Phil Wadler, and Peter 8 | Thiemann. 9 | 10 | The proof technique and definitions are a mixture of those used 11 | by Max New in his thesis (Chapter 10) and 12 | by Dreyer, Ahmed, and Birkedal in "Logical Step-Indexed Logical Relations". 13 | 14 | -} 15 | 16 | open import Data.List using (List; []; _∷_; length; map) 17 | open import Data.Nat 18 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 19 | open import Data.Nat.Properties 20 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 21 | open import Data.Unit using (⊤; tt) 22 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 23 | open import Data.Empty using (⊥; ⊥-elim) 24 | open import Data.Sum using (_⊎_; inj₁; inj₂) 25 | open import Relation.Binary.PropositionalEquality as Eq 26 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 27 | open import Relation.Nullary using (¬_; Dec; yes; no) 28 | open import Var 29 | open import InjProj.CastCalculus 30 | open import InjProj.Precision 31 | open import StepIndexedLogic 32 | open import RawLogRel.LogRel 33 | open import RawLogRel.CompatibilityLemmas 34 | 35 | fundamental : ∀ {Γ}{A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 36 | → Γ ⊩ M ⊑ M′ ⦂ A⊑A′ 37 | ---------------------------- 38 | → Γ ⊨ M ⊑ M′ ⦂ (A , A′ , A⊑A′) 39 | fundamental {Γ} {A} {A′} {A⊑A′} .(` _) .(` _) (⊑-var ∋x) = 40 | compatibility-var ∋x 41 | fundamental {Γ} {_} {_} {base⊑} ($ (Num n)) ($ (Num n)) ⊑-lit = 42 | compatible-nat 43 | fundamental {Γ} {_} {_} {base⊑} ($ (Bool b)) ($ (Bool b)) ⊑-lit = 44 | compatible-bool 45 | fundamental {Γ} {A} {A′} {A⊑A′} (L · M) (L′ · M′) (⊑-app ⊢L⊑L′ ⊢M⊑M′) = 46 | compatible-app{L = L}{L′}{M}{M′} (fundamental L L′ ⊢L⊑L′) 47 | (fundamental M M′ ⊢M⊑M′) 48 | fundamental {Γ} {.(_ ⇒ _)} {.(_ ⇒ _)} {.(fun⊑ _ _)} (ƛ N)(ƛ N′) (⊑-lam ⊢N⊑N′) = 49 | compatible-lambda{N = N}{N′} (fundamental N N′ ⊢N⊑N′) 50 | fundamental {Γ} {★} {A′} {unk⊑ c} (M ⟨ G !⟩) M′ (⊑-inj-L ⊢M⊑M′) = 51 | compatible-inj-L{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 52 | fundamental {Γ} {★} {★} {.unk⊑unk} M (M′ ⟨ G !⟩) (⊑-inj-R ⊢M⊑M′) = 53 | compatible-inj-R{Γ}{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 54 | fundamental {Γ} {_} {A′} {A⊑A′} (M ⟨ H ?⟩) M′ (⊑-proj-L ⊢M⊑M′) = 55 | compatible-proj-L{Γ}{H}{A′}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 56 | fundamental {Γ} {A} {.(gnd⇒ty _)} {A⊑A′} M (M′ ⟨ H′ ?⟩) (⊑-proj-R ⊢M⊑M′) = 57 | compatible-proj-R{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 58 | fundamental {Γ} {A} {.A} {.Refl⊑} M .blame (⊑-blame ⊢M∶A) = 59 | compatible-blame ⊢M∶A 60 | 61 | gradual-guarantee : ∀ {A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 62 | → [] ⊩ M ⊑ M′ ⦂ A⊑A′ 63 | ------------------ 64 | → ⊨ M ⊑ M′ 65 | gradual-guarantee {A}{A′}{A⊑A′} M M′ M⊑M′ = 66 | let (⊨≺M⊑M′ , ⊨≻M⊑M′) = fundamental M M′ M⊑M′ in 67 | let ℰ≺MM′ = ⊨≺M⊑M′ id id in 68 | let ℰ≻MM′ = ⊨≻M⊑M′ id id in 69 | ℰ≺≻⇒GG ℰ≺MM′ ℰ≻MM′ 70 | -------------------------------------------------------------------------------- /RawLogRel/GradualGuarantee.agda~: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | module LogRelLogic.GradualGuarantee where 3 | 4 | {- 5 | 6 | This is a proof of the gradual guarantee using 7 | step-indexed logical relations by Jeremy Siek, Phil Wadler, and Peter 8 | Thiemann. 9 | 10 | The proof technique and definitions are a mixture of those used 11 | by Max New in his thesis (Chapter 10) and 12 | by Dreyer, Ahmed, and Birkedal in "Logical Step-Indexed Logical Relations". 13 | 14 | -} 15 | 16 | open import Data.List using (List; []; _∷_; length; map) 17 | open import Data.Nat 18 | open import Data.Bool using (true; false) renaming (Bool to 𝔹) 19 | open import Data.Nat.Properties 20 | open import Data.Product using (_,_; _×_; proj₁; proj₂; Σ-syntax; ∃-syntax) 21 | open import Data.Unit using (⊤; tt) 22 | open import Data.Unit.Polymorphic renaming (⊤ to topᵖ; tt to ttᵖ) 23 | open import Data.Empty using (⊥; ⊥-elim) 24 | open import Data.Sum using (_⊎_; inj₁; inj₂) 25 | open import Relation.Binary.PropositionalEquality as Eq 26 | using (_≡_; _≢_; refl; sym; cong; subst; trans) 27 | open import Relation.Nullary using (¬_; Dec; yes; no) 28 | open import Var 29 | open import InjProj.CastCalculus 30 | open import InjProj.Precision 31 | open import StepIndexedLogic 32 | open import LogRelLogic.LogRel 33 | open import LogRelLogic.CompatibilityLemmas 34 | 35 | fundamental : ∀ {Γ}{A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 36 | → Γ ⊩ M ⊑ M′ ⦂ A⊑A′ 37 | ---------------------------- 38 | → Γ ⊨ M ⊑ M′ ⦂ (A , A′ , A⊑A′) 39 | fundamental {Γ} {A} {A′} {A⊑A′} .(` _) .(` _) (⊑-var ∋x) = 40 | compatibility-var ∋x 41 | fundamental {Γ} {_} {_} {base⊑} ($ (Num n)) ($ (Num n)) ⊑-lit = 42 | compatible-nat 43 | fundamental {Γ} {_} {_} {base⊑} ($ (Bool b)) ($ (Bool b)) ⊑-lit = 44 | compatible-bool 45 | fundamental {Γ} {A} {A′} {A⊑A′} (L · M) (L′ · M′) (⊑-app ⊢L⊑L′ ⊢M⊑M′) = 46 | compatible-app{L = L}{L′}{M}{M′} (fundamental L L′ ⊢L⊑L′) 47 | (fundamental M M′ ⊢M⊑M′) 48 | fundamental {Γ} {.(_ ⇒ _)} {.(_ ⇒ _)} {.(fun⊑ _ _)} (ƛ N)(ƛ N′) (⊑-lam ⊢N⊑N′) = 49 | compatible-lambda{N = N}{N′} (fundamental N N′ ⊢N⊑N′) 50 | fundamental {Γ} {★} {A′} {unk⊑ c} (M ⟨ G !⟩) M′ (⊑-inj-L ⊢M⊑M′) = 51 | compatible-inj-L{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 52 | fundamental {Γ} {★} {★} {.unk⊑unk} M (M′ ⟨ G !⟩) (⊑-inj-R ⊢M⊑M′) = 53 | compatible-inj-R{Γ}{G = G}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 54 | fundamental {Γ} {_} {A′} {A⊑A′} (M ⟨ H ?⟩) M′ (⊑-proj-L ⊢M⊑M′) = 55 | compatible-proj-L{Γ}{H}{A′}{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 56 | fundamental {Γ} {A} {.(gnd⇒ty _)} {A⊑A′} M (M′ ⟨ H′ ?⟩) (⊑-proj-R ⊢M⊑M′) = 57 | compatible-proj-R{M = M}{M′} (fundamental M M′ ⊢M⊑M′) 58 | fundamental {Γ} {A} {.A} {.Refl⊑} M .blame (⊑-blame ⊢M∶A) = 59 | compatible-blame ⊢M∶A 60 | 61 | gradual-guarantee : ∀ {A}{A′}{A⊑A′ : A ⊑ A′} → (M M′ : Term) 62 | → [] ⊩ M ⊑ M′ ⦂ A⊑A′ 63 | ------------------ 64 | → ⊨ M ⊑ M′ 65 | gradual-guarantee {A}{A′}{A⊑A′} M M′ M⊑M′ = 66 | let (⊨≺M⊑M′ , ⊨≻M⊑M′) = fundamental M M′ M⊑M′ in 67 | let ℰ≺MM′ = ⊨≺M⊑M′ id id in 68 | let ℰ≻MM′ = ⊨≻M⊑M′ id id in 69 | ℰ≺≻⇒GG ℰ≺MM′ ℰ≻MM′ 70 | -------------------------------------------------------------------------------- /SimpleCoercionsBlame.agda: -------------------------------------------------------------------------------- 1 | module SimpleCoercionsBlame where 2 | 3 | open import Data.Nat 4 | open import Data.Bool 5 | open import Relation.Nullary using (¬_; Dec; yes; no) 6 | open import Relation.Nullary.Negation using (contradiction) 7 | open import Relation.Binary.PropositionalEquality 8 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 9 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 10 | renaming (_,_ to ⟨_,_⟩) 11 | open import Data.Sum using (_⊎_; inj₁; inj₂) 12 | open import Data.Empty using (⊥; ⊥-elim) 13 | open import Data.Empty.Irrelevant renaming (⊥-elim to ⊥-elimi) 14 | 15 | open import Types 16 | open import Variables 17 | open import Labels 18 | open import SimpleCoercions 19 | 20 | data CastBlameSafe : ∀ {A} → Cast A → Label → Set where 21 | 22 | safe-id : ∀ {A} {a : Atomic A} {ℓ} 23 | → CastBlameSafe (id {A} {a}) ℓ 24 | 25 | safe-inj : ∀ {A} {i : A ≢ ⋆} {ℓ} 26 | → CastBlameSafe (inj A {i}) ℓ 27 | 28 | safe-proj : ∀ {B} {j : B ≢ ⋆} {ℓ ℓ′} 29 | → ℓ ≢̂ ℓ′ 30 | → CastBlameSafe (proj B ℓ′ {j}) ℓ 31 | 32 | safe-cfun : ∀ {S₁ S₂ T₁ T₂} {c : Cast (T₁ ⇒ S₁)} {d : Cast (S₂ ⇒ T₂)} {ℓ} 33 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 34 | → CastBlameSafe (cfun c d) ℓ 35 | 36 | safe-cpair : ∀ {S₁ S₂ T₁ T₂} {c : Cast (S₁ ⇒ T₁)} {d : Cast (S₂ ⇒ T₂)} {ℓ} 37 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 38 | → CastBlameSafe (cpair c d) ℓ 39 | 40 | safe-csum : ∀ {S₁ S₂ T₁ T₂} {c : Cast (S₁ ⇒ T₁)} {d : Cast (S₂ ⇒ T₂)} {ℓ} 41 | → CastBlameSafe c ℓ → CastBlameSafe d ℓ 42 | → CastBlameSafe (csum c d) ℓ 43 | 44 | domBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 45 | → CastBlameSafe (dom c x) ℓ 46 | domBlameSafe (safe-cfun safe-c safe-d) x = safe-c 47 | 48 | codBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 49 | → CastBlameSafe (cod c x) ℓ 50 | codBlameSafe (safe-cfun safe-c safe-d) x = safe-d 51 | 52 | fstBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 53 | → CastBlameSafe (fstC c x) ℓ 54 | fstBlameSafe (safe-cpair safe-c safe-d) x = safe-c 55 | 56 | sndBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 57 | → CastBlameSafe (sndC c x) ℓ 58 | sndBlameSafe (safe-cpair safe-c safe-d) x = safe-d 59 | 60 | inlBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 61 | → CastBlameSafe (inlC c x) ℓ 62 | inlBlameSafe (safe-csum safe-c safe-d) x = safe-c 63 | 64 | inrBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 65 | → CastBlameSafe (inrC c x) ℓ 66 | inrBlameSafe (safe-csum safe-c safe-d) x = safe-d 67 | 68 | open import PreCastStructureWithBlameSafety 69 | 70 | pcss : PreCastStructWithBlameSafety 71 | pcss = record 72 | { precast = pcs 73 | ; CastBlameSafe = CastBlameSafe 74 | ; domBlameSafe = domBlameSafe 75 | ; codBlameSafe = codBlameSafe 76 | ; fstBlameSafe = fstBlameSafe 77 | ; sndBlameSafe = sndBlameSafe 78 | ; inlBlameSafe = inlBlameSafe 79 | ; inrBlameSafe = inrBlameSafe 80 | } 81 | 82 | open import ParamCastSubtyping pcss 83 | 84 | coerce-safe : ∀ {A B} {ℓ ℓ′} 85 | → (c~ : A ~ B) 86 | → ℓ ≢̂ ℓ′ 87 | → CastBlameSafe (coerce A B {c~} ℓ′) ℓ 88 | coerce-safe {A} {B} unk~L ℓ≢ with eq-unk B 89 | ... | yes eq rewrite eq = safe-id 90 | ... | no _ = safe-proj ℓ≢ 91 | coerce-safe {A} {B} unk~R ℓ≢ with eq-unk A 92 | ... | yes eq rewrite eq = safe-id 93 | ... | no _ = safe-inj 94 | coerce-safe base~ ℓ≢ = safe-id 95 | coerce-safe (fun~ c~ d~) ℓ≢ = safe-cfun (coerce-safe c~ (≢̂→≢̂flip ℓ≢)) (coerce-safe d~ ℓ≢) 96 | coerce-safe (pair~ c~ d~) ℓ≢ = safe-cpair (coerce-safe c~ ℓ≢) (coerce-safe d~ ℓ≢) 97 | coerce-safe (sum~ c~ d~) ℓ≢ = safe-csum (coerce-safe c~ ℓ≢) (coerce-safe d~ ℓ≢) 98 | 99 | applyCast-pres-allsafe : ∀ {Γ A B} {V : Γ ⊢ A} {vV : Value V} {c : Cast (A ⇒ B)} {ℓ} 100 | → (a : Active c) 101 | → CastBlameSafe c ℓ 102 | → CastsAllSafe V ℓ 103 | → CastsAllSafe (applyCast V vV c {a}) ℓ 104 | applyCast-pres-allsafe {vV = vV} (A-proj {B}) (safe-proj ℓ≢) allsafe with canonical⋆ _ vV 105 | ... | ⟨ A′ , ⟨ M′ , ⟨ _ , ⟨ _ , meq ⟩ ⟩ ⟩ ⟩ rewrite meq with A′ `~ B 106 | ... | no _ = allsafe-blame-diff-ℓ ℓ≢ 107 | ... | yes A′~B with allsafe 108 | ... | (allsafe-wrap _ allsafe-M′) = allsafe-cast (coerce-safe A′~B ℓ≢) allsafe-M′ 109 | applyCast-pres-allsafe A-fun (safe-cfun safe-c safe-d) allsafe = 110 | allsafe-ƛ (allsafe-cast safe-d (allsafe-· (rename-pres-allsafe S_ allsafe) (allsafe-cast safe-c allsafe-var))) 111 | applyCast-pres-allsafe A-pair (safe-cpair safe-c safe-d) allsafe = 112 | allsafe-cons (allsafe-cast safe-c (allsafe-fst allsafe)) 113 | (allsafe-cast safe-d (allsafe-snd allsafe)) 114 | applyCast-pres-allsafe A-sum (safe-csum safe-c safe-d) allsafe = 115 | allsafe-case allsafe (allsafe-inl (allsafe-cast safe-c allsafe-var)) 116 | (allsafe-inr (allsafe-cast safe-d allsafe-var)) 117 | applyCast-pres-allsafe A-id safe allsafe = allsafe 118 | 119 | open import CastStructureWithBlameSafety 120 | 121 | css : CastStructWithBlameSafety 122 | css = record { pcss = pcss ; applyCast = applyCast ; applyCast-pres-allsafe = applyCast-pres-allsafe } 123 | 124 | -- Instantiate blame-subtyping theorem for `SimpleCoercion`. 125 | open import ParamBlameSubtyping css using (soundness-<:) public 126 | 127 | -------------------------------------------------------------------------------- /SimpleFunCastBlame.agda: -------------------------------------------------------------------------------- 1 | module SimpleFunCastBlame where 2 | 3 | open import Data.Nat 4 | open import Data.Bool 5 | open import Relation.Nullary using (¬_; Dec; yes; no) 6 | open import Relation.Nullary.Negation using (contradiction) 7 | open import Relation.Binary.PropositionalEquality 8 | using (_≡_;_≢_; refl; trans; sym; cong; cong₂; cong-app) 9 | open import Data.Product using (_×_; proj₁; proj₂; Σ; Σ-syntax) 10 | renaming (_,_ to ⟨_,_⟩) 11 | open import Data.Sum using (_⊎_; inj₁; inj₂) 12 | open import Data.Empty using (⊥; ⊥-elim) 13 | open import Data.Empty.Irrelevant renaming (⊥-elim to ⊥-elimi) 14 | 15 | open import Types 16 | open import Variables 17 | open import Labels 18 | open import SimpleFunCast 19 | 20 | open import Subtyping using (_<:₁_) 21 | open _<:₁_ 22 | infix 5 _<:_ 23 | _<:_ = _<:₁_ 24 | 25 | data CastBlameSafe : ∀ {A} → Cast A → Label → Set where 26 | 27 | safe-<: : ∀ {S T} {c~ : S ~ T} {ℓ} 28 | → S <: T 29 | ---------------------------- 30 | → CastBlameSafe (cast S T ℓ {c~}) ℓ 31 | 32 | safe-ℓ≢ : ∀ {S T} {c~ : S ~ T} {ℓ ℓ′} 33 | → ℓ ≢̂ ℓ′ 34 | ----------------------------- 35 | → CastBlameSafe (cast S T ℓ′ {c~}) ℓ 36 | 37 | domBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 38 | → CastBlameSafe (dom c x) ℓ 39 | domBlameSafe (safe-<: {c~ = c~} (<:-⇒ sub-dom sub-cod)) x with ~-relevant c~ 40 | ... | fun~ _ _ = safe-<: sub-dom 41 | domBlameSafe (safe-ℓ≢ {c~ = c~} ℓ≢) x with ~-relevant c~ 42 | ... | fun~ _ _ = safe-ℓ≢ ℓ≢ 43 | 44 | codBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ ⇒ S₂) ⇒ (T₁ ⇒ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 45 | → CastBlameSafe (cod c x) ℓ 46 | codBlameSafe (safe-<: {c~ = c~} (<:-⇒ sub-dom sub-cod)) x with ~-relevant c~ 47 | ... | fun~ _ _ = safe-<: sub-cod 48 | codBlameSafe (safe-ℓ≢ {c~ = c~} ℓ≢) x with ~-relevant c~ 49 | ... | fun~ _ _ = safe-ℓ≢ ℓ≢ 50 | 51 | fstBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 52 | → CastBlameSafe (fstC c x) ℓ 53 | fstBlameSafe (safe-<: {c~ = c~} (<:-× sub-fst sub-snd)) x with ~-relevant c~ 54 | ... | pair~ _ _ = safe-<: sub-fst 55 | fstBlameSafe (safe-ℓ≢ {c~ = c~} ℓ≢) x with ~-relevant c~ 56 | ... | pair~ _ _ = safe-ℓ≢ ℓ≢ 57 | 58 | sndBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `× S₂) ⇒ (T₁ `× T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 59 | → CastBlameSafe (sndC c x) ℓ 60 | sndBlameSafe (safe-<: {c~ = c~} (<:-× sub-fst sub-snd)) x with ~-relevant c~ 61 | ... | pair~ _ _ = safe-<: sub-snd 62 | sndBlameSafe (safe-ℓ≢ {c~ = c~} ℓ≢) x with ~-relevant c~ 63 | ... | pair~ _ _ = safe-ℓ≢ ℓ≢ 64 | 65 | inlBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 66 | → CastBlameSafe (inlC c x) ℓ 67 | inlBlameSafe (safe-<: {c~ = c~} (<:-⊎ sub-l sub-r)) x with ~-relevant c~ 68 | ... | sum~ _ _ = safe-<: sub-l 69 | inlBlameSafe (safe-ℓ≢ {c~ = c~} ℓ≢) x with ~-relevant c~ 70 | ... | sum~ _ _ = safe-ℓ≢ ℓ≢ 71 | 72 | inrBlameSafe : ∀ {S₁ S₂ T₁ T₂} {c : Cast ((S₁ `⊎ S₂) ⇒ (T₁ `⊎ T₂))} {ℓ} → CastBlameSafe c ℓ → (x : Cross c) 73 | → CastBlameSafe (inrC c x) ℓ 74 | inrBlameSafe (safe-<: {c~ = c~} (<:-⊎ sub-l sub-r)) x with ~-relevant c~ 75 | ... | sum~ _ _ = safe-<: sub-r 76 | inrBlameSafe (safe-ℓ≢ {c~ = c~} ℓ≢) x with ~-relevant c~ 77 | ... | sum~ _ _ = safe-ℓ≢ ℓ≢ 78 | 79 | open import PreCastStructureWithBlameSafety 80 | 81 | pcss : PreCastStructWithBlameSafety 82 | pcss = record 83 | { precast = pcs 84 | ; CastBlameSafe = CastBlameSafe 85 | ; domBlameSafe = domBlameSafe 86 | ; codBlameSafe = codBlameSafe 87 | ; fstBlameSafe = fstBlameSafe 88 | ; sndBlameSafe = sndBlameSafe 89 | ; inlBlameSafe = inlBlameSafe 90 | ; inrBlameSafe = inrBlameSafe 91 | } 92 | 93 | open import ParamCastSubtyping pcss 94 | 95 | applyCast-pres-allsafe : ∀ {Γ A B} {V : Γ ⊢ A} {vV : Value V} {c : Cast (A ⇒ B)} {ℓ} 96 | → (a : Active c) 97 | → CastBlameSafe c ℓ 98 | → CastsAllSafe V ℓ 99 | -------------------------------------- 100 | → CastsAllSafe (applyCast V vV c {a}) ℓ 101 | applyCast-pres-allsafe (activeId _) safe allsafe = allsafe 102 | applyCast-pres-allsafe (activeProj (cast ⋆ .⋆ ℓ) ⋆≢⋆) (safe-<: T<:⋆) allsafe = ⊥-elimi (⋆≢⋆ refl) 103 | applyCast-pres-allsafe {vV = vV} (activeProj (cast ⋆ B ℓ′) B≢⋆) (safe-ℓ≢ ℓ≢) allsafe with canonical⋆ _ vV 104 | ... | ⟨ A′ , ⟨ M′ , ⟨ _ , ⟨ _ , meq ⟩ ⟩ ⟩ ⟩ rewrite meq with A′ `~ B 105 | ... | no _ = allsafe-blame-diff-ℓ ℓ≢ 106 | ... | yes _ with allsafe 107 | ... | (allsafe-wrap _ allsafe-M′) = allsafe-cast (safe-ℓ≢ ℓ≢) allsafe-M′ 108 | 109 | open import CastStructureWithBlameSafety 110 | 111 | css : CastStructWithBlameSafety 112 | css = record { pcss = pcss ; applyCast = applyCast ; applyCast-pres-allsafe = applyCast-pres-allsafe } 113 | 114 | -- Instantiate blame-subtyping theorem for `SimpleFunCast`. 115 | open import ParamBlameSubtyping css using (soundness-<:) public 116 | 117 | -------------------------------------------------------------------------------- /StaticGradualGuarantee.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat using (ℕ; zero; suc) 2 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; cong) 3 | open import Data.Product using (_×_; proj₁; proj₂; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩) 4 | 5 | open import Types 6 | open import Variables 7 | open import Labels 8 | open import GTLC 9 | open import GTLCPrecision 10 | 11 | 12 | module StaticGradualGuarantee where 13 | 14 | ctx-prec-var : ∀ {Γ Γ′ A′} {x : ℕ} 15 | → Γ ⊑* Γ′ 16 | → Γ′ ∋ x ⦂ A′ 17 | → ∃[ A ] (Γ ∋ x ⦂ A) × (A ⊑ A′) 18 | ctx-prec-var (⊑*-, lp lp*) Z = ⟨ _ , ⟨ Z , lp ⟩ ⟩ 19 | ctx-prec-var (⊑*-, lp lp*) (S ∋x) = 20 | let ⟨ A , ⟨ ∋n , lpA ⟩ ⟩ = ctx-prec-var lp* ∋x in ⟨ A , ⟨ S ∋n , lpA ⟩ ⟩ 21 | 22 | static-gradual-guarantee : ∀ {Γ Γ′ A′} {M M′ : Term} 23 | → Γ′ ⊢G M′ ⦂ A′ 24 | → Γ ⊑* Γ′ 25 | → M ⊑ᴳ M′ 26 | ------------------------------- 27 | → ∃[ A ] (Γ ⊢G M ⦂ A) × (A ⊑ A′) 28 | static-gradual-guarantee (⊢var ∋x) lp* ⊑ᴳ-var = 29 | let ⟨ A , ⟨ ∋n , lpA ⟩ ⟩ = ctx-prec-var lp* ∋x in 30 | ⟨ A , ⟨ ⊢var ∋n , lpA ⟩ ⟩ 31 | static-gradual-guarantee (⊢lam ⊢N′) lp* (⊑ᴳ-ƛ lp lpN) = 32 | let ⟨ B , ⟨ ⊢N , lpB ⟩ ⟩ = static-gradual-guarantee ⊢N′ (⊑*-, lp lp*) lpN in 33 | ⟨ _ , ⟨ ⊢lam ⊢N , fun⊑ lp lpB ⟩ ⟩ 34 | static-gradual-guarantee (⊢app ⊢L′ ⊢M′ m c~) lp* (⊑ᴳ-· lpL lpM) 35 | with static-gradual-guarantee ⊢L′ lp* lpL 36 | ... | ⟨ AB , ⟨ ⊢L , lpAB ⟩ ⟩ 37 | with static-gradual-guarantee ⊢M′ lp* lpM 38 | ... | ⟨ B , ⟨ ⊢M , lpB ⟩ ⟩ with lpAB 39 | ... | unk⊑ = ⟨ _ , ⟨ ⊢app ⊢L ⊢M match⇒⋆ unk~L , unk⊑ ⟩ ⟩ 40 | ... | fun⊑ lp1 lp2 with m 41 | ... | match⇒⇒ = 42 | ⟨ _ , ⟨ ⊢app ⊢L ⊢M match⇒⇒ (lp-consis c~ lp1 lpB) , lp2 ⟩ ⟩ 43 | static-gradual-guarantee ⊢lit lp* ⊑ᴳ-prim = ⟨ _ , ⟨ ⊢lit , Refl⊑ ⟩ ⟩ 44 | static-gradual-guarantee (⊢if ⊢L′ ⊢M′ ⊢N′ c~ d~) lp* (⊑ᴳ-if lpL lpM lpN) 45 | with static-gradual-guarantee ⊢L′ lp* lpL | static-gradual-guarantee ⊢M′ lp* lpM | static-gradual-guarantee ⊢N′ lp* lpN 46 | ... | ⟨ B , ⟨ ⊢L , lpB ⟩ ⟩ | ⟨ A , ⟨ ⊢M , lpA ⟩ ⟩ | ⟨ A' , ⟨ ⊢N , lpA' ⟩ ⟩ = 47 | ⟨ _ , ⟨ ⊢if ⊢L ⊢M ⊢N (lp-consis c~ lpB Refl⊑) (lp-consis d~ lpA lpA') , ⨆-pres-prec _ _ lpA lpA' ⟩ ⟩ 48 | static-gradual-guarantee (⊢cons ⊢M′ ⊢N′) lp* (⊑ᴳ-cons lpM lpN) 49 | with static-gradual-guarantee ⊢M′ lp* lpM | static-gradual-guarantee ⊢N′ lp* lpN 50 | ... | ⟨ A , ⟨ ⊢M , lpA ⟩ ⟩ | ⟨ B , ⟨ ⊢N , lpB ⟩ ⟩ = 51 | ⟨ _ , ⟨ ⊢cons ⊢M ⊢N , pair⊑ lpA lpB ⟩ ⟩ 52 | static-gradual-guarantee (⊢fst ⊢M′ m) lp* (⊑ᴳ-fst lpM) 53 | with static-gradual-guarantee ⊢M′ lp* lpM 54 | ... | ⟨ A , ⟨ ⊢M , lpA ⟩ ⟩ with m | lpA 55 | ... | match×⋆ | unk⊑ = ⟨ _ , ⟨ ⊢fst ⊢M match×⋆ , unk⊑ ⟩ ⟩ 56 | ... | match×× | unk⊑ = ⟨ _ , ⟨ ⊢fst ⊢M match×⋆ , unk⊑ ⟩ ⟩ 57 | ... | match×× | pair⊑ lp1 lp2 = ⟨ _ , ⟨ ⊢fst ⊢M match×× , lp1 ⟩ ⟩ 58 | static-gradual-guarantee (⊢snd ⊢M′ m) lp* (⊑ᴳ-snd lpM) 59 | with static-gradual-guarantee ⊢M′ lp* lpM 60 | ... | ⟨ A , ⟨ ⊢M , lpA ⟩ ⟩ with m | lpA 61 | ... | match×⋆ | unk⊑ = ⟨ _ , ⟨ ⊢snd ⊢M match×⋆ , unk⊑ ⟩ ⟩ 62 | ... | match×× | unk⊑ = ⟨ _ , ⟨ ⊢snd ⊢M match×⋆ , unk⊑ ⟩ ⟩ 63 | ... | match×× | pair⊑ lp1 lp2 = ⟨ _ , ⟨ ⊢snd ⊢M match×× , lp2 ⟩ ⟩ 64 | static-gradual-guarantee (⊢inl ⊢M′) lp* (⊑ᴳ-inl lp lpM) 65 | with static-gradual-guarantee ⊢M′ lp* lpM 66 | ... | ⟨ A , ⟨ ⊢M , lpA ⟩ ⟩ = ⟨ _ , ⟨ ⊢inl ⊢M , sum⊑ lpA lp ⟩ ⟩ 67 | static-gradual-guarantee (⊢inr ⊢M′) lp* (⊑ᴳ-inr lp lpM) 68 | with static-gradual-guarantee ⊢M′ lp* lpM 69 | ... | ⟨ B , ⟨ ⊢M , lpB ⟩ ⟩ = ⟨ _ , ⟨ ⊢inr ⊢M , sum⊑ lp lpB ⟩ ⟩ 70 | static-gradual-guarantee (⊢case ⊢L′ ⊢M′ ⊢N′ c~ d~) lp* (⊑ᴳ-case lpL lp1 lp2 lpM lpN) 71 | with static-gradual-guarantee ⊢L′ lp* lpL | static-gradual-guarantee ⊢M′ (⊑*-, lp1 lp*) lpM | static-gradual-guarantee ⊢N′ (⊑*-, lp2 lp*) lpN 72 | ... | ⟨ A , ⟨ ⊢L , lpA ⟩ ⟩ | ⟨ B , ⟨ ⊢M , lpB ⟩ ⟩ | ⟨ C , ⟨ ⊢N , lpC ⟩ ⟩ = 73 | ⟨ _ , ⟨ ⊢case ⊢L ⊢M ⊢N (lp-consis c~ lpA (sum⊑ lp1 lp2)) (lp-consis d~ lpB lpC) , ⨆-pres-prec _ _ lpB lpC ⟩ ⟩ 74 | -------------------------------------------------------------------------------- /Subtyping.agda: -------------------------------------------------------------------------------- 1 | module Subtyping where 2 | 3 | open import Types 4 | 5 | 6 | -- The subtyping relation(s). 7 | infix 5 _<:₁_ 8 | infix 5 _<:₂_ 9 | infix 5 _<:₃_ 10 | 11 | {- 12 | Traditional subtyping, where Dyn (⋆) is at its top. 13 | (The subtyping relations are in the same order as Fig. 3 in the 'Exploring the Design Space' paper. ) 14 | -} 15 | data _<:₁_ : Type → Type → Set where 16 | 17 | T<:⋆ : ∀ {T} 18 | -------- 19 | → T <:₁ ⋆ 20 | 21 | <:-B : ∀ {B} 22 | ----------- 23 | → ` B <:₁ ` B 24 | 25 | -- Product and sum are monotone with respect to subtyping. 26 | <:-× : ∀ {S₁ S₂ T₁ T₂} 27 | → S₁ <:₁ T₁ → S₂ <:₁ T₂ 28 | ----------------------- 29 | → S₁ `× S₂ <:₁ T₁ `× T₂ 30 | 31 | <:-⊎ : ∀ {S₁ S₂ T₁ T₂} 32 | → S₁ <:₁ T₁ → S₂ <:₁ T₂ 33 | ----------------------- 34 | → S₁ `⊎ S₂ <:₁ T₁ `⊎ T₂ 35 | 36 | <:-⇒ : ∀ {S₁ S₂ T₁ T₂} 37 | → T₁ <:₁ S₁ → S₂ <:₁ T₂ 38 | ----------------------- 39 | → S₁ ⇒ S₂ <:₁ T₁ ⇒ T₂ 40 | 41 | {- 42 | Subtyping of WF-1. This is the rarely used one. 43 | -} 44 | data _<:₂_ : Type → Type → Set where 45 | 46 | <:-⋆ : ⋆ <:₂ ⋆ 47 | 48 | <:-B : ∀ {B} 49 | ----------- 50 | → ` B <:₂ ` B 51 | 52 | -- Product and sum are monotone with respect to subtyping. 53 | <:-× : ∀ {S₁ S₂ T₁ T₂} 54 | → S₁ <:₂ T₁ → S₂ <:₂ T₂ 55 | ----------------------- 56 | → S₁ `× S₂ <:₂ T₁ `× T₂ 57 | 58 | <:-⊎ : ∀ {S₁ S₂ T₁ T₂} 59 | → S₁ <:₂ T₁ → S₂ <:₂ T₂ 60 | ----------------------- 61 | → S₁ `⊎ S₂ <:₂ T₁ `⊎ T₂ 62 | 63 | <:-⇒ : ∀ {S₁ S₂ T₁ T₂} 64 | → T₁ <:₂ S₁ → S₂ <:₂ T₂ 65 | ----------------------- 66 | → S₁ ⇒ S₂ <:₂ T₁ ⇒ T₂ 67 | 68 | {- 69 | Subtyping of WF-2. 70 | This is usually used to characterize the cast safety of UD (which routes through ground types). 71 | -} 72 | data _<:₃_ : Type → Type → Set where 73 | 74 | <:-⋆ : ⋆ <:₃ ⋆ 75 | 76 | <:-B : ∀ {B} 77 | ----------- 78 | → ` B <:₃ ` B 79 | 80 | <:-G : ∀ {S G} 81 | → S <:₃ G → Ground G 82 | -------------------------- 83 | → S <:₃ ⋆ 84 | 85 | -- Product and sum are monotone with respect to subtyping. 86 | <:-× : ∀ {S₁ S₂ T₁ T₂} 87 | → S₁ <:₃ T₁ → S₂ <:₃ T₂ 88 | ----------------------- 89 | → S₁ `× S₂ <:₃ T₁ `× T₂ 90 | 91 | <:-⊎ : ∀ {S₁ S₂ T₁ T₂} 92 | → S₁ <:₃ T₁ → S₂ <:₃ T₂ 93 | ----------------------- 94 | → S₁ `⊎ S₂ <:₃ T₁ `⊎ T₂ 95 | 96 | <:-⇒ : ∀ {S₁ S₂ T₁ T₂} 97 | → T₁ <:₃ S₁ → S₂ <:₃ T₂ 98 | ----------------------- 99 | → S₁ ⇒ S₂ <:₃ T₁ ⇒ T₂ 100 | -------------------------------------------------------------------------------- /Variables.agda: -------------------------------------------------------------------------------- 1 | module Variables where 2 | 3 | open import Data.Nat using (ℕ; zero; suc) 4 | open import Data.Nat.Properties using (_≟_; suc-injective) 5 | open import Relation.Nullary using (¬_; Dec; yes; no) 6 | open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; cong) 7 | open import Types 8 | 9 | infixl 5 _,_ 10 | 11 | data Context : Set where 12 | ∅ : Context 13 | _,_ : Context → Type → Context 14 | 15 | infix 4 _⊑*_ 16 | 17 | -- Typing context precision 18 | data _⊑*_ : Context → Context → Set where 19 | 20 | ⊑*-∅ : ∅ ⊑* ∅ 21 | 22 | ⊑*-, : ∀ {A A′ Γ Γ′} 23 | → A ⊑ A′ 24 | → Γ ⊑* Γ′ 25 | → Γ , A ⊑* Γ′ , A′ 26 | 27 | infix 4 _∋_ 28 | infix 9 S_ 29 | 30 | data _∋_ : Context → Type → Set where 31 | 32 | Z : ∀ {Γ A} 33 | ---------- 34 | → Γ , A ∋ A 35 | 36 | S_ : ∀ {Γ A B} 37 | → Γ ∋ A 38 | --------- 39 | → Γ , B ∋ A 40 | 41 | ∋→ℕ : ∀{Γ}{A} → Γ ∋ A → ℕ 42 | ∋→ℕ {.(_ , A)} {A} Z = 0 43 | ∋→ℕ {.(_ , _)} {A} (S Γ∋A) = suc (∋→ℕ Γ∋A) 44 | 45 | var-eq? : ∀ {Γ A} 46 | → (x₁ x₂ : Γ ∋ A) 47 | → Dec (x₁ ≡ x₂) 48 | var-eq? Z Z = yes refl 49 | var-eq? Z (S _) = no λ () 50 | var-eq? (S _) Z = no λ () 51 | var-eq? (S x₁) (S x₂) with var-eq? x₁ x₂ 52 | ... | yes x₁≡x₂ = yes (cong S_ x₁≡x₂) 53 | ... | no x₁≢x₂ = no λ { refl → x₁≢x₂ refl } 54 | 55 | ⊑*→⊑ : ∀ {Γ Γ′ A A′} 56 | → (x : Γ ∋ A) → (x′ : Γ′ ∋ A′) 57 | → Γ ⊑* Γ′ 58 | → ∋→ℕ x ≡ ∋→ℕ x′ 59 | ----------------- 60 | → A ⊑ A′ 61 | ⊑*→⊑ Z Z (⊑*-, lp lpc) refl = lp 62 | ⊑*→⊑ (S x) (S x′) (⊑*-, _ lpc) eq = ⊑*→⊑ x x′ lpc (suc-injective eq) 63 | 64 | ∋→ℕ-lookup-same : ∀ {Γ A B} 65 | → (x : Γ ∋ A) → (y : Γ ∋ B) 66 | → ∋→ℕ x ≡ ∋→ℕ y 67 | --------------------------- 68 | → A ≡ B 69 | ∋→ℕ-lookup-same Z Z refl = refl 70 | ∋→ℕ-lookup-same (S x) (S y) eq = ∋→ℕ-lookup-same x y (suc-injective eq) 71 | -------------------------------------------------------------------------------- /gradual-typing.agda-lib: -------------------------------------------------------------------------------- 1 | name: gradual-typing 2 | depend: standard-library abt denot sil 3 | include: . 4 | --------------------------------------------------------------------------------