Clean up 'Map' to hide implementation details, extract code

Signed-off-by: Danila Fedorin <danila.fedorin@gmail.com>
This commit is contained in:
Danila Fedorin 2024-02-10 16:51:43 -08:00
parent 1b8c88b1a2
commit d718338759
2 changed files with 73 additions and 63 deletions

View File

@ -19,6 +19,7 @@ open import Data.List.Relation.Unary.Any using (Any; here; there) -- TODO: re-ex
open import Data.Product using (_×_; _,_; Σ; proj₁ ; proj₂) open import Data.Product using (_×_; _,_; Σ; proj₁ ; proj₂)
open import Data.Empty using (⊥; ⊥-elim) open import Data.Empty using (⊥; ⊥-elim)
open import Equivalence open import Equivalence
open import Utils using (Unique; push; empty; Unique-append; All¬-¬Any)
open IsLattice lB using () renaming open IsLattice lB using () renaming
( ≈-refl to ≈₂-refl; ≈-sym to ≈₂-sym; ≈-trans to ≈₂-trans ( ≈-refl to ≈₂-refl; ≈-sym to ≈₂-sym; ≈-trans to ≈₂-trans
@ -28,34 +29,10 @@ open IsLattice lB using () renaming
; absorb-⊔-⊓ to absorb-⊔₂-⊓₂; absorb-⊓-⊔ to absorb-⊓₂-⊔₂ ; absorb-⊔-⊓ to absorb-⊔₂-⊓₂; absorb-⊓-⊔ to absorb-⊓₂-⊔₂
) )
module ImplKeys where private module ImplKeys where
keys : List (A × B) List A keys : List (A × B) List A
keys = map proj₁ keys = map proj₁
data Unique {c} {C : Set c} : List C Set c where
empty : Unique []
push : {x : C} {xs : List C}
All (λ x' ¬ x x') xs
Unique xs
Unique (x xs)
Unique-append : {c} {C : Set c} {x : C} {xs : List C}
¬ MemProp._∈_ x xs Unique xs Unique (xs ++ (x []))
Unique-append {c} {C} {x} {[]} _ _ = push [] empty
Unique-append {c} {C} {x} {x' xs'} x∉xs (push x'≢ uxs') =
push (help x'≢) (Unique-append (λ x∈xs' x∉xs (there x∈xs')) uxs')
where
x'≢x : ¬ x' x
x'≢x x'≡x = x∉xs (here (sym x'≡x))
help : {l : List C} All (λ x'' ¬ x' x'') l All (λ x'' ¬ x' x'') (l ++ (x []))
help {[]} _ = x'≢x []
help {e es} (x'≢e x'≢es) = x'≢e help x'≢es
All¬-¬Any : {p c} {C : Set c} {P : C Set p} {l : List C} All (λ x ¬ P x) l ¬ Any P l
All¬-¬Any {l = x xs} (¬Px _) (here Px) = ¬Px Px
All¬-¬Any {l = x xs} (_ ¬Pxs) (there Pxs) = All¬-¬Any ¬Pxs Pxs
private module _ where private module _ where
open MemProp using (_∈_) open MemProp using (_∈_)
open ImplKeys open ImplKeys
@ -559,6 +536,8 @@ Expr-Provenance k (e₁ ∩ e₂) k∈ke₁e₂
... | no k∉ke₁ | yes k∈ke₂ = ⊥-elim (intersect-preserves-∉₁ {l₂ = proj₁ e₂ } k∉ke₁ k∈ke₁e₂) ... | no k∉ke₁ | yes k∈ke₂ = ⊥-elim (intersect-preserves-∉₁ {l₂ = proj₁ e₂ } k∉ke₁ k∈ke₁e₂)
... | no k∉ke₁ | no k∉ke₂ = ⊥-elim (intersect-preserves-∉₂ {l₁ = proj₁ e₁ } k∉ke₂ k∈ke₁e₂) ... | no k∉ke₁ | no k∉ke₂ = ⊥-elim (intersect-preserves-∉₂ {l₁ = proj₁ e₁ } k∉ke₂ k∈ke₁e₂)
module _ (≈₂-dec : (b₁ b₂ : B) Dec (b₁ ≈₂ b₂)) where
private module _ where
data SubsetInfo (m₁ m₂ : Map) : Set (a ⊔ℓ b) where data SubsetInfo (m₁ m₂ : Map) : Set (a ⊔ℓ b) where
extra : (k : A) k ∈k m₁ ¬ k ∈k m₂ SubsetInfo m₁ m₂ extra : (k : A) k ∈k m₁ ¬ k ∈k m₂ SubsetInfo m₁ m₂
mismatch : (k : A) (v₁ v₂ : B) (k , v₁) m₁ (k , v₂) m₂ ¬ v₁ ≈₂ v₂ SubsetInfo m₁ m₂ mismatch : (k : A) (v₁ v₂ : B) (k , v₁) m₁ (k , v₂) m₂ ¬ v₁ ≈₂ v₂ SubsetInfo m₁ m₂
@ -576,7 +555,6 @@ SubsetInfo-to-dec {m₁} {m₂} (mismatch k v₁ v₂ k,v₁∈m₁ k,v₂∈m
in v₁̷≈v₂ (subst (λ v'' v₁ ≈₂ v'') (Map-functional {k} {v'} {v₂} {m₂} k,v'∈m₂ k,v₂∈m₂) v₁≈v')) -- for some reason, can't just use subst... in v₁̷≈v₂ (subst (λ v'' v₁ ≈₂ v'') (Map-functional {k} {v'} {v₂} {m₂} k,v'∈m₂ k,v₂∈m₂) v₁≈v')) -- for some reason, can't just use subst...
SubsetInfo-to-dec (fine m₁⊆m₂) = yes m₁⊆m₂ SubsetInfo-to-dec (fine m₁⊆m₂) = yes m₁⊆m₂
module _ (≈₂-dec : (b₁ b₂ : B) Dec (b₁ ≈₂ b₂)) where
compute-SubsetInfo : m₁ m₂ SubsetInfo m₁ m₂ compute-SubsetInfo : m₁ m₂ SubsetInfo m₁ m₂
compute-SubsetInfo ([] , _) m₂ = fine (λ k v ()) compute-SubsetInfo ([] , _) m₂ = fine (λ k v ())
compute-SubsetInfo m₁@((k , v) xs₁ , push k≢xs₁ uxs₁) m₂@(l₂ , u₂) compute-SubsetInfo m₁@((k , v) xs₁ , push k≢xs₁ uxs₁) m₂@(l₂ , u₂)

32
Utils.agda Normal file
View File

@ -0,0 +1,32 @@
module Utils where
open import Data.List using (List; []; _∷_; _++_)
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.List.Relation.Unary.Any using (Any; here; there) -- TODO: re-export these with nicer names from map
open import Relation.Binary.PropositionalEquality using (_≡_; sym)
open import Relation.Nullary using (¬_)
data Unique {c} {C : Set c} : List C Set c where
empty : Unique []
push : {x : C} {xs : List C}
All (λ x' ¬ x x') xs
Unique xs
Unique (x xs)
Unique-append : {c} {C : Set c} {x : C} {xs : List C}
¬ x xs Unique xs Unique (xs ++ (x []))
Unique-append {c} {C} {x} {[]} _ _ = push [] empty
Unique-append {c} {C} {x} {x' xs'} x∉xs (push x'≢ uxs') =
push (help x'≢) (Unique-append (λ x∈xs' x∉xs (there x∈xs')) uxs')
where
x'≢x : ¬ x' x
x'≢x x'≡x = x∉xs (here (sym x'≡x))
help : {l : List C} All (λ x'' ¬ x' x'') l All (λ x'' ¬ x' x'') (l ++ (x []))
help {[]} _ = x'≢x []
help {e es} (x'≢e x'≢es) = x'≢e help x'≢es
All¬-¬Any : {p c} {C : Set c} {P : C Set p} {l : List C} All (λ x ¬ P x) l ¬ Any P l
All¬-¬Any {l = x xs} (¬Px _) (here Px) = ¬Px Px
All¬-¬Any {l = x xs} (_ ¬Pxs) (there Pxs) = All¬-¬Any ¬Pxs Pxs