diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3b9dc5d4..6abf5d54 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -75,6 +75,22 @@ jobs: if: steps.filter.outputs.code == 'true' uses: Swatinem/rust-cache@779680da715d629ac1d338a641029a2f4372abb5 # v2 + # The Lean development in `formal/` is checked by *building* it: `lake + # build` elaborates every theorem and evaluates every `#guard`, so without + # a toolchain on the runner the `Formal model` step below would skip and + # gate nothing. elan is pinned by release and verified by hash, the same + # discipline as pinning the actions above by SHA, and it installs the + # version `formal/lean-toolchain` names rather than a floating one. + - name: Setup Lean + if: steps.filter.outputs.code == 'true' + run: | + curl -sSfL -o /tmp/elan.tar.gz \ + https://github.com/leanprover/elan/releases/download/v4.2.3/elan-x86_64-unknown-linux-gnu.tar.gz + echo "df0b2b3a439961ffcbb3985214365ffe40f49bc871df04dff268c7d8e21ca8b2 /tmp/elan.tar.gz" \ + | sha256sum -c - + tar xzf /tmp/elan.tar.gz -C /tmp + /tmp/elan-init -y --default-toolchain "$(cat formal/lean-toolchain)" >/dev/null + echo "$HOME/.elan/bin" >> "$GITHUB_PATH" # 3. Run Checks (Only if code changed) - name: Shellcheck @@ -137,6 +153,15 @@ jobs: if: steps.filter.outputs.code == 'true' && (success() || failure()) run: ./ci.sh doc + - name: Formal model + # Builds the Lean model, which is what checks its proofs, then diffs the + # model's verdicts against the solver's. Placed before `Test` so the + # oracle binary exists by the time the suite runs: the differential tests + # skip themselves without it, and skipping is the failure mode this step + # exists to remove. + if: steps.filter.outputs.code == 'true' && (success() || failure()) + run: ./ci.sh formal + - name: Test # Run even if earlier steps failed so we see all errors in one run. # (Steps default to `if: success()`, which skips on prior failure.) diff --git a/ci.sh b/ci.sh index e63bcc69..533614a4 100755 --- a/ci.sh +++ b/ci.sh @@ -48,6 +48,26 @@ ci_clippy_lib() { cargo clippy --lib -- -D warnings; } # argument as `ci_clippy_serde`: a configuration nothing runs is a # configuration that rots. ci_test() { cargo test -q ${DEEP_TYPECHECK:+--features deep-typecheck}; } +# The formal model (`formal/`): building it is what elaborates every theorem and +# evaluates every `#guard` in the Lean development, and the differential tests +# then diff the model's verdicts against the solver's. Those tests skip +# themselves when the oracle binary is absent, so without this gate nothing +# notices the model drifting from the solver — the same rot argument as +# `ci_clippy_serde`, and the drift is silent in both directions. A machine with +# no Lean toolchain skips, loudly; under CI a missing toolchain is a broken gate +# rather than a local convenience, so it fails instead. +ci_formal() { + if ! command -v lake >/dev/null 2>&1; then + if [[ -n "${CI:-}" ]]; then + echo "ci_formal: no Lean toolchain (lake) under CI — this gate would be a no-op" >&2 + return 1 + fi + echo "ci_formal: no Lean toolchain (lake) — formal model not checked" >&2 + return 0 + fi + (cd formal && lake build) || return 1 + cargo test -q --test differential_oracle +} ci_doc() { RUSTDOCFLAGS="-A warnings -D rustdoc::broken_intra_doc_links" \ cargo doc --no-deps @@ -120,6 +140,9 @@ ci_all() { # shellcheck disable=SC2310 # intentional: || captures failure without exiting ci_test || failed=1 + # shellcheck disable=SC2310 + # intentional: || captures failure without exiting + ci_formal || failed=1 exit "${failed}" } diff --git a/formal/.gitignore b/formal/.gitignore new file mode 100644 index 00000000..bfb30ec8 --- /dev/null +++ b/formal/.gitignore @@ -0,0 +1 @@ +/.lake diff --git a/formal/CclFormal.lean b/formal/CclFormal.lean new file mode 100644 index 00000000..7a2438ff --- /dev/null +++ b/formal/CclFormal.lean @@ -0,0 +1,12 @@ +import CclFormal.Ty +import CclFormal.Merge +import CclFormal.Coalesce +import CclFormal.Term +import CclFormal.Safety +import CclFormal.Sub +import CclFormal.Decide +import CclFormal.Json +import CclFormal.Props +import CclFormal.Equiv +import CclFormal.Transitivity +import CclFormal.Bridge diff --git a/formal/CclFormal/Bridge.lean b/formal/CclFormal/Bridge.lean new file mode 100644 index 00000000..8cf28b06 --- /dev/null +++ b/formal/CclFormal/Bridge.lean @@ -0,0 +1,1821 @@ +import CclFormal.Coalesce +import CclFormal.Equiv + +/-! +# M4c — the bridge: `merge` is the subtyping join + +`Merge.lean` proves `merge pol` is the least upper bound of the order it induces +(`merge_isLub`), and that order is defined *by* the merge. This module states the +theorem that names the order independently: the merged position materializes to +the `Sub`-least upper bound of what its operands materialize to, and dually at a +negative position. + +The statements are `Bool`-valued on purpose. `subCheck` decides `Sub` +(`subCheck_iff_sub`) and `coalesce` is total, so each is measurable over a +bounded sample before it is proved, and the sample is what caught the shapes +recorded in `formal/design.md`, "M4c — the lattice, and what a merge means". +-/ + +namespace CclFormal +namespace CTy + +/-- The soundness half at one pair: where all three positions materialize, a +positive merge lands above both operands and a negative one below both. + +Conditional on materializing, which is the honest form — `coalesce` is partial, +and its failures are exactly the joins no `Ty` names. -/ +def LubSoundAt (pol : Bool) (a b : CTy) : Bool := + match coalesce pol a, coalesce pol b, coalesce pol (merge pol a b) with + | .ok (some ta), .ok (some tb), .ok (some tm) => + if pol then subCheck ta tm && subCheck tb tm + else subCheck tm ta && subCheck tm tb + | _, _, _ => true + +/-! ## Ground positions + +`wf` excludes `KindM.conflict`. `KindM.unknown` is the other non-ground kind — a +kind variable nothing has pinned — and it is not a subject for a subtyping +statement: `coalesce` materializes it by applying the capability default, a merge +that pins the slot to `data` overrides that default, and so the operand's own +materialization is not what the merge combined. `kindResolved` is what "ground" +means for the kind slot, and the bridge theorem assumes it. -/ + +mutual + +def kindResolved : CTy → Bool + | .mk _ r v f _ => + (match r with + | none => true + | some m => kindResolvedKeys m (m.map Prod.fst)) + && (match v with + | none => true + | some m => kindResolvedKeys m (m.map Prod.fst)) + && (match f with + | none => true + | some (k, d, cod) => + (k == .data || k == .compute) && kindResolvedAll d && kindResolved cod) +termination_by t => (sizeOf t, 0) + +/-- All payloads of a map are `kindResolved` (worklist form, as `wfKeys`). -/ +def kindResolvedKeys (m : List (FieldKey × CTy)) : List FieldKey → Bool + | [] => true + | k :: ks => + (match h : m.lookup k with + | some v => kindResolved v + | none => true) + && kindResolvedKeys m ks +termination_by ks => (sizeOf m, ks.length) +decreasing_by + · have := lookup_sizeOf h + apply Prod.Lex.left + omega + · apply Prod.Lex.right + simp + +/-- Every domain alternative of a slot is `kindResolved`. -/ +def kindResolvedAll : List CTy → Bool + | [] => true + | d :: ds => kindResolved d && kindResolvedAll ds +termination_by ds => (sizeOf ds, 0) +decreasing_by + · apply Prod.Lex.left + simp + omega + · apply Prod.Lex.left + simp + omega + +end + +/-- Ground: the input-bound invariant plus a concrete kind at every function +slot. What the bridge theorem assumes of a single position. -/ +def ground (t : CTy) : Bool := wf t && kindResolved t + +/-- Pointwise reading of `kindResolvedKeys`, as `wfKeys_iff`. -/ +theorem kindResolvedKeys_iff {m : List (FieldKey × CTy)} {ks : List FieldKey} : + kindResolvedKeys m ks = true ↔ + ∀ k ∈ ks, ∀ v, m.lookup k = some v → kindResolved v = true := by + induction ks with + | nil => simp [kindResolvedKeys] + | cons k ks ih => + rw [kindResolvedKeys, Bool.and_eq_true, ih] + constructor + · intro ⟨hhead, htail⟩ k' hk' + rcases List.mem_cons.mp hk' with h | h + · subst h + intro v hv + rw [hv] at hhead + exact hhead + · exact htail k' h + · intro h + refine ⟨?_, fun k' hk' => h k' (by simp [hk'])⟩ + rcases hv : m.lookup k with _ | v + · rfl + · exact h k (by simp) v hv + +/-- The lemma both halves factor through: `coalesce pol` carries `le pol` to +`Sub` at a positive position and to its converse at a negative one. Soundness is +this applied to `le_merge_left`/`le_merge_right`; leastness is `merge_le` +transported back through an embedding of `Ty` into `CTy`. -/ +def MonoAt (pol : Bool) (a b : CTy) : Bool := + if eqv (merge pol a b) b then + match coalesce pol a, coalesce pol b with + | .ok (some ta), .ok (some tb) => if pol then subCheck ta tb else subCheck tb ta + | _, _ => true + else true + +/-! ## One slot at a time + +A position with a single populated slot materializes to that slot's contribution +with the position's refinements attached: the other three helpers answer `none` and +their `if` drops them, so `combine` sees one entry. -/ + +theorem coalesce_atoms_only (pol : Bool) (as : List Atom) (c : Option (List Pred)) : + coalesce pol (.mk as none none none c) = + combine ((as.map atomTy).eraseDups.map some) c := by + rw [coalesce, recShapes_none, varShapes_none, funShapes_none] + show combine ((as.map atomTy).eraseDups.map some ++ [] ++ [] ++ []) c = _ + simp + +theorem coalesce_rec_only (pol : Bool) (m : List (FieldKey × CTy)) (c : Option (List Pred)) : + coalesce pol (.mk [] (some m) none none c) = + (do + let x ← recShapes pol (.mk [] (some m) none none c) + .ok (x.map (attachRefinements · c))) := by + rw [coalesce, varShapes_none, funShapes_none] + rcases h : recShapes pol (.mk [] (some m) none none c) with e | x + · rfl + · show combine ([] ++ [x] ++ [] ++ []) c = _ + simp [combine] + rfl + +theorem coalesce_var_only (pol : Bool) (m : List (FieldKey × CTy)) (c : Option (List Pred)) : + coalesce pol (.mk [] none (some m) none c) = + (do + let x ← varShapes pol (.mk [] none (some m) none c) + .ok (x.map (attachRefinements · c))) := by + rw [coalesce, recShapes_none, funShapes_none] + rcases h : varShapes pol (.mk [] none (some m) none c) with e | x + · rfl + · show combine ([] ++ [] ++ [x] ++ []) c = _ + simp [combine] + rfl + +theorem coalesce_fun_only (pol : Bool) (g : KindM × List CTy × CTy) (c : Option (List Pred)) : + coalesce pol (.mk [] none none (some g) c) = + (do + let x ← funShapes pol (.mk [] none none (some g) c) + .ok (x.map (attachRefinements · c))) := by + rw [coalesce, recShapes_none, varShapes_none] + rcases h : funShapes pol (.mk [] none none (some g) c) with e | x + · rfl + · show combine ([] ++ [] ++ [] ++ [x]) c = _ + simp [combine] + rfl + +/-! ## The atoms case + +The first case of `MonoAt`'s proof. Materializing at all means exactly one of the +atom, record, variant, and function shapes is populated, and `le pol a b` forces +the same one on both sides, so each case reasons about a single slot. -/ + +/-- `coalesce` on a position whose only content is atoms and refinements. -/ +theorem coalesce_atoms (pol : Bool) (as : List Atom) (c : Option (List Pred)) : + coalesce pol (.mk as none none none c) = + (match (as.map atomTy).eraseDups with + | [] => .ok none + | [t] => .ok (some (attachRefinements t c)) + | _ => .error .incompatible) := by + rw [coalesce_atoms_only] + rcases h : (as.map atomTy).eraseDups with _ | ⟨x, xs⟩ + · simp [combine] + · rcases xs with _ | ⟨y, ys⟩ + · simp [combine] + · simp [combine] + +/-- Refinements ride a subtyping edge: the side with more refinements stays the subtype, and +the sets compare by membership, as `RefinementSet` does. -/ +theorem subCheck_attachRefinements {t u : Ty} {p q : List Pred} + (hnrt : t.isRefined = false) (hnru : u.isRefined = false) + (htu : subCheck t u = true) (hq : ∀ x ∈ q, x ∈ p) : + subCheck (attachRefinements t (some p)) (attachRefinements u (some q)) = true := by + have hpt : t.peel = (t, []) := Ty.peel_of_not_refined hnrt + have hpu : u.peel = (u, []) := Ty.peel_of_not_refined hnru + rcases p with _ | ⟨x, xs⟩ + · rcases q with _ | ⟨y, ys⟩ + · simpa [attachRefinements] using htu + · exact absurd (hq y (by simp)) (by simp) + · have hlhs : attachRefinements t (some (x :: xs)) = .refined t (x :: xs) := by + cases t <;> simp_all [attachRefinements, Ty.isRefined] + rcases q with _ | ⟨y, ys⟩ + · rw [hlhs] + simp only [attachRefinements, subCheck, Ty.peel, hpt, hpu, deficit] + simpa using htu + · have hrhs : attachRefinements u (some (y :: ys)) = .refined u (y :: ys) := by + cases u <;> simp_all [attachRefinements, Ty.isRefined] + rw [hlhs, hrhs] + simp only [subCheck, Ty.peel, hpt, hpu, deficit, List.append_nil] + simp_all + exact ⟨fun h => hq.1.resolve_left h, fun a ha h => (hq.2 a ha).resolve_left h⟩ + +/-! ## Keyed slots + +A keyed slot materializes its payloads in the map's order, so the shape's fields +are the map's keys carrying the payloads' types. `KeyedRel` is that relation, and +the three keyed cases all read their slot through it. -/ + +/-- Two keyed lists carrying the same keys in the same order, payloads related by +`R`. -/ +def KeyedRel {α β} (R : α → β → Prop) : List (FieldKey × α) → List (FieldKey × β) → Prop + | [], [] => True + | (k, v) :: m, (k', t) :: kvs => k = k' ∧ R v t ∧ KeyedRel R m kvs + | _, _ => False + +/-- A key resolving on the left resolves on the right, to a related payload. -/ +theorem KeyedRel.lookup {α β} {R : α → β → Prop} : + ∀ {m : List (FieldKey × α)} {kvs : List (FieldKey × β)}, KeyedRel R m kvs → + ∀ {k v}, m.lookup k = some v → ∃ t, kvs.lookup k = some t ∧ R v t + | [], [], _, _, _, hl => by simp at hl + | [], _ :: _, h, _, _, _ => by simp [KeyedRel] at h + | _ :: _, [], h, _, _, _ => by simp [KeyedRel] at h + | (k, v) :: m, (k', t) :: kvs, h, k₀, v₀, hl => by + obtain ⟨hk, hR, hrest⟩ := h + subst hk + simp only [List.lookup_cons] at hl ⊢ + by_cases hbeq : (k₀ == k) = true + · rw [hbeq] at hl ⊢ + simp only at hl ⊢ + cases hl + exact ⟨t, rfl, hR⟩ + · simp only [Bool.not_eq_true] at hbeq + rw [hbeq] at hl ⊢ + simp only at hl ⊢ + exact KeyedRel.lookup hrest hl + +/-- A key resolving on the right resolves on the left, to a related payload — +the converse of [`KeyedRel.lookup`]. -/ +theorem KeyedRel.lookup' {α β} {R : α → β → Prop} : + ∀ {m : List (FieldKey × α)} {kvs : List (FieldKey × β)}, KeyedRel R m kvs → + ∀ {k t}, kvs.lookup k = some t → ∃ v, m.lookup k = some v ∧ R v t + | [], [], _, _, _, hl => by simp at hl + | [], _ :: _, h, _, _, _ => by simp [KeyedRel] at h + | _ :: _, [], h, _, _, _ => by simp [KeyedRel] at h + | (k, v) :: m, (k', t) :: kvs, h, k₀, t₀, hl => by + obtain ⟨hk, hR, hrest⟩ := h + subst hk + simp only [List.lookup_cons] at hl ⊢ + by_cases hbeq : (k₀ == k) = true + · rw [hbeq] at hl ⊢ + simp only at hl ⊢ + cases hl + exact ⟨v, rfl, hR⟩ + · simp only [Bool.not_eq_true] at hbeq + rw [hbeq] at hl ⊢ + simp only at hl ⊢ + exact KeyedRel.lookup' hrest hl + +/-- The keys of a related pair agree, so a key missing on the left is missing on +the right. -/ +theorem KeyedRel.keys {α β} {R : α → β → Prop} : + ∀ {m : List (FieldKey × α)} {kvs : List (FieldKey × β)}, KeyedRel R m kvs → + kvs.map Prod.fst = m.map Prod.fst + | [], [], _ => rfl + | [], _ :: _, h => by simp [KeyedRel] at h + | _ :: _, [], h => by simp [KeyedRel] at h + | (k, v) :: m, (k', t) :: kvs, h => by + obtain ⟨hk, -, hrest⟩ := h + subst hk + simpa using KeyedRel.keys hrest + +/-- `coalesce` materializes a keyed slot pointwise: the two `mapM`s it runs give +exactly `KeyedRel`. -/ +theorem coalesce_keyed_rel (pol : Bool) : + ∀ (m : List (FieldKey × CTy)) (payloads : List (Option Ty)) (ts : List Ty), + m.mapM (fun kv => coalesce pol kv.2) = .ok payloads → payloads.mapM id = some ts → + KeyedRel (fun v t => coalesce pol v = .ok (some t)) m ((m.map Prod.fst).zip ts) + | [], payloads, ts, hm, hp => by + cases mapM_ok_nil hm + cases mapM_some_nil hp + trivial + | (k, v) :: m, payloads, ts, hm, hp => by + obtain ⟨o, ps, hov, hps, rfl⟩ := mapM_ok_cons hm + obtain ⟨t, ts', hot, hpts, rfl⟩ := mapM_some_cons hp + have ho : o = some t := hot + subst ho + refine ⟨rfl, hov, ?_⟩ + exact coalesce_keyed_rel pol m ps ts' hps hpts + +/-- `coalesce` on a position whose only content is a variant slot and refinements. -/ +theorem coalesce_variant_ok (pol : Bool) {m : List (FieldKey × CTy)} + {c : Option (List Pred)} {ty : Ty} + (h : coalesce pol (.mk [] none (some m) none c) = .ok (some ty)) : + ∃ kvs, ty = attachRefinements (.variant kvs) c ∧ + KeyedRel (fun v t => coalesce pol v = .ok (some t)) m kvs := by + have hattach : m.attach.mapM (fun vp => coalesce pol vp.val.snd) + = m.mapM (fun kv => coalesce pol kv.2) := by + have hgen : ∀ (f : FieldKey × CTy → Except CoErr (Option Ty)), + m.attach.mapM (fun x => f x.1) = m.mapM f := by + intro f + simp + exact hgen (fun kv => coalesce pol kv.2) + -- Case on the slot's contribution first: that reduces the outer bind, so the + -- contribution's own shape is read off `hv` rather than through it. + rcases hv : varShapes pol (.mk [] none (some m) none c) with e | x <;> + rw [coalesce_var_only, hv] at h + · cases h + rcases x with _ | base + · cases h + cases h + rw [varShapes, hattach] at hv + rcases hpay : m.mapM (fun kv => coalesce pol kv.2) with e | payloads <;> rw [hpay] at hv + · cases hv + · -- The remaining bind reduces definitionally, which a type ascription is + -- enough to say. + replace hv : (Except.ok ((payloads.mapM id).map + (fun ts => Ty.variant ((m.map Prod.fst).zip ts))) : Except CoErr (Option Ty)) + = .ok (some base) := hv + rcases hts : payloads.mapM id with _ | ts <;> rw [hts] at hv + · cases hv + · cases hv + exact ⟨(m.map Prod.fst).zip ts, rfl, coalesce_keyed_rel pol m payloads ts hpay hts⟩ + +/-- `coalesce` on a position whose only content is a record slot and refinements: the +payloads materialize pointwise, and the shape is a tuple when the keys are dense +indices and a record when they are names. The two refusals — an empty field set and +mixed keys — do not materialize, and the sparse-index shape is unresolved. -/ +theorem coalesce_record_ok (pol : Bool) {m : List (FieldKey × CTy)} + {c : Option (List Pred)} {ty : Ty} + (h : coalesce pol (.mk [] (some m) none none c) = .ok (some ty)) : + m ≠ [] ∧ ∃ (ts : List Ty) (base : Ty), ty = attachRefinements base c ∧ + KeyedRel (fun v t => coalesce pol v = .ok (some t)) m ((m.map Prod.fst).zip ts) ∧ + ((∃ idxs, indexKeys m = some idxs ∧ byIndex m.length (idxs.zip ts) = some base) ∨ + (∃ names, nameKeys m = some names ∧ base = .record (names.zip ts))) := by + have hattach : m.attach.mapM (fun rp => coalesce pol rp.val.snd) + = m.mapM (fun kv => coalesce pol kv.2) := by + have hgen : ∀ (f : FieldKey × CTy → Except CoErr (Option Ty)), + m.attach.mapM (fun x => f x.1) = m.mapM f := by + intro f + simp + exact hgen (fun kv => coalesce pol kv.2) + rcases hr : recShapes pol (.mk [] (some m) none none c) with e | x <;> + rw [coalesce_rec_only, hr] at h + · cases h + rcases x with _ | base + · cases h + cases h + rw [recShapes, hattach] at hr + by_cases hm : m.isEmpty = true + · rw [if_pos hm] at hr + cases hr + rw [if_neg hm] at hr + refine ⟨fun hnil => hm (by simp [hnil]), ?_⟩ + rcases hidx : indexKeys m with _ | idxs <;> rw [hidx] at hr <;> try simp only at hr + · rcases hnm : nameKeys m with _ | names <;> rw [hnm] at hr <;> try simp only at hr + · cases hr + · rcases hpay : m.mapM (fun kv => coalesce pol kv.2) with e | payloads <;> rw [hpay] at hr + · cases hr + · replace hr : (Except.ok ((payloads.mapM id).map (fun ts => Ty.record (names.zip ts))) + : Except CoErr (Option Ty)) = .ok (some base) := hr + rcases hts : payloads.mapM id with _ | ts <;> rw [hts] at hr + · cases hr + · cases hr + exact ⟨ts, _, rfl, coalesce_keyed_rel pol m payloads ts hpay hts, + Or.inr ⟨names, rfl, rfl⟩⟩ + · rcases hpay : m.mapM (fun kv => coalesce pol kv.2) with e | payloads <;> rw [hpay] at hr + · cases hr + · replace hr : (if (idxs.length == m.length && + (List.range m.length).all (idxs.contains ·)) = true + then Except.ok ((payloads.mapM id).bind (fun ts => byIndex m.length (idxs.zip ts))) + else Except.ok none : Except CoErr (Option Ty)) = .ok (some base) := hr + by_cases hd : + (idxs.length == m.length && (List.range m.length).all (idxs.contains ·)) = true + · rw [if_pos hd] at hr + rcases hts : payloads.mapM id with _ | ts <;> rw [hts] at hr <;> + try simp only [Option.bind_some] at hr + · cases hr + · rcases htup : byIndex m.length (idxs.zip ts) with _ | tup <;> rw [htup] at hr + · cases hr + · cases hr + exact ⟨ts, base, rfl, coalesce_keyed_rel pol m payloads ts hpay hts, + Or.inl ⟨idxs, rfl, htup⟩⟩ + · rw [if_neg hd] at hr + cases hr + +/-- Dedup keeps a non-empty list non-empty, so a position with atoms contributes +a shape. -/ +theorem eraseDups_ne_nil {α} [BEq α] [LawfulBEq α] : + ∀ {l : List α}, l ≠ [] → l.eraseDups ≠ [] + | [], h => absurd rfl h + | x :: xs, _ => by + intro hz + have hmem : x ∈ (x :: xs).eraseDups := List.mem_eraseDups.mpr (by simp) + rw [hz] at hmem + simp at hmem + +/-- **Materializing means exactly one slot carries the position.** The four +contributions concatenate and `combine` accepts only a singleton, so a position +with two populated slots has no type — which is what lets every case of the +monotonicity lemma be about a single slot. -/ +theorem coalesce_shape (pol : Bool) {as : List Atom} + {r v : Option (List (FieldKey × CTy))} {f : Option (KindM × List CTy × CTy)} + {c : Option (List Pred)} {ty : Ty} + (h : coalesce pol (.mk as r v f c) = .ok (some ty)) : + (as ≠ [] ∧ r = none ∧ v = none ∧ f = none) ∨ + (as = [] ∧ (∃ m, r = some m) ∧ v = none ∧ f = none) ∨ + (as = [] ∧ r = none ∧ (∃ m, v = some m) ∧ f = none) ∨ + (as = [] ∧ r = none ∧ v = none ∧ ∃ g, f = some g) := by + rw [coalesce] at h + rcases hr : recShapes pol (.mk as r v f c) with e | rx <;> rw [hr] at h + · cases h + rcases hv : varShapes pol (.mk as r v f c) with e | vx <;> rw [hv] at h + · cases h + rcases hf : funShapes pol (.mk as r v f c) with e | fx <;> rw [hf] at h + · cases h + obtain ⟨t, hlen, -⟩ := combine_ok h + -- One shape survives, so the four contributions' lengths sum to one. The atom + -- contribution is non-empty exactly when the atom list is. + have hcount := congrArg List.length hlen + have hzero : ((as.map atomTy).eraseDups).length = 0 → as = [] := by + intro hz + rcases as with _ | ⟨a, as'⟩ + · rfl + · exact absurd (List.eq_nil_of_length_eq_zero hz) (eraseDups_ne_nil (by simp)) + have hpos : as ≠ [] → 0 < ((as.map atomTy).eraseDups).length := by + intro hne + rcases hd : ((as.map atomTy).eraseDups) with _ | ⟨x, xs⟩ + · exact absurd hd (eraseDups_ne_nil (by simpa using hne)) + · simp [hd] + rcases r with _ | mr <;> rcases v with _ | mv <;> rcases f with _ | g <;> + simp only [Option.isSome_none, Option.isSome_some, Bool.false_eq_true, if_false, if_true, + List.length_append, List.length_map, List.length_nil, List.length_cons, + Nat.add_zero, Nat.zero_add] at hcount + · exact Or.inl ⟨fun hnil => by rw [hnil] at hcount; simp at hcount, rfl, rfl, rfl⟩ + · refine Or.inr (Or.inr (Or.inr ⟨?_, rfl, rfl, ⟨g, rfl⟩⟩)) + exact hzero (by omega) + · refine Or.inr (Or.inr (Or.inl ⟨?_, rfl, ⟨mv, rfl⟩, rfl⟩)) + exact hzero (by omega) + · exact absurd hcount (by omega) + · refine Or.inr (Or.inl ⟨?_, ⟨mr, rfl⟩, rfl, rfl⟩) + exact hzero (by omega) + · exact absurd hcount (by omega) + · exact absurd hcount (by omega) + · exact absurd hcount (by omega) + +/-! ## Where the merge had to move a data domain + +The function case needs one thing `le` does not give it: at a negative position a +`data` slot's two domains agree. This is not a restriction on which types a data +domain may be — a data domain is refined whenever a filter narrows a collection, +which is most of them. It is a condition on the *pair*, saying the merge did not +have to move a data domain, and that is exactly when a bound exists: `subCheck` +reads a data domain invariantly, as `constrain_go` does when it reports +`ConstrainError::DataDomainMismatch`, so two collections over different domains +have nothing below both. Their join is the Σ over both candidates, which M5 adds. +-/ + +mutual + +def DataAgree (pol : Bool) : CTy → CTy → Bool + | .mk _ r₁ v₁ f₁ _, .mk _ r₂ v₂ f₂ _ => + (match r₁, r₂ with + | some m₁, some m₂ => DataAgreeKeys pol m₁ m₂ (m₁.map Prod.fst) + | _, _ => true) + && (match v₁, v₂ with + | some m₁, some m₂ => DataAgreeKeys pol m₁ m₂ (m₁.map Prod.fst) + | _, _ => true) + && (match f₁, f₂ with + | some (k₁, [d₁], cod₁), some (_, [d₂], cod₂) => + (if pol then true else if k₁ == KindM.data then eqv d₁ d₂ else true) + -- Both orders, because the function case reads its hypothesis in + -- both: a `data` slot needs the domain edge each way. + && DataAgree (!pol) d₁ d₂ && DataAgree (!pol) d₂ d₁ + && DataAgree pol cod₁ cod₂ + | _, _ => true) +termination_by a b => (sizeOf a + sizeOf b, 0) + +/-- The condition on the payloads a pair of keyed slots share (worklist form, as +`wfKeys`). A key only one side carries imposes nothing: the merge cannot move a +domain it did not combine. -/ +def DataAgreeKeys (pol : Bool) (m₁ m₂ : List (FieldKey × CTy)) : List FieldKey → Bool + | [] => true + | k :: ks => + (match h₁ : m₁.lookup k, h₂ : m₂.lookup k with + | some x, some y => DataAgree pol x y + | _, _ => true) + && DataAgreeKeys pol m₁ m₂ ks +termination_by ks => (sizeOf m₁ + sizeOf m₂, ks.length) +decreasing_by + · have h1 := lookup_sizeOf h₁ + have h2 := lookup_sizeOf h₂ + apply Prod.Lex.left + omega + · apply Prod.Lex.right + simp + +end + +/-- Pointwise reading of `DataAgreeKeys`, as `wfKeys_iff`. -/ +theorem DataAgreeKeys_iff {pol : Bool} {m₁ m₂ : List (FieldKey × CTy)} {ks : List FieldKey} : + DataAgreeKeys pol m₁ m₂ ks = true ↔ + ∀ k ∈ ks, ∀ x y, m₁.lookup k = some x → m₂.lookup k = some y → + DataAgree pol x y = true := by + induction ks with + | nil => simp [DataAgreeKeys] + | cons k ks ih => + rw [DataAgreeKeys, Bool.and_eq_true, ih] + constructor + · intro ⟨hhead, htail⟩ k' hk' + rcases List.mem_cons.mp hk' with h | h + · subst h + intro x y hx hy + rw [hx, hy] at hhead + exact hhead + · exact htail k' h + · intro h + refine ⟨?_, fun k' hk' => h k' (by simp [hk'])⟩ + rcases hx : m₁.lookup k with _ | x + · rfl + · rcases hy : m₂.lookup k with _ | y + · rfl + · exact h k (by simp) x y hx hy + +/-! ## The shapes of two related positions agree + +`eqv` requires the same slot *presence* on both sides, and a merge leaves a slot +absent only when both operands do, so a slot the lower operand carries and the +upper one lacks refutes `le` outright. The atom lists are the one slot that +compares by containment rather than presence. -/ + +theorem le_atoms_sub {pol : Bool} {as bs : List Atom} {r v f c r' v' f' c'} + (hle : le pol (.mk as r v f c) (.mk bs r' v' f' c')) : ∀ x ∈ as, x ∈ bs := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨hat, -⟩, -⟩, -⟩, -⟩, -⟩ := hle + intro x hx + have := (List.all_eq_true.mp hat) x (by simp [hx]) + simpa using this + +theorem le_rec_absurd {pol : Bool} {as bs : List Atom} {mr : List (FieldKey × CTy)} + {v f c v' f' c'} (hle : le pol (.mk as (some mr) v f c) (.mk bs none v' f' c')) : False := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨-, hrec⟩, -⟩, -⟩, -⟩ := hle + simp at hrec + +theorem le_var_absurd {pol : Bool} {as bs : List Atom} {mv : List (FieldKey × CTy)} + {r f c r' f' c'} (hle : le pol (.mk as r (some mv) f c) (.mk bs r' none f' c')) : False := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨-, -⟩, -⟩, hvar⟩, -⟩, -⟩ := hle + simp at hvar + +theorem le_fun_absurd {pol : Bool} {as bs : List Atom} {g : KindM × List CTy × CTy} + {r v c r' v' c'} (hle : le pol (.mk as r v (some g) c) (.mk bs r' v' none c')) : False := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨-, -⟩, -⟩, -⟩, hfn⟩, -⟩ := hle + simp at hfn + +/-! ## Inverting `le` on a keyed slot + +A slot's merge is one of two keyed operations, and which one it is depends on the +slot and the polarity together: records intersect at a positive position and unite +at a negative one, variants the other way. The two inversions below are stated on +the map operation rather than the slot, so each slot's four cases are two +applications apiece. -/ + +/-- A united map is `eqv` to the upper operand only if the lower operand's keys +are all the upper's, with the shared payloads related. A key held by the lower +operand alone survives the union, and the upper operand has nothing to match it. -/ +theorem le_of_unionMap {pol : Bool} {m₁ m₂ : List (FieldKey × CTy)} + (h₁ : subKeys (unionMap pol m₁ m₂) m₂ ((unionMap pol m₁ m₂).map Prod.fst) = true) : + ∀ k v, m₁.lookup k = some v → ∃ w, m₂.lookup k = some w ∧ le pol v w := by + intro k v hv + rcases hw : m₂.lookup k with _ | w + · have hM : (unionMap pol m₁ m₂).lookup k = some v := by + rw [unionMap_lookup, hv, hw] + obtain ⟨x, y, -, hy, -⟩ := subKeys_iff.mp h₁ k (mem_keys_of_lookup hM) + rw [hw] at hy + cases hy + · have hM : (unionMap pol m₁ m₂).lookup k = some (merge pol v w) := by + rw [unionMap_lookup, hv, hw] + refine ⟨w, rfl, ?_⟩ + obtain ⟨x, y, hx, hy, heq⟩ := subKeys_iff.mp h₁ k (mem_keys_of_lookup hM) + rw [hM] at hx + rw [hw] at hy + cases hx + cases hy + exact heq + +/-- An intersected map is `eqv` to the upper operand only if the upper operand's +keys are all the lower's, with the payloads related. The intersection drops a key +the lower operand lacks, and then the upper operand has a key it cannot match. -/ +theorem le_of_interMap {pol : Bool} {m₁ m₂ : List (FieldKey × CTy)} + (h₁ : subKeys (interMap pol m₁ m₂) m₂ ((interMap pol m₁ m₂).map Prod.fst) = true) + (h₂ : subKeys m₂ (interMap pol m₁ m₂) (m₂.map Prod.fst) = true) : + ∀ k w, m₂.lookup k = some w → ∃ v, m₁.lookup k = some v ∧ le pol v w := by + intro k w hw + obtain ⟨x, y, -, hy, -⟩ := subKeys_iff.mp h₂ k (mem_keys_of_lookup hw) + rcases hv : m₁.lookup k with _ | v + · rw [interMap_lookup, hv, hw] at hy + simp at hy + · refine ⟨v, rfl, ?_⟩ + have hM : (interMap pol m₁ m₂).lookup k = some (merge pol v w) := by + rw [interMap_lookup, hv, hw] + obtain ⟨x', y', hx', hy', heq⟩ := subKeys_iff.mp h₁ k (mem_keys_of_lookup hM) + rw [hM] at hx' + rw [hw] at hy' + cases hx' + cases hy' + exact heq + +/-- The record slot's two `subKeys` facts, with the merge's shape reduced. Records +intersect at a positive position and unite at a negative one — the opposite of the +variant slot, which is what makes their variance opposite. -/ +theorem eqv_record_slot {pol : Bool} {m₁ m₂ : List (FieldKey × CTy)} + {ca cb : Option (List Pred)} + (hle : le pol (.mk [] (some m₁) none none ca) (.mk [] (some m₂) none none cb)) : + (if pol then + subKeys (interMap pol m₁ m₂) m₂ ((interMap pol m₁ m₂).map Prod.fst) = true ∧ + subKeys m₂ (interMap pol m₁ m₂) (m₂.map Prod.fst) = true + else + subKeys (unionMap pol m₁ m₂) m₂ ((unionMap pol m₁ m₂).map Prod.fst) = true ∧ + subKeys m₂ (unionMap pol m₁ m₂) (m₂.map Prod.fst) = true) := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨-, -⟩, hrec⟩, -⟩, -⟩, -⟩ := hle + cases pol + · simp only [Bool.false_eq_true, if_false] at hrec + rw [← unionMap] at hrec + simpa using hrec + · simpa only [if_true] using hrec + +/-- The variant slot's two `subKeys` facts, with the merge's shape reduced. -/ +theorem eqv_variant_slot {pol : Bool} {m₁ m₂ : List (FieldKey × CTy)} + {ca cb : Option (List Pred)} + (hle : le pol (.mk [] none (some m₁) none ca) (.mk [] none (some m₂) none cb)) : + (if pol then + subKeys (unionMap pol m₁ m₂) m₂ ((unionMap pol m₁ m₂).map Prod.fst) = true ∧ + subKeys m₂ (unionMap pol m₁ m₂) (m₂.map Prod.fst) = true + else + subKeys (interMap pol m₁ m₂) m₂ ((interMap pol m₁ m₂).map Prod.fst) = true ∧ + subKeys m₂ (interMap pol m₁ m₂) (m₂.map Prod.fst) = true) := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨-, -⟩, -⟩, hvar⟩, -⟩, -⟩ := hle + cases pol + · simpa only [Bool.false_eq_true, if_false] using hvar + · simp only [if_true] at hvar + rw [← unionMap] at hvar + simpa using hvar + +/-- `subCheck`'s keyed lookups agree with `List.lookup`: both find the first +binding, and `BEq` on the key is lawful. -/ +theorem lookupBy_eq_lookup {α} [BEq α] [LawfulBEq α] (l : List (α × Ty)) (k : α) : + lookupBy l k = List.lookup k l := by + induction l with + | nil => simp [lookupBy] + | cons hd tl ih => + obtain ⟨k', t⟩ := hd + simp only [lookupBy, List.find?_cons, List.lookup_cons] + by_cases hk : k = k' + · subst hk + simp + · rw [beq_eq_false_iff_ne.mpr hk, beq_eq_false_iff_ne.mpr (Ne.symm hk)] + simpa [lookupBy] using ih + +/-- Every entry of a related pair's right side resolves on the left, given +duplicate-free keys — which `wf` supplies. -/ +theorem KeyedRel.mem {α β} {R : α → β → Prop} : + ∀ {m : List (FieldKey × α)} {kvs : List (FieldKey × β)}, KeyedRel R m kvs → + nodupKeys (m.map Prod.fst) = true → + ∀ e ∈ kvs, ∃ v, m.lookup e.1 = some v ∧ R v e.2 + | [], [], _, _, _, he => by simp at he + | [], _ :: _, h, _, _, _ => by simp [KeyedRel] at h + | _ :: _, [], h, _, _, _ => by simp [KeyedRel] at h + | (k, v) :: m, (k', t) :: kvs, h, hnd, e, he => by + obtain ⟨hk, hR, hrest⟩ := h + subst hk + simp only [List.map_cons, nodupKeys, Bool.and_eq_true] at hnd + rcases List.mem_cons.mp he with rfl | he' + · exact ⟨v, by simp, hR⟩ + · obtain ⟨v', hv', hR'⟩ := KeyedRel.mem hrest hnd.2 e he' + have hne : e.1 ≠ k := by + intro heq + have hmem : k ∈ m.map Prod.fst := by + rw [← heq, ← KeyedRel.keys hrest] + exact List.mem_map_of_mem he' + simp [hmem] at hnd + refine ⟨v', ?_, hR'⟩ + rw [List.lookup_cons, beq_eq_false_iff_ne.mpr hne] + exact hv' + +/-- `subTags` from a per-entry statement: it walks the left type's tags in order, +so an entry-wise fact is exactly what it consumes. -/ +theorem subTags_of_mem : ∀ {a b : List (FieldKey × Ty)}, + (∀ e ∈ a, ∃ u, List.lookup e.1 b = some u ∧ subCheck e.2 u = true) → subTags b a = true + | [], b, _ => by rw [subTags] + | (k, t) :: rest, b, h => by + obtain ⟨u, hu, hsub⟩ := h (k, t) (by simp) + rw [subTags, Bool.and_eq_true] + refine ⟨?_, subTags_of_mem fun e he => h e (List.mem_cons_of_mem _ he)⟩ + split + · rename_i t0 hlk + rw [lookupBy_eq_lookup] at hlk + simp only [hu, Option.some.injEq] at hlk + subst hlk + exact hsub + · rename_i hlk + rw [lookupBy_eq_lookup] at hlk + rw [hu] at hlk + cases hlk + +/-- Looking a key up through an injective re-tagging of the key list. -/ +theorem lookup_zip_map_key {α β γ} [BEq α] [LawfulBEq α] [BEq β] [LawfulBEq β] + (g : α → β) (hg : ∀ x y, g x = g y → x = y) : + ∀ (ks : List α) (vs : List γ) (k : α), + List.lookup (g k) ((ks.map g).zip vs) = List.lookup k (ks.zip vs) + | [], vs, k => by simp + | k' :: ks, [], k => by simp + | k' :: ks, v :: vs, k => by + simp only [List.map_cons, List.zip_cons_cons, List.lookup_cons] + by_cases hk : k = k' + · subst hk + simp + · rw [beq_eq_false_iff_ne.mpr hk, beq_eq_false_iff_ne.mpr (fun h => hk (hg _ _ h))] + exact lookup_zip_map_key g hg ks vs k + +/-- A dense index map's tuple, read back: its payloads are the map's, by index. -/ +theorem byIndex_get {n : Nat} {kvs : List (Nat × Ty)} {tup : Ty} + (h : byIndex n kvs = some tup) : + ∃ ts, tup = .tuple ts ∧ ts.length = n ∧ + ∀ (i : Nat) (y : Ty), i < n → ts[i]? = some y → List.lookup i kvs = some y := by + rw [byIndex] at h + simp only [Option.map_eq_some_iff] at h + obtain ⟨ts, hts, rfl⟩ := h + obtain ⟨hlen, hget⟩ := mapM_some_get hts + refine ⟨ts, rfl, by simpa using hlen, fun i y hi hy => ?_⟩ + exact hget i i y (by simp [hi]) hy + +/-- `subSeq` from a positional statement: it pairs the tuples off from the front +and stops at the shorter right-hand side, which is tuple width subtyping. -/ +theorem subSeq_of_get : ∀ {a b : List Ty}, b.length ≤ a.length → + (∀ (i : Nat) (x y : Ty), a[i]? = some x → b[i]? = some y → subCheck x y = true) → + subSeq a b = true + | _, [], _, _ => by rw [subSeq] + | [], _ :: _, hlen, _ => by simp at hlen + | x :: xs, y :: ys, hlen, h => by + rw [subSeq, Bool.and_eq_true] + refine ⟨h 0 x y (by simp) (by simp), subSeq_of_get (by simpa using hlen) fun i u v hu hv => ?_⟩ + exact h (i + 1) u v (by simpa using hu) (by simpa using hv) + +/-- `subFields` from a per-field statement: it walks the right type's fields and +demands each on the left, which is record width subtyping. -/ +theorem subFields_of_mem : ∀ {a b : List (String × Ty)}, + (∀ e ∈ b, ∃ u, List.lookup e.1 a = some u ∧ subCheck u e.2 = true) → subFields a b = true + | _, [], _ => by rw [subFields] + | a, (n, t) :: rest, h => by + obtain ⟨u, hu, hsub⟩ := h (n, t) (by simp) + rw [subFields, Bool.and_eq_true] + refine ⟨?_, subFields_of_mem fun e he => h e (List.mem_cons_of_mem _ he)⟩ + split + · rename_i t0 hlk + rw [lookupBy_eq_lookup] at hlk + simp only [hu, Option.some.injEq] at hlk + subst hlk + exact hsub + · rename_i hlk + rw [lookupBy_eq_lookup] at hlk + rw [hu] at hlk + cases hlk + +/-- A list of duplicate-free keys is no longer than one containing all of them. -/ +theorem nodupKeys_length_le : ∀ {a b : List FieldKey}, nodupKeys a = true → + (∀ x ∈ a, x ∈ b) → a.length ≤ b.length + | [], _, _, _ => by simp + | x :: as, b, hnd, hsub => by + simp only [nodupKeys, Bool.and_eq_true, Bool.not_eq_eq_eq_not, Bool.not_true] at hnd + have hxb : x ∈ b := hsub x (by simp) + have hsub' : ∀ y ∈ as, y ∈ b.erase x := by + intro y hy + have hne : y ≠ x := by + intro heq + subst heq + simp [hy] at hnd + exact (List.mem_erase_of_ne hne).mpr (hsub y (by simp [hy])) + have hle := nodupKeys_length_le hnd.2 hsub' + rw [List.length_erase_of_mem hxb] at hle + have hpos : 0 < b.length := List.length_pos_of_mem hxb + simp only [List.length_cons] + omega + +/-- Re-tagging a key list distributes over the zip. -/ +theorem zip_map_left {α β γ} (g : α → β) : + ∀ (ks : List α) (vs : List γ), + (ks.map g).zip vs = (ks.zip vs).map (fun kv => (g kv.1, kv.2)) + | [], vs => by simp + | k :: ks, [] => by simp + | k :: ks, v :: vs => by simpa using zip_map_left g ks vs + +/-- An index key is not a name key. -/ +theorem idx_ne_name {k : FieldKey} {idxs : List Nat} {names : List String} + (hi : k ∈ idxs.map FieldKey.idx) (hn : k ∈ names.map FieldKey.name) : False := by + obtain ⟨n, -, rfl⟩ := List.mem_map.mp hi + obtain ⟨s, -, hs⟩ := List.mem_map.mp hn + cases hs + +/-- A non-empty contained map shares a key, so key lists that cannot share one +refute the containment. Two record slots related by `le` therefore materialize at +the same shape: a map of names shares no key with a map of indices. -/ +theorem keys_disjoint_absurd {ms ss : List (FieldKey × CTy)} + (hsub : ∀ k ∈ ss.map Prod.fst, k ∈ ms.map Prod.fst) (hne : ss ≠ []) + (hdisj : ∀ k, k ∈ ms.map Prod.fst → k ∈ ss.map Prod.fst → False) : False := by + rcases ss with _ | ⟨⟨k, w⟩, rest⟩ + · exact hne rfl + · have hk : k ∈ ((k, w) :: rest).map Prod.fst := by simp + exact hdisj k (hsub k hk) hk + +/-- The record slot's comparison, stated once for both polarities: the contained +map's materialization is the right-hand side, because a record with more fields is +the subtype and a merge narrows the field set toward whichever operand `le` puts +above. `R` is materialization and `Q` is the payload relation. -/ +theorem subCheck_record_shapes {R : CTy → Ty → Prop} {Q : CTy → CTy → Prop} + {ms ss : List (FieldKey × CTy)} {tsm tss : List Ty} {tm tsub : Ty} + (hndm : nodupKeys (ms.map Prod.fst) = true) + (hnds : nodupKeys (ss.map Prod.fst) = true) + (hrelm : KeyedRel R ms ((ms.map Prod.fst).zip tsm)) + (hrels : KeyedRel R ss ((ss.map Prod.fst).zip tss)) + (hnes : ss ≠ []) + (hsub : ∀ k w, ss.lookup k = some w → ∃ v, ms.lookup k = some v ∧ Q v w) + (hstep : ∀ k v w tv tw, ms.lookup k = some v → ss.lookup k = some w → Q v w → + R v tv → R w tw → subCheck tv tw = true) + (hm : (∃ idxs, indexKeys ms = some idxs ∧ byIndex ms.length (idxs.zip tsm) = some tm) ∨ + (∃ names, nameKeys ms = some names ∧ tm = .record (names.zip tsm))) + (hs : (∃ idxs, indexKeys ss = some idxs ∧ byIndex ss.length (idxs.zip tss) = some tsub) ∨ + (∃ names, nameKeys ss = some names ∧ tsub = .record (names.zip tss))) : + subCheck tm tsub = true ∧ tm.isRefined = false ∧ tsub.isRefined = false := by + have hkeys : ∀ k ∈ ss.map Prod.fst, k ∈ ms.map Prod.fst := by + intro k hk + obtain ⟨w, hw⟩ := Option.isSome_iff_exists.mp (lookup_of_mem_keys hk) + obtain ⟨v, hv, -⟩ := hsub k w hw + exact mem_keys_of_lookup hv + rcases hm with ⟨idxs₁, hi₁, hb₁⟩ | ⟨names₁, hn₁, rfl⟩ <;> + rcases hs with ⟨idxs₂, hi₂, hb₂⟩ | ⟨names₂, hn₂, rfl⟩ + · -- Both index-keyed: tuples, compared position by position. + obtain ⟨u₁, rfl, hlen₁, hget₁⟩ := byIndex_get hb₁ + obtain ⟨u₂, rfl, hlen₂, hget₂⟩ := byIndex_get hb₂ + have hlen : u₂.length ≤ u₁.length := by + have hkl := nodupKeys_length_le hnds hkeys + simp only [List.length_map] at hkl + omega + refine ⟨?_, by simp [Ty.isRefined], by simp [Ty.isRefined]⟩ + rw [subCheck] + refine subSeq_of_get hlen fun i x y hx hy => ?_ + have hinj : ∀ a b : Nat, FieldKey.idx a = FieldKey.idx b → a = b := by + intro a b h + cases h + rfl + have hix : i < u₁.length := by + rcases Nat.lt_or_ge i u₁.length with h | h + · exact h + · rw [List.getElem?_eq_none h] at hx + cases hx + have hiy : i < u₂.length := by + rcases Nat.lt_or_ge i u₂.length with h | h + · exact h + · rw [List.getElem?_eq_none h] at hy + cases hy + have hkss : ((ss.map Prod.fst).zip tss).lookup (FieldKey.idx i) = some y := by + rw [indexKeys_keys hi₂, lookup_zip_map_key FieldKey.idx hinj] + exact hget₂ i y (by omega) hy + have hkms : ((ms.map Prod.fst).zip tsm).lookup (FieldKey.idx i) = some x := by + rw [indexKeys_keys hi₁, lookup_zip_map_key FieldKey.idx hinj] + exact hget₁ i x (by omega) hx + obtain ⟨w, hw, hRw⟩ := hrels.lookup' hkss + obtain ⟨v, hv, hQ⟩ := hsub _ w hw + obtain ⟨u, hu, hRv⟩ := hrelm.lookup hv + rw [hkms] at hu + simp only [Option.some.injEq] at hu + subst hu + exact hstep _ v w x y hv hw hQ hRv hRw + · exact absurd (keys_disjoint_absurd hkeys hnes fun k hk₁ hk₂ => + idx_ne_name (indexKeys_keys hi₁ ▸ hk₁) (nameKeys_keys hn₂ ▸ hk₂)) not_false + · exact absurd (keys_disjoint_absurd hkeys hnes fun k hk₁ hk₂ => + idx_ne_name (indexKeys_keys hi₂ ▸ hk₂) (nameKeys_keys hn₁ ▸ hk₁)) not_false + · -- Both name-keyed: records, compared field by field. + refine ⟨?_, by simp [Ty.isRefined], by simp [Ty.isRefined]⟩ + rw [subCheck] + refine subFields_of_mem fun e he => ?_ + have hmem : (FieldKey.name e.1, e.2) ∈ (ss.map Prod.fst).zip tss := by + rw [nameKeys_keys hn₂, zip_map_left] + exact List.mem_map_of_mem he + obtain ⟨w, hw, hRw⟩ := hrels.mem hnds _ hmem + obtain ⟨v, hv, hQ⟩ := hsub _ w hw + obtain ⟨u, hu, hRv⟩ := hrelm.lookup hv + refine ⟨u, ?_, hstep _ v w u e.2 hv hw hQ hRv hRw⟩ + rw [nameKeys_keys hn₁] at hu + rw [lookup_zip_map_key FieldKey.name (fun _ _ h => by cases h; rfl)] at hu + exact hu + +/-- The record case of `MonoAt`. A record's fields are covariant and its field set +contravariant, and the merge intersects the set at a positive position and unites +it at a negative one, so in both the contained map's materialization is the +right-hand side. -/ +theorem mono_record (pol : Bool) {m₁ m₂ : List (FieldKey × CTy)} + {ca cb : Option (List Pred)} {ta tb : Ty} + (hwa : wf (.mk [] (some m₁) none none ca) = true) + (hwb : wf (.mk [] (some m₂) none none cb) = true) + (ih : ∀ k v w tv tw, m₁.lookup k = some v → m₂.lookup k = some w → le pol v w → + coalesce pol v = .ok (some tv) → coalesce pol w = .ok (some tw) → + (if pol then subCheck tv tw else subCheck tw tv) = true) + (hle : le pol (.mk [] (some m₁) none none ca) (.mk [] (some m₂) none none cb)) + (ha : coalesce pol (.mk [] (some m₁) none none ca) = .ok (some ta)) + (hb : coalesce pol (.mk [] (some m₂) none none cb) = .ok (some tb)) : + (if pol then subCheck ta tb else subCheck tb ta) = true := by + obtain ⟨hne₁, ts₁, base₁, rfl, hrel₁, hshape₁⟩ := coalesce_record_ok pol ha + obtain ⟨hne₂, ts₂, base₂, rfl, hrel₂, hshape₂⟩ := coalesce_record_ok pol hb + rw [wf.eq_def] at hwa hwb + simp only [Bool.and_eq_true] at hwa hwb + have hnd₁ : nodupKeys (m₁.map Prod.fst) = true := hwa.1.1.1.2 + have hnd₂ : nodupKeys (m₂.map Prod.fst) = true := hwb.1.1.1.2 + have hrefinements : refinementsEqv (mergeRefinements pol ca cb) cb = true := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + exact hle.2 + rcases ca with _ | p + · exact absurd hwa.2 (by simp) + rcases cb with _ | q + · exact absurd hwb.2 (by simp) + cases pol + · simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + obtain ⟨hsc, hnr₂, hnr₁⟩ := + subCheck_record_shapes (R := fun v t => coalesce false v = .ok (some t)) + (Q := fun a b => le false b a) hnd₂ hnd₁ hrel₂ hrel₁ hne₁ + (fun k w hw => le_of_unionMap (eqv_record_slot hle).1 k w hw) + (fun k v w tv tw hv hw hQ hRv hRw => by + simpa using ih k w v tw tv hw hv hQ hRw hRv) + hshape₂ hshape₁ + exact subCheck_attachRefinements hnr₂ hnr₁ hsc fun x hx => + hrefinements.1 x (List.mem_append_left _ hx) + · simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + obtain ⟨hsc, hnr₁, hnr₂⟩ := + subCheck_record_shapes (R := fun v t => coalesce true v = .ok (some t)) + (Q := le true) hnd₁ hnd₂ hrel₁ hrel₂ hne₂ + (fun k w hw => + le_of_interMap (eqv_record_slot hle).1 (eqv_record_slot hle).2 k w hw) + (fun k v w tv tw hv hw hQ hRv hRw => by + simpa using ih k v w tv tw hv hw hQ hRv hRw) + hshape₁ hshape₂ + exact subCheck_attachRefinements hnr₁ hnr₂ hsc fun x hx => + (List.mem_filter.mp (hrefinements.2 x hx)).1 + +/-- The variant case of `MonoAt`, taking the payloads' monotonicity as `ih`. The +tags of a variant are contravariant in `subCheck`, and the merge unions them at a +positive position and intersects them at a negative one, which is the same +direction read twice. -/ +theorem mono_variant (pol : Bool) {m₁ m₂ : List (FieldKey × CTy)} + {ca cb : Option (List Pred)} {ta tb : Ty} + (hwa : wf (.mk [] none (some m₁) none ca) = true) + (hwb : wf (.mk [] none (some m₂) none cb) = true) + (ih : ∀ k v w tv tw, m₁.lookup k = some v → m₂.lookup k = some w → le pol v w → + coalesce pol v = .ok (some tv) → coalesce pol w = .ok (some tw) → + (if pol then subCheck tv tw else subCheck tw tv) = true) + (hle : le pol (.mk [] none (some m₁) none ca) (.mk [] none (some m₂) none cb)) + (ha : coalesce pol (.mk [] none (some m₁) none ca) = .ok (some ta)) + (hb : coalesce pol (.mk [] none (some m₂) none cb) = .ok (some tb)) : + (if pol then subCheck ta tb else subCheck tb ta) = true := by + obtain ⟨kvs₁, rfl, hrel₁⟩ := coalesce_variant_ok pol ha + obtain ⟨kvs₂, rfl, hrel₂⟩ := coalesce_variant_ok pol hb + rw [wf.eq_def] at hwa hwb + simp only [Bool.and_eq_true] at hwa hwb + have hnd₁ : nodupKeys (m₁.map Prod.fst) = true := hwa.1.1.2.2 + have hnd₂ : nodupKeys (m₂.map Prod.fst) = true := hwb.1.1.2.2 + have hrefinements : refinementsEqv (mergeRefinements pol ca cb) cb = true := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + exact hle.2 + have hnr : ∀ kvs : List (FieldKey × Ty), (Ty.variant kvs).isRefined = false := by + intro kvs + simp [Ty.isRefined] + rcases ca with _ | p + · exact absurd hwa.2 (by simp) + rcases cb with _ | q + · exact absurd hwb.2 (by simp) + cases pol + · -- Negative: the tags intersect, so `m₂`'s entries drive the comparison. + simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + refine subCheck_attachRefinements (hnr _) (hnr _) ?_ fun x hx => + hrefinements.1 x (List.mem_append_left _ hx) + rw [subCheck] + refine subTags_of_mem fun e he => ?_ + obtain ⟨w, hw, hcw⟩ := hrel₂.mem hnd₂ e he + obtain ⟨v, hv, hlevw⟩ := le_of_interMap (eqv_variant_slot hle).1 (eqv_variant_slot hle).2 e.1 w hw + obtain ⟨u, hu, hcv⟩ := hrel₁.lookup hv + exact ⟨u, hu, ih e.1 v w u e.2 hv hw hlevw hcv hcw⟩ + · -- Positive: the tags union, so `m₁`'s entries drive it. + simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + refine subCheck_attachRefinements (hnr _) (hnr _) ?_ fun x hx => + (List.mem_filter.mp (hrefinements.2 x hx)).1 + rw [subCheck] + refine subTags_of_mem fun e he => ?_ + obtain ⟨v, hv, hcv⟩ := hrel₁.mem hnd₁ e he + obtain ⟨w, hw, hlevw⟩ := le_of_unionMap (eqv_variant_slot hle).1 e.1 v hv + obtain ⟨u, hu, hcw⟩ := hrel₂.lookup hw + exact ⟨u, hu, ih e.1 v w e.2 u hv hw hlevw hcv hcw⟩ + +/-- An atom materializes to a leaf: never a refinement, and a subtype of itself. -/ +theorem atomTy_leaf (α : Atom) : + (atomTy α).isRefined = false ∧ subCheck (atomTy α) (atomTy α) = true := by + cases α <;> simp [atomTy, Ty.isRefined, subCheck] + +/-- The atoms case of `MonoAt`: a position whose only content is atoms and +refinements. Both operands materialize to the same atom, because the merge unions the +atom lists and `le` says the union is the upper operand's, and the refinement slots +then compare by containment in the polarity's direction. -/ +theorem mono_atoms (pol : Bool) {as bs : List Atom} {ca cb : Option (List Pred)} + {ta tb : Ty} + (hwa : wf (.mk as none none none ca) = true) + (hwb : wf (.mk bs none none none cb) = true) + (hle : le pol (.mk as none none none ca) (.mk bs none none none cb)) + (ha : coalesce pol (.mk as none none none ca) = .ok (some ta)) + (hb : coalesce pol (.mk bs none none none cb) = .ok (some tb)) : + (if pol then subCheck ta tb else subCheck tb ta) = true := by + rw [coalesce_atoms] at ha hb + -- Exactly one atom survives dedup on each side, or the position did not + -- materialize. + rcases hda : (as.map atomTy).eraseDups with _ | ⟨α, αs⟩ <;> rw [hda] at ha + · exact absurd ha (by simp) + rcases αs with _ | ⟨_, _⟩ + case cons.cons => exact absurd ha (by simp) + rcases hdb : (bs.map atomTy).eraseDups with _ | ⟨β, βs⟩ <;> rw [hdb] at hb + · exact absurd hb (by simp) + rcases βs with _ | ⟨_, _⟩ + case cons.cons => exact absurd hb (by simp) + simp only [Except.ok.injEq, Option.some.injEq] at ha hb + subst ha hb + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨hat, -⟩, -⟩, -⟩, -⟩, hcl⟩ := hle + -- The atom lists union, so `le` forces `as ⊆ bs`, and a singleton dedup on + -- each side then pins one atom on both. + have hmemα : α ∈ as.map atomTy := List.mem_eraseDups.mp (by rw [hda]; simp) + obtain ⟨a, hain, rfl⟩ := List.mem_map.mp hmemα + have hab : a ∈ bs := by + have := (List.all_eq_true.mp hat) a (by simp [hain]) + simpa using this + have hαβ : atomTy a = β := by + have := List.mem_eraseDups.mpr (List.mem_map_of_mem (f := atomTy) hab) + rw [hdb] at this + simpa using this + subst hαβ + -- A position with atoms has a refinement slot (`wf`), so both sides are `some`. + have hasne : ¬ as.isEmpty = true := by + intro h + rw [List.isEmpty_iff.mp h] at hain + simp at hain + have hbsne : ¬ bs.isEmpty = true := by + intro h + rw [List.isEmpty_iff.mp h] at hab + simp at hab + rw [wf.eq_def] at hwa hwb + simp only [Bool.and_eq_true] at hwa hwb + rcases ca with _ | p + · exact absurd hwa.2 (by simp [hasne]) + rcases cb with _ | q + · exact absurd hwb.2 (by simp [hbsne]) + obtain ⟨hnr, hrefl⟩ := atomTy_leaf a + -- The refinement slots then compare by containment, in the polarity's direction: + -- a positive merge intersects and a negative one appends. + cases pol + · simp only [mergeRefinements, refinementsEqv_iff] at hcl + simpa using subCheck_attachRefinements hnr hnr hrefl fun x hx => + hcl.1 x (List.mem_append_left _ hx) + · simp only [mergeRefinements, refinementsEqv_iff] at hcl + simpa using subCheck_attachRefinements hnr hnr hrefl fun x hx => + (List.mem_filter.mp (hcl.2 x hx)).1 + +/-- The atoms case, as an instance of the gate the sample measures. -/ +theorem monoAt_atoms (pol : Bool) {as bs : List Atom} {ca cb : Option (List Pred)} + (hwa : wf (.mk as none none none ca) = true) + (hwb : wf (.mk bs none none none cb) = true) : + MonoAt pol (.mk as none none none ca) (.mk bs none none none cb) = true := by + rw [MonoAt] + split + · rename_i hle + split + · rename_i ta tb ha hb + exact mono_atoms pol hwa hwb hle ha hb + · rfl + · rfl + +/-! ## The function case + +Under `wf` a function slot carries one domain, so both readings coincide: a `data` +slot's single alternative survives dedup, and a `compute` slot's meet-fold over an +empty tail is that alternative. -/ + +/-- `coalesce` on a position whose only content is a `data` function slot. -/ +theorem coalesce_fun_data_ok (pol : Bool) {d cod : CTy} {c : Option (List Pred)} + {ty : Ty} (h : coalesce pol (.mk [] none none (some (.data, [d], cod)) c) = .ok (some ty)) : + ∃ dt ct, coalesce (!pol) d = .ok (some dt) ∧ coalesce pol cod = .ok (some ct) ∧ + ty = attachRefinements (.fn none .data dt ct) c := by + rcases hf : funShapes pol (.mk [] none none (some (KindM.data, [d], cod)) c) with e | x <;> + rw [coalesce_fun_only, hf] at h + · cases h + rcases x with _ | base + · cases h + cases h + rw [funShapes] at hf + simp at hf + rcases hc : coalesce pol cod with e | oc + · simp [hc] at hf + cases hf + rcases hd : coalesce (!pol) d with e | od + · simp [hc, hd] at hf + cases hf + rcases od with _ | dt + · simp [hc, hd, funTy, Functor.map, Except.map, List.eraseDups, List.eraseDupsBy, + List.eraseDupsBy.loop] at hf + cases hf + rcases oc with _ | ct + · simp [hc, hd, funTy, Functor.map, Except.map, List.eraseDups, List.eraseDupsBy, + List.eraseDupsBy.loop] at hf + cases hf + refine ⟨dt, ct, rfl, rfl, ?_⟩ + rw [hc, hd] at hf + replace hf : (Except.ok (some (Ty.fn none FunKind.data dt ct)) : Except CoErr (Option Ty)) + = .ok (some base) := hf + cases hf + rfl + +/-- `coalesce` on a position whose only content is a `compute` function slot. -/ +theorem coalesce_fun_compute_ok (pol : Bool) {d cod : CTy} {c : Option (List Pred)} + {ty : Ty} + (h : coalesce pol (.mk [] none none (some (.compute, [d], cod)) c) = .ok (some ty)) : + ∃ dt ct, coalesce (!pol) d = .ok (some dt) ∧ coalesce pol cod = .ok (some ct) ∧ + ty = attachRefinements (.fn none .compute dt ct) c := by + rcases hf : funShapes pol (.mk [] none none (some (KindM.compute, [d], cod)) c) with e | x <;> + rw [coalesce_fun_only, hf] at h + · cases h + rcases x with _ | base + · cases h + cases h + rw [funShapes] at hf + simp at hf + have hmeet : meetAll (!pol) d [] = d := rfl + rw [hmeet] at hf + rcases hc : coalesce pol cod with e | oc + · simp [hc] at hf + cases hf + rcases hd : coalesce (!pol) d with e | od + · simp [hc, hd] at hf + cases hf + rcases od with _ | dt + · simp [hc, hd, funTy, Functor.map, Except.map] at hf + cases hf + rcases oc with _ | ct + · simp [hc, hd, funTy, Functor.map, Except.map] at hf + cases hf + refine ⟨dt, ct, rfl, rfl, ?_⟩ + rw [hc, hd] at hf + replace hf : (Except.ok (some (Ty.fn none FunKind.compute dt ct)) : Except CoErr (Option Ty)) + = .ok (some base) := hf + cases hf + rfl + +/-- Equivalent positions are below each other, at either polarity. -/ +theorem le_of_eqv (p : Bool) {x y : CTy} (h : eqv x y = true) (hwy : wf y = true) : + le p x y := + eqv_trans _ _ _ (merge_congr_left p x y y h) (merge_idem p y hwy) + +/-- `le` on a function-slot position, read off slot by slot. The kinds must agree, +because a mixed join is `conflict` and `wf` excludes that; the codomains are +related at the outer polarity; and the domains are equivalent at a positive +position, where they accumulate, and related at the flipped polarity at a negative +one, where they meet. -/ +theorem eqv_fun_slot {pol : Bool} {k₁ k₂ : KindM} {d₁ d₂ cod₁ cod₂ : CTy} + {ca cb : Option (List Pred)} + (hk₁ : k₁ ≠ .conflict) (hk₂ : k₂ ≠ .conflict) (hu₁ : k₁ ≠ .unknown) + (hle : le pol (.mk [] none none (some (k₁, [d₁], cod₁)) ca) + (.mk [] none none (some (k₂, [d₂], cod₂)) cb)) : + k₁ = k₂ ∧ le pol cod₁ cod₂ ∧ (if pol then eqv d₁ d₂ = true else le true d₁ d₂) := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + obtain ⟨⟨⟨⟨⟨-, -⟩, -⟩, -⟩, ⟨⟨hkind, hsd, -⟩, hcod⟩⟩, -⟩ := hle + have hmeet : meetDoms [d₁] [d₂] = some [merge true d₁ d₂] := by simp [meetDoms, subDoms] + have hkk : k₁ = k₂ := by + rcases k₁ <;> rcases k₂ <;> cases pol <;> + simp_all [joinKind, mergeFun, meetDoms, subDoms] + subst hkk + have hnc : (joinKind k₁ k₁ == KindM.conflict) = false := by + rcases k₁ <;> simp_all [joinKind] + cases pol + · simp only [mergeFun, hnc, Bool.false_eq_true, if_false, hmeet] at hsd hcod + refine ⟨rfl, by simpa [le] using hcod, ?_⟩ + obtain ⟨y, hy, heq⟩ := subDoms_iff.mp hsd (merge true d₁ d₂) (by simp) + simp only [List.mem_singleton] at hy + subst hy + simpa [le] using heq + · simp only [mergeFun, hnc, if_true, if_false] at hsd hcod + refine ⟨rfl, by simpa [le] using hcod, ?_⟩ + simp only [if_true] + obtain ⟨y, hy, heq⟩ := + subDoms_iff.mp hsd d₁ (by simp only [unionDoms]; exact List.mem_append_left _ (by simp)) + simp only [List.mem_singleton] at hy + subst hy + exact heq + +/-- A function edge from its parts: the domain is contravariant, and invariant when +both sides are `data`, because a collection's domain is its data. -/ +theorem subCheck_fn (kf : FunKind) {dt₁ dt₂ ct₁ ct₂ : Ty} + (hdom : subCheck dt₂ dt₁ = true) + (hinv : kf = .data → subCheck dt₁ dt₂ = true) + (hcod : subCheck ct₁ ct₂ = true) : + subCheck (.fn none kf dt₁ ct₁) (.fn none kf dt₂ ct₂) = true := by + cases kf + · simpa [subCheck, kindOkB] using ⟨hdom, hcod⟩ + · simpa [subCheck, kindOkB] using ⟨⟨hdom, hinv rfl⟩, hcod⟩ + +/-- The function case of `MonoAt`. The domains merge at the flipped polarity, so +the domain edge runs the other way — contravariance — and a `data` slot needs it in +both directions, because `subCheck` reads a data domain invariantly. A positive +merge accumulates the alternatives and `le` collapses them to one, which supplies +that agreement; a negative merge takes their meet and supplies only one direction, +so it is assumed (`hagree`), and the shape it excludes is the one `Ty` gives no +bound for. -/ +theorem mono_fun (pol : Bool) {k₁ k₂ : KindM} {d₁ d₂ cod₁ cod₂ : CTy} + {ca cb : Option (List Pred)} {ta tb : Ty} + (hwa : wf (.mk [] none none (some (k₁, [d₁], cod₁)) ca) = true) + (hwb : wf (.mk [] none none (some (k₂, [d₂], cod₂)) cb) = true) + (hk₁ : k₁ = .data ∨ k₁ = .compute) (hk₂ : k₂ = .data ∨ k₂ = .compute) + (hagree : pol = false → k₁ = .data → eqv d₁ d₂ = true) + (ihd : ∀ (x y : CTy) (tx ty' : Ty), ((x = d₁ ∧ y = d₂) ∨ (x = d₂ ∧ y = d₁)) → + le (!pol) x y → coalesce (!pol) x = .ok (some tx) → + coalesce (!pol) y = .ok (some ty') → + (if !pol then subCheck tx ty' else subCheck ty' tx) = true) + (ihc : ∀ (tx ty' : Ty), le pol cod₁ cod₂ → + coalesce pol cod₁ = .ok (some tx) → coalesce pol cod₂ = .ok (some ty') → + (if pol then subCheck tx ty' else subCheck ty' tx) = true) + (hle : le pol (.mk [] none none (some (k₁, [d₁], cod₁)) ca) + (.mk [] none none (some (k₂, [d₂], cod₂)) cb)) + (ha : coalesce pol (.mk [] none none (some (k₁, [d₁], cod₁)) ca) = .ok (some ta)) + (hb : coalesce pol (.mk [] none none (some (k₂, [d₂], cod₂)) cb) = .ok (some tb)) : + (if pol then subCheck ta tb else subCheck tb ta) = true := by + rw [wf.eq_def] at hwa hwb + simp only [Bool.and_eq_true] at hwa hwb + have hwd₁ : wf d₁ = true := hwa.1.2.1.2 + have hwd₂ : wf d₂ = true := hwb.1.2.1.2 + obtain ⟨rfl, hlec, hdom⟩ := + eqv_fun_slot (by rcases hk₁ with rfl | rfl <;> simp) (by rcases hk₂ with rfl | rfl <;> simp) + (by rcases hk₁ with rfl | rfl <;> simp) hle + have hrefinements : refinementsEqv (mergeRefinements pol ca cb) cb = true := by + rw [le, merge.eq_def, eqv.eq_def] at hle + simp only [Bool.and_eq_true] at hle + exact hle.2 + -- The two domains agree whenever the kind demands invariance. + have heqd : k₁ = .data → eqv d₁ d₂ = true := by + intro hkd + cases pol + · exact hagree rfl hkd + · simpa using hdom + rcases ca with _ | p + · exact absurd hwa.2 (by simp) + rcases cb with _ | q + · exact absurd hwb.2 (by simp) + have hnr : ∀ (kf : FunKind) (x y : Ty), (Ty.fn none kf x y).isRefined = false := by + intro kf x y + simp [Ty.isRefined] + rcases hk₁ with rfl | rfl + · obtain ⟨dt₁, ct₁, hd₁, hc₁, rfl⟩ := coalesce_fun_data_ok pol ha + obtain ⟨dt₂, ct₂, hd₂, hc₂, rfl⟩ := coalesce_fun_data_ok pol hb + have hfwd := ihd d₁ d₂ dt₁ dt₂ (Or.inl ⟨rfl, rfl⟩) + (le_of_eqv _ (heqd rfl) hwd₂) hd₁ hd₂ + have hbwd := ihd d₂ d₁ dt₂ dt₁ (Or.inr ⟨rfl, rfl⟩) + (le_of_eqv _ (eqv_symm _ _ (heqd rfl)) hwd₁) hd₂ hd₁ + have hcc := ihc ct₁ ct₂ hlec hc₁ hc₂ + cases pol + · simp only [Bool.false_eq_true, if_false, Bool.not_false, if_true] at hfwd hbwd hcc ⊢ + exact subCheck_attachRefinements (hnr _ _ _) (hnr _ _ _) + (subCheck_fn .data hfwd (fun _ => hbwd) hcc) + (fun x hx => by + simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + exact hrefinements.1 x (List.mem_append_left _ hx)) + · simp only [if_true, Bool.not_true, Bool.false_eq_true, if_false] at hfwd hbwd hcc ⊢ + exact subCheck_attachRefinements (hnr _ _ _) (hnr _ _ _) + (subCheck_fn .data hfwd (fun _ => hbwd) hcc) + (fun x hx => by + simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + exact (List.mem_filter.mp (hrefinements.2 x hx)).1) + · obtain ⟨dt₁, ct₁, hd₁, hc₁, rfl⟩ := coalesce_fun_compute_ok pol ha + obtain ⟨dt₂, ct₂, hd₂, hc₂, rfl⟩ := coalesce_fun_compute_ok pol hb + have hcc := ihc ct₁ ct₂ hlec hc₁ hc₂ + cases pol + · have hd := ihd d₁ d₂ dt₁ dt₂ (Or.inl ⟨rfl, rfl⟩) (by simpa using hdom) hd₁ hd₂ + simp only [Bool.false_eq_true, if_false, Bool.not_false, if_true] at hd hcc ⊢ + exact subCheck_attachRefinements (hnr _ _ _) (hnr _ _ _) + (subCheck_fn .compute hd (fun h => absurd h (by simp)) hcc) + (fun x hx => by + simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + exact hrefinements.1 x (List.mem_append_left _ hx)) + · have hd := ihd d₁ d₂ dt₁ dt₂ (Or.inl ⟨rfl, rfl⟩) + (le_of_eqv _ (by simpa using hdom) hwd₂) hd₁ hd₂ + simp only [if_true, Bool.not_true, Bool.false_eq_true, if_false] at hd hcc ⊢ + exact subCheck_attachRefinements (hnr _ _ _) (hnr _ _ _) + (subCheck_fn .compute hd (fun h => absurd h (by simp)) hcc) + (fun x hx => by + simp only [mergeRefinements, refinementsEqv_iff] at hrefinements + exact (List.mem_filter.mp (hrefinements.2 x hx)).1) + +/-- `ground`, projected onto a record slot's key walk. -/ +theorem ground_rec_keys {as : List Atom} {ma : List (FieldKey × CTy)} {v f c} + (h : ground (.mk as (some ma) v f c) = true) : + wfKeys ma (ma.map Prod.fst) = true ∧ kindResolvedKeys ma (ma.map Prod.fst) = true := by + simp only [ground, Bool.and_eq_true] at h + obtain ⟨hw, hk⟩ := h + rw [wf.eq_def] at hw + rw [kindResolved.eq_def] at hk + simp only [Bool.and_eq_true] at hw hk + exact ⟨hw.1.1.1.1, hk.1.1⟩ + +/-- `ground`, projected onto a variant slot's key walk. -/ +theorem ground_var_keys {as : List Atom} {ma : List (FieldKey × CTy)} {r f c} + (h : ground (.mk as r (some ma) f c) = true) : + wfKeys ma (ma.map Prod.fst) = true ∧ kindResolvedKeys ma (ma.map Prod.fst) = true := by + simp only [ground, Bool.and_eq_true] at h + obtain ⟨hw, hk⟩ := h + rw [wf.eq_def] at hw + rw [kindResolved.eq_def] at hk + simp only [Bool.and_eq_true] at hw hk + exact ⟨hw.1.1.2.1, hk.1.2⟩ + +/-- `ground`, projected onto a function slot: `wf` forces one domain and a kind +that is not `conflict`, and `kindResolved` forces one that is not `unknown`. -/ +theorem ground_fun {as : List Atom} {k : KindM} {ds : List CTy} {cod : CTy} {c} + (h : ground (.mk as none none (some (k, ds, cod)) c) = true) : + ∃ d, ds = [d] ∧ ground d = true ∧ ground cod = true ∧ (k = .data ∨ k = .compute) := by + simp only [ground, Bool.and_eq_true] at h + obtain ⟨hw, hk⟩ := h + rw [wf.eq_def] at hw + rw [kindResolved.eq_def] at hk + simp only [Bool.and_eq_true] at hw hk + obtain ⟨⟨-, hwf⟩, -⟩ := hw + obtain ⟨-, hkf⟩ := hk + rcases ds with _ | ⟨d, rest⟩ + · simp at hwf + rcases rest with _ | ⟨_, _⟩ + · simp only [bne_iff_ne, ne_eq, Bool.and_eq_true] at hwf + simp only [Bool.and_eq_true, kindResolvedAll, Bool.or_eq_true, beq_iff_eq] at hkf + refine ⟨d, rfl, ?_, ?_, hkf.1.1⟩ + · simp only [ground, Bool.and_eq_true] + exact ⟨hwf.1.2, hkf.1.2.1⟩ + · simp only [ground, Bool.and_eq_true] + exact ⟨hwf.2, hkf.2⟩ + · simp at hwf + +/-! ## The lemma, assembled + +Fuel on the summed size, symmetric because the function case applies the +hypothesis to its domains in both directions. Materializing pins each position to +one of four shapes (`coalesce_shape`), and `le` refutes every pairing of different +ones, so each surviving case is the matching slot's. -/ + +theorem mono : ∀ (n : Nat) (pol : Bool) (a b : CTy), sizeOf a + sizeOf b < n → + ground a = true → ground b = true → DataAgree pol a b = true → le pol a b → + ∀ (ta tb : Ty), coalesce pol a = .ok (some ta) → coalesce pol b = .ok (some tb) → + (if pol then subCheck ta tb else subCheck tb ta) = true := by + intro n + induction n with + | zero => + intro _ _ _ hfuel + exact absurd hfuel (by omega) + | succ n ih => + intro pol a b hfuel hga hgb hagree hle ta tb ha hb + obtain ⟨as, ra, va, fa, ca⟩ := a + obtain ⟨bs, rb, vb, fb, cb⟩ := b + -- `ground` and the pair condition, projected onto a shared keyed payload. + have hkeyed : ∀ (ma mb : List (FieldKey × CTy)), + wfKeys ma (ma.map Prod.fst) = true → wfKeys mb (mb.map Prod.fst) = true → + kindResolvedKeys ma (ma.map Prod.fst) = true → + kindResolvedKeys mb (mb.map Prod.fst) = true → + DataAgreeKeys pol ma mb (ma.map Prod.fst) = true → + sizeOf ma + sizeOf mb < n → + ∀ k v w tv tw, ma.lookup k = some v → mb.lookup k = some w → le pol v w → + coalesce pol v = .ok (some tv) → coalesce pol w = .ok (some tw) → + (if pol then subCheck tv tw else subCheck tw tv) = true := by + intro ma mb hwa hwb hka hkb hda hsz k v w tv tw hv hw hlevw hcv hcw + have hsv := lookup_sizeOf hv + have hsw := lookup_sizeOf hw + refine ih pol v w (by omega) ?_ ?_ ?_ hlevw tv tw hcv hcw + · simp only [ground, Bool.and_eq_true] + exact ⟨wfKeys_iff.mp hwa k (mem_keys_of_lookup hv) v hv, + kindResolvedKeys_iff.mp hka k (mem_keys_of_lookup hv) v hv⟩ + · simp only [ground, Bool.and_eq_true] + exact ⟨wfKeys_iff.mp hwb k (mem_keys_of_lookup hw) w hw, + kindResolvedKeys_iff.mp hkb k (mem_keys_of_lookup hw) w hw⟩ + · exact DataAgreeKeys_iff.mp hda k (mem_keys_of_lookup hv) v w hv hw + rcases coalesce_shape pol ha with + ⟨hane, rfl, rfl, rfl⟩ | ⟨rfl, ⟨ma, rfl⟩, rfl, rfl⟩ | ⟨rfl, rfl, ⟨ma, rfl⟩, rfl⟩ + | ⟨rfl, rfl, rfl, ⟨ga, rfl⟩⟩ <;> + rcases coalesce_shape pol hb with + ⟨hbne, rfl, rfl, rfl⟩ | ⟨rfl, ⟨mb, rfl⟩, rfl, rfl⟩ | ⟨rfl, rfl, ⟨mb, rfl⟩, rfl⟩ + | ⟨rfl, rfl, rfl, ⟨gb, rfl⟩⟩ + · simp only [ground, Bool.and_eq_true] at hga hgb + exact mono_atoms pol hga.1 hgb.1 hle ha hb + · exact absurd (List.eq_nil_iff_forall_not_mem.mpr + (fun x hx => by simpa using le_atoms_sub hle x hx)) hane + · exact absurd (List.eq_nil_iff_forall_not_mem.mpr + (fun x hx => by simpa using le_atoms_sub hle x hx)) hane + · exact absurd (List.eq_nil_iff_forall_not_mem.mpr + (fun x hx => by simpa using le_atoms_sub hle x hx)) hane + · exact absurd hle (fun h => le_rec_absurd h) + · obtain ⟨hwka, hkka⟩ := ground_rec_keys hga + obtain ⟨hwkb, hkkb⟩ := ground_rec_keys hgb + have hda : DataAgreeKeys pol ma mb (ma.map Prod.fst) = true := by + simp only [DataAgree, Bool.and_eq_true] at hagree + exact hagree.1.1 + have hsz : sizeOf ma + sizeOf mb < n := by + simp at hfuel + omega + simp only [ground, Bool.and_eq_true] at hga hgb + exact mono_record pol hga.1 hgb.1 + (hkeyed ma mb hwka hwkb hkka hkkb hda hsz) hle ha hb + · exact absurd hle (fun h => le_rec_absurd h) + · exact absurd hle (fun h => le_rec_absurd h) + · exact absurd hle (fun h => le_var_absurd h) + · exact absurd hle (fun h => le_var_absurd h) + · obtain ⟨hwka, hkka⟩ := ground_var_keys hga + obtain ⟨hwkb, hkkb⟩ := ground_var_keys hgb + have hda : DataAgreeKeys pol ma mb (ma.map Prod.fst) = true := by + simp only [DataAgree, Bool.and_eq_true] at hagree + exact hagree.1.2 + have hsz : sizeOf ma + sizeOf mb < n := by + simp at hfuel + omega + simp only [ground, Bool.and_eq_true] at hga hgb + exact mono_variant pol hga.1 hgb.1 + (hkeyed ma mb hwka hwkb hkka hkkb hda hsz) hle ha hb + · exact absurd hle (fun h => le_var_absurd h) + · exact absurd hle (fun h => le_fun_absurd h) + · exact absurd hle (fun h => le_fun_absurd h) + · exact absurd hle (fun h => le_fun_absurd h) + · obtain ⟨k₁, ds₁, cod₁⟩ := ga + obtain ⟨k₂, ds₂, cod₂⟩ := gb + obtain ⟨d₁, rfl, hgd₁, hgc₁, hk₁⟩ := ground_fun hga + obtain ⟨d₂, rfl, hgd₂, hgc₂, hk₂⟩ := ground_fun hgb + simp only [DataAgree, Bool.and_eq_true] at hagree + obtain ⟨-, ⟨⟨hkind, hdd⟩, hddrev⟩, hdc⟩ := hagree + have ihd : ∀ (x y : CTy) (tx ty' : Ty), ((x = d₁ ∧ y = d₂) ∨ (x = d₂ ∧ y = d₁)) → + le (!pol) x y → coalesce (!pol) x = .ok (some tx) → + coalesce (!pol) y = .ok (some ty') → + (if !pol then subCheck tx ty' else subCheck ty' tx) = true := by + intro x y tx ty' hxy hlexy hcx hcy + rcases hxy with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact ih (!pol) x y (by simp at hfuel; omega) hgd₁ hgd₂ hdd hlexy tx ty' hcx hcy + · exact ih (!pol) x y (by simp at hfuel; omega) hgd₂ hgd₁ hddrev hlexy tx ty' hcx hcy + have ihc : ∀ (tx ty' : Ty), le pol cod₁ cod₂ → + coalesce pol cod₁ = .ok (some tx) → coalesce pol cod₂ = .ok (some ty') → + (if pol then subCheck tx ty' else subCheck ty' tx) = true := by + intro tx ty' hlec hcx hcy + exact ih pol cod₁ cod₂ (by simp at hfuel; omega) hgc₁ hgc₂ hdc hlec tx ty' hcx hcy + have hagr : pol = false → k₁ = KindM.data → eqv d₁ d₂ = true := by + intro hp hkd + subst hp + subst hkd + simpa using hkind + simp only [ground, Bool.and_eq_true] at hga hgb + exact mono_fun pol hga.1 hgb.1 hk₁ hk₂ hagr ihd ihc hle ha hb + +/-! ## Transport: soundness is monotonicity, twice + +`le_merge_left` and `le_merge_right` put both operands below the merge in the +order the merge induces, and monotonicity carries that order to `Sub`. So the +soundness half is not a separate argument — it is two instances of `MonoAt`. -/ + +theorem lubSound_of_mono (pol : Bool) (a b : CTy) (hwa : wf a = true) (hwb : wf b = true) + (hma : MonoAt pol a (merge pol a b) = true) + (hmb : MonoAt pol b (merge pol a b) = true) : + LubSoundAt pol a b = true := by + rw [LubSoundAt] + rcases ha : coalesce pol a with ea | oa + · rfl + rcases oa with _ | ta + · rfl + rcases hb : coalesce pol b with eb | ob + · rfl + rcases ob with _ | tb + · rfl + rcases hm : coalesce pol (merge pol a b) with em | om + · rfl + rcases om with _ | tm + · rfl + -- Both operands are below the merge, so both `MonoAt` guards discharge. + have hla : eqv (merge pol a (merge pol a b)) (merge pol a b) = true := + le_merge_left pol a b hwa + have hlb : eqv (merge pol b (merge pol a b)) (merge pol a b) = true := + le_merge_right pol a b hwb + rw [MonoAt, if_pos hla, ha, hm] at hma + rw [MonoAt, if_pos hlb, hb, hm] at hmb + cases pol + · simp only [Bool.false_eq_true, if_false] at hma hmb ⊢ + simp [hma, hmb] + · simp only [if_true] at hma hmb ⊢ + simp [hma, hmb] + +/-- `MonoAt`, discharged by `mono`. -/ +theorem monoAt_of_mono (pol : Bool) (a b : CTy) (hga : ground a = true) + (hgb : ground b = true) (hda : DataAgree pol a b = true) : MonoAt pol a b = true := by + rw [MonoAt] + split + · rename_i hle + split + · rename_i ta tb hca hcb + exact mono (sizeOf a + sizeOf b + 1) pol a b (by omega) hga hgb hda hle ta tb hca hcb + · rfl + · rfl + +/-- **The bridge's soundness half.** Where all three positions materialize, a +positive merge lands above both operands under `Sub` and a negative one below +both, on ground positions whose merge did not have to move a data domain. -/ +theorem lubSound (pol : Bool) (a b : CTy) (hga : ground a = true) (hgb : ground b = true) + (hgm : ground (merge pol a b) = true) + (hda : DataAgree pol a (merge pol a b) = true) + (hdb : DataAgree pol b (merge pol a b) = true) : + LubSoundAt pol a b = true := by + have hwa : wf a = true := by + simp only [ground, Bool.and_eq_true] at hga + exact hga.1 + have hwb : wf b = true := by + simp only [ground, Bool.and_eq_true] at hgb + exact hgb.1 + exact lubSound_of_mono pol a b hwa hwb + (monoAt_of_mono pol a (merge pol a b) hga hgm hda) + (monoAt_of_mono pol b (merge pol a b) hgb hgm hdb) + +/-- **Leastness, among positions.** A position above both operands materializes to +a type above the merge's materialization, so the merge is the least of the bounds +the representation can express. + +Stated over positions rather than over all of `Ty`, which is where it stops: the +step from "above both, as a position" to "above both, as a type" needs an +embedding `Ty → CTy` and the reflection of `Sub` into `le`, the converse of +monotonicity. Neither is proved here. -/ +theorem lubLeast (pol : Bool) (a b u : CTy) (hgu : ground u = true) + (hgm : ground (merge pol a b) = true) + (hdm : DataAgree pol (merge pol a b) u = true) + (hau : le pol a u) (hbu : le pol b u) + {tm tu : Ty} (hm : coalesce pol (merge pol a b) = .ok (some tm)) + (hu : coalesce pol u = .ok (some tu)) : + (if pol then subCheck tm tu else subCheck tu tm) = true := + mono (sizeOf (merge pol a b) + sizeOf u + 1) pol (merge pol a b) u (by omega) hgm hgu hdm + (merge_le pol hau hbu) tm tu hm hu + +/-! ## A bounded sample + +Small enough to evaluate and wide enough to reach every arm of `merge`: each slot +at its identity (`none`), at its absorbing empty shape (`some []`), and +populated; the refinement slot at both of its `none` readings; and a function slot at +each kind over domains that agree and domains that do not. -/ + +private def intC : CTy := .mk [.prim .int] none none none (some []) +private def boolC : CTy := .mk [.prim .bool] none none none (some []) + +private def leaves : List CTy := + [ cempty + , .mk [] none none none (some []) + , intC + , boolC + , .mk [.uintRange 3] none none none (some []) + , .mk [.uintRange 4] none none none (some []) + , .mk [.source "s"] none none none (some []) + , .mk [.txn] none none none (some []) + , .mk [.prim .int] none none none (some [.elem]) + , .mk [] (some []) none none (some []) + , .mk [] (some [(.name "a", intC)]) none none (some []) + , .mk [] (some [(.name "a", intC), (.name "b", boolC)]) none none (some []) + , .mk [] (some [(.idx 0, intC)]) none none (some []) + , .mk [] (some [(.idx 0, intC), (.idx 1, boolC)]) none none (some []) + , .mk [] (some [(.idx 1, boolC), (.idx 0, intC)]) none none (some []) + , .mk [] (some [(.name "b", boolC), (.name "a", intC)]) none none (some []) + , .mk [] none (some [(.name "t1", boolC), (.name "t0", intC)]) none (some []) + , .mk [] none (some [(.name "t0", intC), (.name "t0", boolC)]) none (some []) + , .mk [] (some [(.name "a", intC), (.name "a", boolC)]) none none (some []) + , .mk [] (some [(.idx 0, intC), (.idx 0, boolC)]) none none (some []) + , .mk [] none (some []) none (some []) + , .mk [] none (some [(.name "t0", intC)]) none (some []) + , .mk [] none (some [(.name "t0", intC), (.name "t1", boolC)]) none (some []) + ] + +private def funs : List CTy := + let kinds : List KindM := [.data, .compute, .unknown] + let doms : List CTy := + [ intC + , .mk [.prim .int] none none none (some [.elem]) + , .mk [.uintRange 3] none none none (some []) + , .mk [.uintRange 4] none none none (some []) + , .mk [] (some [(.name "a", intC)]) none none (some []) + , .mk [] (some [(.name "a", intC), (.name "b", boolC)]) none none (some []) + ] + kinds.flatMap fun k => doms.map fun d => .mk [] none none (some (k, [d], intC)) (some []) + +private def sample : List CTy := leaves ++ funs + +private def cases (gate : CTy → Bool) : List (Bool × CTy × CTy) := + [true, false].flatMap fun pol => + sample.flatMap fun a => + sample.filterMap fun b => + if gate a && gate b then some (pol, a, b) else none + +private def failures (gate : CTy → Bool) : List (Bool × CTy × CTy) := + (cases gate).filter fun (pol, a, b) => !LubSoundAt pol a b + + + + +/-! ## The pool of candidate bounds + +`Ty` is a partial order, not a lattice: a negative merge of two data functions +over distinct domains has *no* lower bound, because a data function's domain is +invariant, so a type below both would need one domain equal to two. Demanding +soundness there demands the impossible, and the lossless answer is the Σ over +both domains that M5 adds. So the soundness half is guarded by the existence of a +bound, and leastness is stated against every candidate. + +The pool is what the sample materializes to, which is finite and so decides the +guard only for the shapes it contains — enough to measure, not to prove. -/ + +private def pool : List Ty := + ((sample.filterMap fun t => + match coalesce true t with + | .ok (some ty) => some ty + | _ => none) ++ + (sample.filterMap fun t => + match coalesce false t with + | .ok (some ty) => some ty + | _ => none)).eraseDups + +/-- Some candidate bounds both operands: above both at a positive position, +below both at a negative one. -/ +private def hasBound (pol : Bool) (ta tb : Ty) : Bool := + pool.any fun t => if pol then subCheck ta t && subCheck tb t + else subCheck t ta && subCheck t tb + +/-- The guarded soundness half: where a bound exists, the merge is one. -/ +def LubSoundGuarded (pol : Bool) (a b : CTy) : Bool := + match coalesce pol a, coalesce pol b, coalesce pol (merge pol a b) with + | .ok (some ta), .ok (some tb), .ok (some tm) => + !hasBound pol ta tb || + (if pol then subCheck ta tm && subCheck tb tm + else subCheck tm ta && subCheck tm tb) + | _, _, _ => true + +/-- Leastness against every candidate: a bound of both operands bounds the +merge. Unconditional — no existence guard, since the quantifier is over +candidates that already bound both. -/ +def LubLeastAt (pol : Bool) (a b : CTy) : Bool := + match coalesce pol a, coalesce pol b, coalesce pol (merge pol a b) with + | .ok (some ta), .ok (some tb), .ok (some tm) => + pool.all fun t => + if pol then !(subCheck ta t && subCheck tb t) || subCheck tm t + else !(subCheck t ta && subCheck t tb) || subCheck t tm + | _, _, _ => true + +private def guardedFailures : List (Bool × CTy × CTy) := + (cases ground).filter fun (pol, a, b) => !LubSoundGuarded pol a b + +private def leastFailures : List (Bool × CTy × CTy) := + (cases ground).filter fun (pol, a, b) => !LubLeastAt pol a b + +private def monoFailures (gate : CTy → Bool) : List (Bool × CTy × CTy) := + (cases gate).filter fun (pol, a, b) => !MonoAt pol a b + +/-! ## What the sample measures + +Three statements, each `#guard`ed over the sample, and the two hypotheses each +pinned by the counterexample that forces it. -/ + +-- Coverage: a change that shrinks the sample shows up here rather than as a +-- silently easier check. +private def provedCovered : List (Bool × CTy × CTy) := + (cases ground).filter fun (pol, a, b) => + ground (merge pol a b) && DataAgree pol a (merge pol a b) + && DataAgree pol b (merge pol a b) + +-- What `lubSound` proves, against what the sample checks: of the kind-resolved +-- pairs, these are the ones whose merge stays ground and whose data domains did +-- not move, so the theorem applies to them. The rest are a merge that left the +-- input shape — a `compute` slot carrying two domain alternatives, which +-- materializes by meeting them — or a data domain the merge moved. +#guard (provedCovered).length == 1814 +#guard (provedCovered.filter fun (pol, a, b) => !LubSoundAt pol a b).isEmpty + +#guard (cases wf).length == 2888 +#guard (cases ground).length == 2048 + +-- In general, over kind-resolved positions: the merge is a bound wherever one +-- exists, and it is below every bound of both operands. +#guard guardedFailures.isEmpty +#guard leastFailures.isEmpty + +-- Unguarded, one shape survives on every fragment, in both orders: a negative +-- merge of two `data` slots whose domains disagree. `subCheck` reads a data +-- domain invariantly, so nothing in `Ty` is below both operands and no merge +-- result could be. Restricting the domain to atoms does not exclude it — the +-- disagreement can sit in the refinement slot, and a refined collection domain is +-- what a filtered source has. +-- Unguarded, one phenomenon survives, on two surfaces and in both orders: a +-- negative merge of two `data` slots whose domains disagree. A disagreement is +-- caught loudly exactly when the domains' join is undefined — two distinct atoms +-- give a two-atom position `coalesce` rejects, so nothing materializes and the +-- statement is vacuous — and silently whenever the join exists: record keys +-- intersect, variant tags unite, refinement sets intersect. So the boundary is the +-- domains' agreement, which is what `mono_fun` assumes, and not the shape of a +-- domain. +#guard (failures ground).length == 4 +#guard (monoFailures ground).length == 2 +#guard !LubSoundAt false + (.mk [] none none (some (.data, [.mk [.prim .int] none none none (some [])], intC)) + (some [])) + (.mk [] none none + (some (.data, [.mk [.prim .int] none none none (some [.elem])], intC)) (some [])) +#guard LubSoundGuarded false + (.mk [] none none (some (.data, [.mk [.prim .int] none none none (some [])], intC)) + (some [])) + (.mk [] none none + (some (.data, [.mk [.prim .int] none none none (some [.elem])], intC)) (some [])) + +-- On the fragment `compact_go` produces — kind-resolved, and every `data` slot's +-- domain atoms only — the merge is the lub with no guard at all. + +-- In general, over kind-resolved positions: the merge is a bound wherever one +-- exists, and it is below every bound of both operands. + +-- The route to the proof: monotonicity holds outright on the same fragment, and +-- fails on exactly the shape the existence guard covers. + +-- Neither a duplicate key nor a content-bearing position without a refinement slot is +-- `wf`, and each breaks the bridge. A duplicate is invisible to `eqv`, which +-- compares by `lookup`, and visible in the type, which carries every entry. +#guard !wf (.mk [] none (some [(.name "t0", intC), (.name "t0", boolC)]) none (some [])) + +-- On the fragment `compact_go` produces — kind-resolved, and every `data` slot's +-- domain atoms only — the merge is the lub with no guard at all. + +-- In general, over kind-resolved positions: the merge is a bound wherever one +-- exists, and it is below every bound of both operands. + +-- The route to the proof: monotonicity holds outright on the same fragment, and +-- fails on exactly the shape the existence guard covers. + +-- On the fragment `compact_go` produces — kind-resolved, and every `data` slot's +-- domain atoms only — the merge is the lub with no guard at all. + +-- In general, over kind-resolved positions: the merge is a bound wherever one +-- exists, and it is below every bound of both operands. + +-- The route to the proof: monotonicity holds outright on the same fragment, and +-- fails on exactly the shape the existence guard covers. + +-- A position with content and no refinement slot is not `wf`, and this is the pair +-- that forces the invariant: at a positive position the merge keeps `__elem`, +-- because the `none` slot is the merge identity rather than a value that +-- guarantees nothing, so the join of `{Int | __elem}` and `Int` is not `Int`. +#guard !wf (.mk [.prim .int] none none none none) +#guard !LubSoundAt true (.mk [.prim .int] none none none (some [.elem])) + (.mk [.prim .int] none none none none) + +-- On the fragment `compact_go` produces — kind-resolved, and every `data` slot's +-- domain atoms only — the merge is the lub with no guard at all. + +-- In general, over kind-resolved positions: the merge is a bound wherever one +-- exists, and it is below every bound of both operands. + +-- `kindResolved` is what excludes the artifact: an `unknown` slot materializes by +-- the capability default, and the merge that pins it to `data` contradicts that +-- default, so the operand's own type is not what the merge combined. +#guard !LubSoundAt true + (.mk [] none none (some (.data, [intC], intC)) (some [])) + (.mk [] none none (some (.unknown, [intC], intC)) (some [])) + +-- The route to the proof: monotonicity holds outright on the same fragment, and +-- fails on exactly the shape the existence guard covers. + +-- The guard is what excludes the shape `Ty` gives no bound: a data function's +-- domain is invariant, so nothing is below both of these, and no merge result +-- could be. The Σ over both domains is the type that would be, which is M5. +#guard !LubSoundAt false + (.mk [] none none (some (.data, [.mk [] (some [(.name "a", intC)]) none none (some [])], intC)) + (some [])) + (.mk [] none none + (some (.data, + [.mk [] (some [(.name "a", intC), (.name "b", boolC)]) none none (some [])], intC)) + (some [])) +#guard LubSoundGuarded false + (.mk [] none none (some (.data, [.mk [] (some [(.name "a", intC)]) none none (some [])], intC)) + (some [])) + (.mk [] none none + (some (.data, + [.mk [] (some [(.name "a", intC), (.name "b", boolC)]) none none (some [])], intC)) + (some [])) + +end CTy +end CclFormal diff --git a/formal/CclFormal/Coalesce.lean b/formal/CclFormal/Coalesce.lean new file mode 100644 index 00000000..56f2321d --- /dev/null +++ b/formal/CclFormal/Coalesce.lean @@ -0,0 +1,499 @@ +import CclFormal.Merge + +/-! +# Materialization: the compact type back out as a `Ty` + +The Lean mirror of `src/ccl/infer/solver/coalesce.rs`'s `coalesce_compact_go` — the +partial function from a merged bound to the type the solver reports. `merge` says +how bounds combine; this says what the combination *is*, and it is the half that +decides whether a join has an answer at all. + +`coalesce` is partial in two different ways, and they are distinct outcomes: + +- **Refused** (`CoErr`): the position has no type. Two or more concrete + contributions at once, a `Data` slot whose alternatives do not reconcile, a + conflicted slot, or a record with mixed key kinds. +- **Unresolved** (`ok none`): nothing concrete reached the position, so + `coalesce_compact_go` emits a fresh `Type::Infer`. The model has no `Infer` node + — the same exclusion `Ty` makes for the subtype relation — so it reports the + fact and not the variable. A position that materializes to an inference variable + is therefore compared only as "unresolved", refinements included: the Rust attaches + the position's refinements to the variable and the model cannot carry them. + +## What it drops, beyond `CTy`'s own adjudications + +- **The Pi binder.** `coalesce_compact_go` keeps `cf.name` when the codomain + references it (`kept_name`). `CTy` has no binder slot, so the model always emits + `none` and the differential compares modulo the binder. +- **`Openness`.** `CTy`'s variant slot is a bare tag map, so a materialized + variant carries no arm-set completeness. Every generated arm set is closed. +- **Which error.** A conflicted `fn` slot is `KindConflict` or + `DomainJoinConflict` in the Rust depending on how many alternatives survive, and + the model drops a conflicted slot's alternatives (see `Merge.lean`), so it + reports one `conflictedSlot` for both. + +## Why it terminates + +By `depth`, not by any subterm ordering. One recursive call is the reason: a +`Compute` slot's alternatives are folded with `merge` (`meetAll`) and the *result* +is materialized, and that result is not a subterm of the position. The bound is +`merge_depth_le` — **`merge` does not deepen a position**, since it unions atoms, +merges map payloads pointwise, and recurses into a function slot's domain and +codomain — so the folded domain is no deeper than the alternatives it came from, +which are children of the position. `compact.rs` makes no such argument anywhere, +and its own recursion rests on it. + +Everything else recurses on a child, and each call's bound is named beside it +(`depth_cod_lt`, `depth_dom_lt`, `depth_recPayload_lt`, `depth_varPayload_lt`, +`depth_fold_lt`). The keyed maps are walked with `List.attach`, so each payload's +recursive call carries the membership proof its bound needs. +-/ + +namespace CclFormal +namespace CTy + +/-- Why a position has no type. -/ +inductive CoErr where + /-- Bounds with no common shape at one position (`IncompatibleBounds`). Two or + more concrete contributions is one way; a product with no fields is the same + thing read one level down, since a positive merge intersects field sets and + there is no zero-field product for the empty map to be. -/ + | incompatible + /-- A `Data` slot whose alternatives do not reconcile (`DomainJoinConflict`). -/ + | domainJoin + /-- A conflicted `fn` slot (`KindConflict` or `DomainJoinConflict`). -/ + | conflictedSlot + /-- A record with mixed `Index`/`Name` keys (`UnresolvedPartial`). -/ + | partialRecord +deriving Repr, DecidableEq + +/-- The type an atom contributes (`AtomKey::to_type`). -/ +def atomTy : Atom → Ty + | .prim b => .base b + | .uintRange n => .uintRange n + | .source s => .dataSource s + | .txn => .txn + +/-- Re-attach the position's refinements, flattening as `Type::refined` does: an empty +refinement set is the bare type. -/ +def attachRefinements (t : Ty) : Option (List Pred) → Ty + | none => t + | some [] => t + | some ps => match t with + | .refined b qs => .refined b (qs ++ ps) + | _ => .refined t ps + +/-- A dense index-keyed map's payloads in *index* order, as a tuple. + +`Ty.tuple` is positional and the map's list order carries no information — `eqv` +compares maps as sets, mirroring the `BTreeMap` the Rust holds, whose iteration +order is the key order. So the payloads are read by index rather than by +position. -/ +def byIndex (n : Nat) (kvs : List (Nat × Ty)) : Option Ty := + ((List.range n).mapM (fun i => List.lookup i kvs)).map Ty.tuple + +/-- The index keys of a map, if every key is one. -/ +def indexKeys : List (FieldKey × CTy) → Option (List Nat) + | [] => some [] + | (.idx n, _) :: rest => (indexKeys rest).map (n :: ·) + | (.name _, _) :: _ => none + +/-- The name keys of a map, if every key is one. -/ +def nameKeys : List (FieldKey × CTy) → Option (List String) + | [] => some [] + | (.name s, _) :: rest => (nameKeys rest).map (s :: ·) + | (.idx _, _) :: _ => none + +/-! ### The depth bounds `coalesce`'s recursion decreases by + +Every recursive call is on something strictly shallower than the position, which is +what makes one measure — `depth` — enough. The folded `Compute` domain is the call +that needs `merge_depth_le`; the rest are children. -/ + +theorem depth_cod_lt {a : List Atom} {r v : Option (List (FieldKey × CTy))} + {c : Option (List Pred)} {k : KindM} {ds : List CTy} {cod : CTy} : + depth cod < depth (CTy.mk a r v (some (k, ds, cod)) c) := by + have h1 : depth cod ≤ optFnDepth (some (k, ds, cod)) := by + simp only [optFnDepth] + exact Nat.le_max_right _ _ + have h2 : optFnDepth (some (k, ds, cod)) + ≤ Nat.max (optMapDepth r) (Nat.max (optMapDepth v) (optFnDepth (some (k, ds, cod)))) := + Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _) + rw [depth] + omega + +theorem depth_dom_lt {a : List Atom} {r v : Option (List (FieldKey × CTy))} + {c : Option (List Pred)} {k : KindM} {ds : List CTy} {cod d : CTy} (h : d ∈ ds) : + depth d < depth (CTy.mk a r v (some (k, ds, cod)) c) := by + have h1 : depth d ≤ optFnDepth (some (k, ds, cod)) := by + simp only [optFnDepth] + exact Nat.le_trans (le_listDepth h) (Nat.le_max_left _ _) + have h2 : optFnDepth (some (k, ds, cod)) + ≤ Nat.max (optMapDepth r) (Nat.max (optMapDepth v) (optFnDepth (some (k, ds, cod)))) := + Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _) + rw [depth] + omega + +/-- The folded `Compute` domain: bounded because `merge` does not deepen. -/ +theorem depth_fold_lt {a : List Atom} {r v : Option (List (FieldKey × CTy))} + {c : Option (List Pred)} {k : KindM} {cod d : CTy} {rest : List CTy} {q : Bool} : + depth (meetAll q d rest) < depth (CTy.mk a r v (some (k, d :: rest, cod)) c) := by + have h0 : depth (meetAll q d rest) ≤ listDepth (d :: rest) := by + refine Nat.le_trans (meetAll_depth_le q d rest) ?_ + rw [listDepth] + exact Nat.max_le.mpr ⟨Nat.le_max_left _ _, Nat.le_max_right _ _⟩ + have h1 : listDepth (d :: rest) ≤ optFnDepth (some (k, d :: rest, cod)) := by + simp only [optFnDepth] + exact Nat.le_max_left _ _ + have h2 : optFnDepth (some (k, d :: rest, cod)) + ≤ Nat.max (optMapDepth r) + (Nat.max (optMapDepth v) (optFnDepth (some (k, d :: rest, cod)))) := + Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _) + rw [depth] + omega + +theorem depth_recPayload_lt {a : List Atom} {m : List (FieldKey × CTy)} + {v : Option (List (FieldKey × CTy))} {f : Option (KindM × List CTy × CTy)} + {c : Option (List Pred)} {p : FieldKey × CTy} (h : p ∈ m) : + depth p.2 < depth (CTy.mk a (some m) v f c) := by + have h1 : depth p.2 ≤ optMapDepth (some m) := by + simp only [optMapDepth] + exact le_mapDepth h + have h2 : optMapDepth (some m) + ≤ Nat.max (optMapDepth (some m)) (Nat.max (optMapDepth v) (optFnDepth f)) := + Nat.le_max_left _ _ + rw [depth] + omega + +theorem depth_varPayload_lt {a : List Atom} {m : List (FieldKey × CTy)} + {r : Option (List (FieldKey × CTy))} {f : Option (KindM × List CTy × CTy)} + {c : Option (List Pred)} {p : FieldKey × CTy} (h : p ∈ m) : + depth p.2 < depth (CTy.mk a r (some m) f c) := by + have h1 : depth p.2 ≤ optMapDepth (some m) := by + simp only [optMapDepth] + exact le_mapDepth h + have h2 : optMapDepth (some m) + ≤ Nat.max (optMapDepth r) (Nat.max (optMapDepth (some m)) (optFnDepth f)) := + Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _) + rw [depth] + omega + +/-! The same three bounds phrased over an `attach` element, so `decreasing_by` can +find them without naming the lambda's binder. -/ + +theorem depth_recAttach_lt {a : List Atom} {m : List (FieldKey × CTy)} + {v : Option (List (FieldKey × CTy))} {f : Option (KindM × List CTy × CTy)} + {c : Option (List Pred)} (rp : {x : FieldKey × CTy // x ∈ m}) : + depth rp.1.2 < depth (CTy.mk a (some m) v f c) := + depth_recPayload_lt rp.2 + +theorem depth_varAttach_lt {a : List Atom} {m : List (FieldKey × CTy)} + {r : Option (List (FieldKey × CTy))} {f : Option (KindM × List CTy × CTy)} + {c : Option (List Pred)} (vp : {x : FieldKey × CTy // x ∈ m}) : + depth vp.1.2 < depth (CTy.mk a r (some m) f c) := + depth_varPayload_lt vp.2 + +theorem depth_domAttach_lt {a : List Atom} {r v : Option (List (FieldKey × CTy))} + {c : Option (List Pred)} {k : KindM} {ds : List CTy} {cod : CTy} + (alt : {x : CTy // x ∈ ds}) : + depth alt.1 < depth (CTy.mk a r v (some (k, ds, cod)) c) := + depth_dom_lt alt.2 + +/-- Build a function type from two materialized halves, unresolved if either is. -/ +def funTy (kind : FunKind) : Option Ty → Option Ty → Option Ty + | some d, some c => some (.fn none kind d c) + | _, _ => none + +/-- The shapes a position contributed, combined: none is unresolved, one is the +type with the position's refinements re-attached, and two or more is a position with +no type at all. + +Named, and not a `match` inside [`coalesce`], because it is what every shape +argument reads: materializing at all means exactly one contribution is non-empty. +-/ +def combine (shapes : List (Option Ty)) (refinements : Option (List Pred)) : + Except CoErr (Option Ty) := + match shapes with + | [] => .ok none + | [t] => .ok (t.map (attachRefinements · refinements)) + | _ => .error .incompatible + +mutual + +/-- Mirror of `coalesce_compact_go`. `ok none` is an unresolved position. + +The four contributions are *named* functions rather than sub-expressions of one +`do` block, because a proof has to speak about one of them on its own: the shape +argument every case of the monotonicity lemma rests on is that materializing +means exactly one contribution is non-empty, and that is unstatable about an +inline expression. Each takes the whole position, which is also what the `depth` +lemmas below are stated against. -/ +def coalesce (pol : Bool) : CTy → Except CoErr (Option Ty) + | t => do + -- The position is passed whole to each contribution and destructured only + -- afterwards: the measure below is stated on `t`, and matching on the + -- constructor first would specialize it out from under the recursive calls. + let recShape ← recShapes pol t + let varShape ← varShapes pol t + let funShape ← funShapes pol t + match t with + | .mk atoms recF varT fn refinements => + -- Whether a contribution is read is the *slot's* question, so the list's + -- length is manifest here rather than something a lemma has to recover + -- from the helper's branches. An absent slot's helper answers `none` and + -- is not read. + combine ((atoms.map atomTy).eraseDups.map some + ++ (if recF.isSome then [recShape] else []) + ++ (if varT.isSome then [varShape] else []) + ++ (if fn.isSome then [funShape] else [])) refinements +termination_by t => (depth t, 1) +decreasing_by all_goals (apply Prod.Lex.right; omega) + +/-- The record slot's contribution: the empty product is unit, dense index keys +are a tuple, sparse ones are unresolved, name keys are a record, and a mix has no +type. The payloads materialize either way, so a nested refusal wins over a +discarded shape — what the `?` in `materialize_record` does. The key kinds are +checked *before* any payload is materialized: a mixed-key map has no type and +`materialize_record` returns without touching the payloads. -/ +def recShapes (pol : Bool) : CTy → Except CoErr (Option Ty) + | .mk _ none _ _ _ => pure none + | .mk _ (some m) _ _ _ => + if m.isEmpty then .error .incompatible + else + match indexKeys m with + | some idxs => do + let payloads ← m.attach.mapM fun rp => coalesce pol rp.1.2 + if idxs.length == m.length && (List.range m.length).all (idxs.contains ·) then + pure ((payloads.mapM id).bind (fun ts => byIndex m.length (idxs.zip ts))) + else + pure none + | none => + match nameKeys m with + | some names => do + let payloads ← m.attach.mapM fun rp => coalesce pol rp.1.2 + pure ((payloads.mapM id).map (fun ts => Ty.record (names.zip ts))) + | none => .error .partialRecord +termination_by t => (depth t, 0) +decreasing_by all_goals (apply Prod.Lex.left; exact depth_recAttach_lt _) + +/-- The variant slot's contribution: its arms, materialized in the map's order. -/ +def varShapes (pol : Bool) : CTy → Except CoErr (Option Ty) + | .mk _ _ none _ _ => pure none + | .mk _ _ (some m) _ _ => do + let payloads ← m.attach.mapM fun vp => coalesce pol vp.1.2 + pure ((payloads.mapM id).map (fun ts => Ty.variant ((m.map Prod.fst).zip ts))) +termination_by t => (depth t, 0) +decreasing_by all_goals (apply Prod.Lex.left; exact depth_varAttach_lt _) + +/-- The function slot's contribution. The resolved kind decides what the domain +alternatives mean: a `Compute` reading — and an unpinned kind variable, which +defaults to it — meets them, while a `Data` reading needs exactly one to survive +materialization. -/ +def funShapes (pol : Bool) : CTy → Except CoErr (Option Ty) + | .mk _ _ _ none _ => pure none + | .mk _ _ _ (some (k, ds, cod)) _ => do + let c ← coalesce pol cod + match k with + | .conflict => .error .conflictedSlot + | .data => do + let mats ← ds.attach.mapM fun alt => coalesce (!pol) alt.1 + match mats.eraseDups with + | [one] => pure (funTy .data one c) + | _ => .error .domainJoin + | _ => + match ds with + | [] => .error .conflictedSlot + | d :: rest => do + let dt ← coalesce (!pol) (meetAll (!pol) d rest) + pure (funTy .compute dt c) +termination_by t => (depth t, 0) +decreasing_by + all_goals + apply Prod.Lex.left + first + | exact depth_cod_lt + | exact depth_fold_lt + | exact depth_domAttach_lt _ + +end + +/-! ## Reading a contribution back + +Each slot contributes an empty list when it is absent and a one-element list when +it is present, and `combine` accepts the concatenation only when it is a +singleton. Together those are the shape argument: materializing means exactly one +slot carries the position. -/ + +theorem combine_ok : ∀ {shapes : List (Option Ty)} {refinements : Option (List Pred)} {ty : Ty}, + combine shapes refinements = .ok (some ty) → ∃ t, shapes = [some t] ∧ ty = attachRefinements t refinements + | [], _, _, h => by simp [combine] at h + | [x], refinements, ty, h => by + rcases x with _ | t + · simp [combine] at h + · refine ⟨t, rfl, ?_⟩ + simp only [combine, Option.map_some, Except.ok.injEq, Option.some.injEq] at h + exact h.symm + | _ :: _ :: _, _, _, h => by simp [combine] at h + +theorem recShapes_none (pol : Bool) {as v f c} : recShapes pol (.mk as none v f c) = .ok none := by + rw [recShapes] + rfl + +theorem varShapes_none (pol : Bool) {as r f c} : varShapes pol (.mk as r none f c) = .ok none := by + rw [varShapes] + rfl + +theorem funShapes_none (pol : Bool) {as r v c} : funShapes pol (.mk as r v none c) = .ok none := by + rw [funShapes] + rfl + +/-! ## Reading a `mapM` back + +`coalesce` materializes a keyed slot's payloads with `mapM` over `attach`, and +every proof about a keyed slot has to invert that. Two cases are enough: a proof +inducts on the map and peels one entry at a time. -/ + +theorem mapM_ok_nil {α β ε} {f : α → Except ε β} {l' : List β} + (h : ([] : List α).mapM f = .ok l') : l' = [] := by + simp only [List.mapM_nil] at h + cases h + rfl + +theorem mapM_ok_cons {α β ε} {f : α → Except ε β} {a : α} {as : List α} {l' : List β} + (h : (a :: as).mapM f = .ok l') : + ∃ b bs, f a = .ok b ∧ as.mapM f = .ok bs ∧ l' = b :: bs := by + rw [List.mapM_cons] at h + rcases hfa : f a with e | b <;> rw [hfa] at h + · cases h + · rcases hbs : as.mapM f with e | bs <;> rw [hbs] at h + · cases h + · cases h + exact ⟨b, bs, rfl, rfl, rfl⟩ + +theorem mapM_some_nil {α β} {f : α → Option β} {l' : List β} + (h : ([] : List α).mapM f = some l') : l' = [] := by + simp only [List.mapM_nil] at h + cases h + rfl + +theorem mapM_some_cons {α β} {f : α → Option β} {a : α} {as : List α} {l' : List β} + (h : (a :: as).mapM f = some l') : + ∃ b bs, f a = some b ∧ as.mapM f = some bs ∧ l' = b :: bs := by + rw [List.mapM_cons] at h + rcases hfa : f a with _ | b <;> rw [hfa] at h + · cases h + · rcases hbs : as.mapM f with _ | bs <;> rw [hbs] at h + · cases h + · cases h + exact ⟨b, bs, rfl, rfl, rfl⟩ + +theorem mapM_some_get {α β} {f : α → Option β} : + ∀ {l : List α} {l' : List β}, l.mapM f = some l' → + l'.length = l.length ∧ + ∀ (i : Nat) (x : α) (y : β), l[i]? = some x → l'[i]? = some y → f x = some y + | [], l', h => by + cases mapM_some_nil h + exact ⟨rfl, fun i x y hx _ => absurd hx (by simp)⟩ + | a :: as, l', h => by + obtain ⟨b, bs, hfa, hbs, rfl⟩ := mapM_some_cons h + obtain ⟨hlen, hget⟩ := mapM_some_get hbs + refine ⟨by simp [hlen], fun i x y hx hy => ?_⟩ + cases i with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at hx hy + subst hx + subst hy + exact hfa + | succ n => + simp only [List.getElem?_cons_succ] at hx hy + exact hget n x y hx hy + +/-! ## Keys of a materialized map + +`indexKeys`/`nameKeys` succeed exactly when every key is of one kind, so the map's +key list is the returned list re-tagged. -/ + +theorem indexKeys_keys : ∀ {m : List (FieldKey × CTy)} {idxs : List Nat}, + indexKeys m = some idxs → m.map Prod.fst = idxs.map FieldKey.idx + | [], idxs, h => by simp [indexKeys] at h; simp [← h] + | (.idx n, v) :: m, idxs, h => by + simp only [indexKeys, Option.map_eq_some_iff] at h + obtain ⟨rest, hrest, rfl⟩ := h + simpa using indexKeys_keys hrest + | (.name s, v) :: m, idxs, h => by simp [indexKeys] at h + +theorem nameKeys_keys : ∀ {m : List (FieldKey × CTy)} {names : List String}, + nameKeys m = some names → m.map Prod.fst = names.map FieldKey.name + | [], names, h => by simp [nameKeys] at h; simp [← h] + | (.name s, v) :: m, names, h => by + simp only [nameKeys, Option.map_eq_some_iff] at h + obtain ⟨rest, hrest, rfl⟩ := h + simpa using nameKeys_keys hrest + | (.idx n, v) :: m, names, h => by simp [nameKeys] at h + +/-! ## The comparison the differential uses + +Refinements compare as a **set**, mirroring `RefinementSet`: the Rust's refinement set is +deduplicated and insertion-ordered, and the model appends, so a positional +comparison would report an order difference as a divergence. Binders compare +normally — the harness erases them on its side, because `CTy` has no binder slot +and the model can only ever emit `none`. -/ + +mutual + +def tyEqv : Ty → Ty → Bool + | .base a, .base b => a == b + | .uintRange a, .uintRange b => a == b + | .dataSource a, .dataSource b => a == b + | .txn, .txn => true + | .fn n0 k0 d0 c0, .fn n1 k1 d1 c1 => n0 == n1 && k0 == k1 && tyEqv d0 d1 && tyEqv c0 c1 + | .tuple a, .tuple b => tyEqvSeq a b + | .record a, .record b => tyEqvRec a b + | .variant a, .variant b => tyEqvVar a b + | .refined b1 p1, .refined b2 p2 => + tyEqv b1 b2 && p1.all (p2.contains ·) && p2.all (p1.contains ·) + | _, _ => false +termination_by a b => sizeOf a + sizeOf b + +def tyEqvSeq : List Ty → List Ty → Bool + | [], [] => true + | x :: xs, y :: ys => tyEqv x y && tyEqvSeq xs ys + | _, _ => false +termination_by a b => sizeOf a + sizeOf b + +def tyEqvRec : List (String × Ty) → List (String × Ty) → Bool + | [], [] => true + | (n1, t1) :: xs, (n2, t2) :: ys => n1 == n2 && tyEqv t1 t2 && tyEqvRec xs ys + | _, _ => false +termination_by a b => sizeOf a + sizeOf b + +def tyEqvVar : List (FieldKey × Ty) → List (FieldKey × Ty) → Bool + | [], [] => true + | (k1, t1) :: xs, (k2, t2) :: ys => k1 == k2 && tyEqv t1 t2 && tyEqvVar xs ys + | _, _ => false +termination_by a b => sizeOf a + sizeOf b + +end + +/-- The outcome the harness reports, and whether the model agrees with it. -/ +inductive CoGot where + | ok (t : Ty) + | unresolved + | err (kind : String) + +def coalesceAgrees (want : Except CoErr (Option Ty)) (got : CoGot) : Bool := + match want, got with + | .ok (some t), .ok u => tyEqv t u + | .ok none, .unresolved => true + | .error e, .err kind => + match e with + | .incompatible => kind == "IncompatibleBounds" + | .domainJoin => kind == "DomainJoinConflict" + -- A conflicted slot is one error here and two there: which one the Rust + -- reports reads the alternatives the model drops. + | .conflictedSlot => kind == "KindConflict" || kind == "DomainJoinConflict" + | .partialRecord => kind == "UnresolvedPartial" + | _, _ => false + +end CTy +end CclFormal diff --git a/formal/CclFormal/Decide.lean b/formal/CclFormal/Decide.lean new file mode 100644 index 00000000..18d028c6 --- /dev/null +++ b/formal/CclFormal/Decide.lean @@ -0,0 +1,225 @@ +import CclFormal.Sub + +/-! +# The executable ground subtype checker + +`subCheck` is the Bool-valued decision procedure for `Sub` — the mirror of +`constrain_go`'s ground control flow, and the executable half of the M1 +differential oracle (`subCheck` vs `constrain_subtype` on ground pairs). +Soundness and completeness against `Sub` are proved in +`CclFormal/Equiv.lean`, so the relation is decidable and every `#guard` +below is a fact about `Sub` itself. +-/ + +namespace CclFormal + +/-- Bool form of `kindOk`. -/ +def kindOkB : FunKind → FunKind → Bool + | .compute, .compute => true + | .data, .data => true + | _, _ => false + +mutual + +/-- Decide `Sub lhs rhs`, arm for arm with `constrain_go`'s ground +fragment. Ground types are closed, so there are no morphisms to thread — +codomains (and their index-spelled refinements) compare directly. -/ +def subCheck (lhs rhs : Ty) : Bool := + match lhs, rhs with + | .base a, .base b => a == b + | .uintRange a, .uintRange b => a == b + | .dataSource a, .dataSource b => a == b + | .txn, .txn => true + | .fn _ k0 d0 c0, .fn _ k1 d1 c1 => + kindOkB k0 k1 && + (if k0 == .data && k1 == .data then + subCheck d1 d0 && subCheck d0 d1 + else + subCheck d1 d0) && + subCheck c0 c1 + | .tuple a, .tuple b => subSeq a b + | .record a, .record b => subFields a b + | .variant a, .variant b => subTags b a + | lhs, rhs => + -- The refinement arm doubles as the mismatch catch-all: with no + -- refinement layer on either side this is `constrain_go`'s final + -- `Mismatch`. + if _h : lhs.peel.2 = [] ∧ rhs.peel.2 = [] then false + else + (deficit lhs.peel.2 rhs.peel.2).isEmpty && + subCheck lhs.peel.1 rhs.peel.1 +termination_by sizeOf lhs + sizeOf rhs +decreasing_by + all_goals simp_wf + all_goals first + | omega + | exact Ty.peel_sum_lt _ _ _h + +/-- Tuple positions, in demand (rhs) order. -/ +def subSeq (a b : List Ty) : Bool := + match a, b with + | _, [] => true + | [], _ :: _ => false + | t0 :: a', t1 :: b' => subCheck t0 t1 && subSeq a' b' +termination_by sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +/-- Record fields the rhs demands, looked up find-first in the lhs. -/ +def subFields (a : List (String × Ty)) (b : List (String × Ty)) : Bool := + match b with + | [] => true + | (n, t1) :: rest => + (match _h : lookupBy a n with + | some t0 => subCheck t0 t1 + | none => false) && + subFields a rest +termination_by sizeOf a + sizeOf b +decreasing_by + all_goals simp_wf + · have := lookupBy_sizeOf _h + omega + · omega + + +/-- Variant tags the lhs may produce, looked up find-first in the rhs. -/ +def subTags (b a : List (FieldKey × Ty)) : Bool := + match a with + | [] => true + | (k, t0) :: rest => + (match _h : lookupBy b k with + | some t1 => subCheck t0 t1 + | none => false) && + subTags b rest +termination_by sizeOf b + sizeOf a +decreasing_by + all_goals simp_wf + · have := lookupBy_sizeOf _h + omega + · omega + +end + +/-! +## Executable spec examples + +One `#guard` per adjudicated behavior (see `formal/design.md`, "M0 status +and adjudicated decisions") — the checker refusing to build is the cheapest +regression net for the rules' shape. +-/ + +/- `{Int | p} <: Int` — dropping a refinement is subsumption. -/ +#guard subCheck (.refined (.base .int) [.elem]) (.base .int) = true + +/- `Int ⊀ {Int | p}` — a refinement cannot be conjured (that is `Restrict`). -/ +#guard subCheck (.base .int) (.refined (.base .int) [.elem]) = false + +/- `{T | p} <: {U | p}` iff `T <: U` — the refined base is covariant: +`{{a, b} | p} <: {{a} | p}` by record width under the shared predicate. -/ +#guard subCheck + (.refined (.record [("a", .base .int), ("b", .base .bool)]) [.elem]) + (.refined (.record [("a", .base .int)]) [.elem]) = true + +/- `UIntRange` is equality-only: `[0,3) ⊀ [0,4)` despite the inclusion. -/ +#guard subCheck (.uintRange 3) (.uintRange 4) = false +#guard subCheck (.uintRange 3) (.uintRange 3) = true + +/- Record width: more fields flow to fewer, never the reverse. -/ +#guard subCheck + (.record [("a", .base .int), ("b", .base .bool)]) + (.record [("a", .base .int)]) = true +#guard subCheck + (.record [("a", .base .int)]) + (.record [("a", .base .int), ("b", .base .bool)]) = false + +/- Variant width is the dual: fewer tags flow to more. -/ +#guard subCheck + (.variant [(.name "some", .base .int)]) + (.variant [(.name "some", .base .int), (.name "none", .base .unit)]) = true + +/- The kinds relate by equality: neither a collection where a capability is +demanded nor a capability where a collection is demanded. -/ +#guard subCheck + (.fn none .data (.uintRange 2) (.base .int)) + (.fn none .compute (.uintRange 2) (.base .int)) = false +#guard subCheck + (.fn none .compute (.uintRange 2) (.base .int)) + (.fn none .data (.uintRange 2) (.base .int)) = false +#guard subCheck + (.fn none .data (.uintRange 2) (.base .int)) + (.fn none .data (.uintRange 2) (.base .int)) = true + +/- Compute domains are contravariant; **data-data domains are invariant** +(the domain *is* the data), so the same domain widening data-to-data fails. -/ +#guard subCheck + (.fn none .compute (.record [("a", .base .int)]) (.base .int)) + (.fn none .compute (.record [("a", .base .int), ("b", .base .bool)]) + (.base .int)) = true +#guard subCheck + (.fn none .data (.record [("a", .base .int)]) (.base .int)) + (.fn none .data (.record [("a", .base .int), ("b", .base .bool)]) + (.base .int)) = false + +/- Indices make α-canonicity structural: two α-variant +dependent function types are the *same* term — `(x: [0,3)) ⤇ {Int | __elem == #0}` +and its `y`-spelt twin both close to `piBound 0`, whatever the display +binder says. -/ +#guard subCheck + (.fn (some "x") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.piBound 0))])) + (.fn (some "y") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.piBound 0))])) = true + +/- Injectivity: a reference to a *different* frame is a different index and +does not match — the silent specialization sharing indices exist to rule +out. -/ +#guard subCheck + (.fn (some "x") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.piBound 0))])) + (.fn (some "y") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.piBound 1))])) = false + +/- A *free* reference (a `let`-bound name a refinement may keep) is a globally +unique name and compares structurally: same name matches, distinct names do +not. -/ +#guard subCheck + (.fn (some "x") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.var "n"))])) + (.fn (some "y") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.var "n"))])) = true +#guard subCheck + (.fn (some "x") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.var "n"))])) + (.fn (some "y") .data (.uintRange 3) + (.refined (.base .int) [(.binop "eq" .elem (.var "m"))])) = false + +/- No partition collapse: a `Variant` domain is below only a `Variant` +domain, so a fan-out-shaped supplier does not satisfy a plain-domain demand. +The fan-out never presents this pair — it is a `DisjointJoin` over the one +domain its arms share — so the relation needs no arm for it. -/ +#guard subCheck + (.fn none .data + (.variant [(.idx 0, .refined (.uintRange 3) [(.litInt 0)]), + (.idx 1, .refined (.uintRange 3) [(.litInt 1)])]) + (.base .int)) + (.fn none .data (.uintRange 3) (.base .int)) = false + +/- A chain whose two hops use different rules — contravariant record width at +each — composes: the executable face of `sub_trans_id`. The kind cannot be one +of the hops any more; it is fixed across the whole chain. -/ +#guard subCheck + (.fn none .compute (.record [("a", .base .int)]) (.base .int)) + (.fn none .compute (.record [("a", .base .int), ("b", .base .bool)]) + (.base .int)) = true +#guard subCheck + (.fn none .compute (.record [("a", .base .int), ("b", .base .bool)]) + (.base .int)) + (.fn none .compute + (.record [("a", .base .int), ("b", .base .bool), ("c", .base .unit)]) + (.base .int)) = true +#guard subCheck + (.fn none .compute (.record [("a", .base .int)]) (.base .int)) + (.fn none .compute + (.record [("a", .base .int), ("b", .base .bool), ("c", .base .unit)]) + (.base .int)) = true + +end CclFormal diff --git a/formal/CclFormal/Equiv.lean b/formal/CclFormal/Equiv.lean new file mode 100644 index 00000000..5a9ce191 --- /dev/null +++ b/formal/CclFormal/Equiv.lean @@ -0,0 +1,286 @@ +import CclFormal.Decide + +/-! +# Checker ↔ relation: soundness, completeness, decidability + +`subCheck_iff_sub` proves the executable checker decides exactly the +declarative relation, giving `Decidable (Sub lhs rhs)` — the ground +subtype relation is decidable, and every `#guard` in `Decide.lean` is +therefore a fact about `Sub` itself, not just about the checker. +-/ + +namespace CclFormal + +theorem kindOkB_iff {k0 k1 : FunKind} : kindOkB k0 k1 = true ↔ kindOk k0 k1 := by + cases k0 <;> cases k1 <;> simp [kindOkB, kindOk] + +theorem subSeq_iff : + ∀ a b, subSeq a b = true ↔ + (b.length ≤ a.length ∧ + ∀ (i : Nat) t0 t1, a[i]? = some t0 → b[i]? = some t1 → + subCheck t0 t1 = true) + | a, [] => by simp [subSeq] + | [], _ :: _ => by simp [subSeq] + | t0 :: a, t1 :: b => by + simp only [subSeq, Bool.and_eq_true, subSeq_iff a b, + List.length_cons] + constructor + · rintro ⟨h0, hlen, hrest⟩ + refine ⟨Nat.succ_le_succ hlen, ?_⟩ + intro i u0 u1 hu0 hu1 + match i with + | 0 => + simp at hu0 hu1 + subst hu0; subst hu1 + exact h0 + | j + 1 => + simp at hu0 hu1 + exact hrest j u0 u1 hu0 hu1 + · intro ⟨hlen, hall⟩ + refine ⟨hall 0 t0 t1 (by simp) (by simp), + Nat.le_of_succ_le_succ hlen, ?_⟩ + intro j u0 u1 h0 h1 + exact hall (j + 1) u0 u1 (by simpa using h0) (by simpa using h1) + +theorem subFields_iff (a : List (String × Ty)) : + ∀ b, subFields a b = true ↔ + ((∀ n t1, (n, t1) ∈ b → (lookupBy a n).isSome) ∧ + ∀ n t0 t1, (n, t1) ∈ b → lookupBy a n = some t0 → + subCheck t0 t1 = true) + | [] => by simp [subFields] + | (n1, t1) :: rest => by + simp only [subFields, Bool.and_eq_true, subFields_iff a rest] + cases hlk : lookupBy a n1 with + | none => + simp only [Bool.false_eq_true, false_and] + constructor + · exact fun h => h.elim + · rintro ⟨hsome, _⟩ + have := hsome n1 t1 (List.mem_cons_self ..) + rw [hlk] at this + exact absurd this (by simp) + | some t0 => + constructor + · rintro ⟨h0, hsome, hsub⟩ + constructor + · intro n u hm + rcases List.mem_cons.mp hm with heq | hmem + · injection heq with h1 h2 + subst h1 + rw [hlk]; rfl + · exact hsome n u hmem + · intro n u0 u1 hm hl + rcases List.mem_cons.mp hm with heq | hmem + · injection heq with h1 h2 + subst h1; subst h2 + rw [hlk] at hl + injection hl with h + subst h + exact h0 + · exact hsub n u0 u1 hmem hl + · rintro ⟨hsome, hsub⟩ + exact ⟨hsub n1 t0 t1 (List.mem_cons_self ..) hlk, + fun n u hm => hsome n u (List.mem_cons_of_mem _ hm), + fun n u0 u1 hm hl => hsub n u0 u1 (List.mem_cons_of_mem _ hm) hl⟩ + +theorem subTags_iff (b : List (FieldKey × Ty)) : + ∀ a, subTags b a = true ↔ + ((∀ k t0, (k, t0) ∈ a → (lookupBy b k).isSome) ∧ + ∀ k t0 t1, (k, t0) ∈ a → lookupBy b k = some t1 → + subCheck t0 t1 = true) + | [] => by simp [subTags] + | (k0, t0) :: rest => by + simp only [subTags, Bool.and_eq_true, subTags_iff b rest] + cases hlk : lookupBy b k0 with + | none => + simp only [Bool.false_eq_true, false_and] + constructor + · exact fun h => h.elim + · rintro ⟨hsome, _⟩ + have := hsome k0 t0 (List.mem_cons_self ..) + rw [hlk] at this + exact absurd this (by simp) + | some t1 => + constructor + · rintro ⟨h0, hsome, hsub⟩ + constructor + · intro k u hm + rcases List.mem_cons.mp hm with heq | hmem + · injection heq with h1 h2 + subst h1 + rw [hlk]; rfl + · exact hsome k u hmem + · intro k u0 u1 hm hl + rcases List.mem_cons.mp hm with heq | hmem + · injection heq with h1 h2 + subst h1; subst h2 + rw [hlk] at hl + injection hl with h + subst h + exact h0 + · exact hsub k u0 u1 hmem hl + · rintro ⟨hsome, hsub⟩ + exact ⟨hsub k0 t0 t1 (List.mem_cons_self ..) hlk, + fun k u hm => hsome k u (List.mem_cons_of_mem _ hm), + fun k u0 u1 hm hl => hsub k u0 u1 (List.mem_cons_of_mem _ hm) hl⟩ + +/-- **Soundness**: an accepting run of the checker is a derivation. -/ +theorem sub_of_subCheck : + ∀ (lhs rhs : Ty), + subCheck lhs rhs = true → Sub lhs rhs + | lhs, rhs, h => by + rw [subCheck.eq_def] at h + split at h + -- Leaves. + · exact eq_of_beq h ▸ Sub.base _ + · exact eq_of_beq h ▸ Sub.uintRange _ + · exact eq_of_beq h ▸ Sub.dataSource _ + · exact Sub.txn + -- Function edge. + · rename_i n0 k0 d0 c0 n1 k1 d1 c1 + rw [Bool.and_eq_true, Bool.and_eq_true] at h + obtain ⟨⟨hok, hdom⟩, hcod⟩ := h + have hcodS := sub_of_subCheck c0 c1 hcod + split at hdom + · -- data-data: invariant domains. + rename_i hdd + rw [Bool.and_eq_true] at hdd + have hk0 : k0 = .data := by simpa using hdd.1 + have hk1 : k1 = .data := by simpa using hdd.2 + subst hk0; subst hk1 + rw [Bool.and_eq_true] at hdom + exact Sub.fnData + (sub_of_subCheck d1 d0 hdom.1) + (sub_of_subCheck d0 d1 hdom.2) hcodS + · rename_i hdd + have hnd : ¬(k0 = .data ∧ k1 = .data) := by + rintro ⟨rfl, rfl⟩ + exact hdd (by simp) + exact Sub.fnCompute (kindOkB_iff.mp hok) hnd + (sub_of_subCheck d1 d0 hdom) hcodS + -- Tuple. + · rename_i a b + obtain ⟨hlen, hpt⟩ := (subSeq_iff a b).mp h + refine Sub.tuple hlen fun i t0 t1 h0 h1 => ?_ + have hm0 := List.mem_of_getElem? h0 + have hm1 := List.mem_of_getElem? h1 + have hs0 := List.sizeOf_lt_of_mem hm0 + have hs1 := List.sizeOf_lt_of_mem hm1 + exact sub_of_subCheck t0 t1 (hpt i t0 t1 h0 h1) + -- Record. + · rename_i a b + obtain ⟨hsome, hsub⟩ := (subFields_iff a b).mp h + refine Sub.record hsome fun n t0 t1 hm hlk => ?_ + have hs0 := lookupBy_sizeOf hlk + have hs1 : sizeOf t1 < sizeOf b := by + have h' := List.sizeOf_lt_of_mem hm + rw [Prod.mk.sizeOf_spec] at h' + omega + exact sub_of_subCheck t0 t1 (hsub n t0 t1 hm hlk) + -- Variant. + · rename_i a b + obtain ⟨hsome, hsub⟩ := (subTags_iff b a).mp h + refine Sub.variant hsome fun k t0 t1 hm hlk => ?_ + have hs1 := lookupBy_sizeOf hlk + have hs0 : sizeOf t0 < sizeOf a := by + have h' := List.sizeOf_lt_of_mem hm + rw [Prod.mk.sizeOf_spec] at h' + omega + exact sub_of_subCheck t0 t1 (hsub k t0 t1 hm hlk) + -- Refinement arm / mismatch catch-all. `lhs`/`rhs` stay un-substituted + -- here (the catch-all pins no constructors), which is exactly what + -- `Sub.refined`'s generic conclusion wants. + · split at h + · exact absurd h (by simp) + · rename_i hne + rw [Bool.and_eq_true] at h + obtain ⟨hdef, hbase⟩ := h + have hlt := Ty.peel_sum_lt lhs rhs hne + refine Sub.refined rfl rfl ?_ ?_ + (sub_of_subCheck lhs.peel.1 rhs.peel.1 hbase) + · cases hl : lhs.peel.2 with + | nil => + cases hr : rhs.peel.2 with + | nil => exact absurd ⟨hl, hr⟩ hne + | cons _ _ => exact .inr (by simp) + | cons _ _ => exact .inl (by simp) + · simpa using hdef +termination_by lhs rhs _ => sizeOf lhs + sizeOf rhs +decreasing_by + all_goals try subst_vars + all_goals simp_wf + all_goals first + | omega + | (simp at hsz; omega) + +/-- **Completeness**: a derivation makes the checker accept. -/ +theorem subCheck_of_sub {lhs rhs : Ty} + (h : Sub lhs rhs) : subCheck lhs rhs = true := by + induction h with + | base b => simp [subCheck] + | uintRange n => simp [subCheck] + | dataSource s => simp [subCheck] + | txn => simp [subCheck] + | @fnCompute n0 n1 k0 k1 d0 c0 d1 c1 hok hnd hdom hcod ihdom ihcod => + have hdd : (k0 == FunKind.data && k1 == FunKind.data) = false := by + rw [Bool.and_eq_false_iff] + by_cases hk : k0 = .data + · subst hk + refine .inr ?_ + rw [Bool.eq_false_iff] + intro hp + exact hnd ⟨rfl, by simpa using hp⟩ + · exact .inl (by simpa using hk) + simp only [subCheck] + simp [hdd, kindOkB_iff.mpr hok, ihdom, ihcod] + | @fnData n0 n1 d0 c0 d1 c1 hdom1 hdom2 hcod ih1 ih2 ihcod => + simp only [subCheck] + simp [kindOkB, ih1, ih2, ihcod] + | tuple hlen hpt ihpt => + simp only [subCheck] + exact (subSeq_iff _ _).mpr ⟨hlen, ihpt⟩ + | record hsome hsub ihsub => + simp only [subCheck] + exact (subFields_iff _ _).mpr ⟨hsome, ihsub⟩ + | variant hsome hsub ihsub => + simp only [subCheck] + exact (subTags_iff _ _).mpr ⟨hsome, ihsub⟩ + | @refined lhs rhs lb lrefs rb rrefs hpl hpr hguard hdef hbase ihbase => + -- The conclusion's sides are generic; every non-catch-all checker arm + -- has both sides peeling to `(·, [])`, refuting the guard, and the + -- catch-all's else-branch is supplied by the premises. + rw [subCheck.eq_def] + split + all_goals try + (simp only [Ty.peel, Prod.mk.injEq] at hpl hpr + obtain ⟨-, hl2⟩ := hpl + obtain ⟨-, hr2⟩ := hpr + subst hl2; subst hr2 + rcases hguard with hg | hg <;> exact absurd rfl hg) + -- The catch-all: the dite's condition is false by the guard. + rw [dif_neg] + · simp only [Bool.and_eq_true] + refine ⟨?_, ?_⟩ + · rw [hpl, hpr] + simpa using hdef + · have hb : lhs.peel.1 = lb := by rw [hpl] + have hb' : rhs.peel.1 = rb := by rw [hpr] + rw [hb, hb'] + exact ihbase + · rintro ⟨hl, hr⟩ + rw [hpl] at hl + rw [hpr] at hr + simp at hl hr + subst hl; subst hr + rcases hguard with hg | hg <;> exact absurd rfl hg + +/-- The checker decides exactly the relation. -/ +theorem subCheck_iff_sub (lhs rhs : Ty) : + subCheck lhs rhs = true ↔ Sub lhs rhs := + ⟨sub_of_subCheck lhs rhs, subCheck_of_sub⟩ + +/-- **The ground subtype relation is decidable.** -/ +instance (lhs rhs : Ty) : Decidable (Sub lhs rhs) := + decidable_of_iff _ (subCheck_iff_sub lhs rhs) + +end CclFormal diff --git a/formal/CclFormal/Json.lean b/formal/CclFormal/Json.lean new file mode 100644 index 00000000..108b2018 --- /dev/null +++ b/formal/CclFormal/Json.lean @@ -0,0 +1,301 @@ +import Lean.Data.Json +import CclFormal.Ty +import CclFormal.Merge + +/-! +# The wire codec + +Hand-written (not derived) so the schema is an explicit, stable contract the +M1 Rust emitter serializes to with plain `serde_json`, rather than whatever +shape a deriving handler happens to produce. Every object carries a `"k"` +discriminant; pairs are 2-arrays. + +The parser is `partial` (recursion over `Lean.Json` has no useful structural +measure); it is harness plumbing, not part of the model — nothing is proved +about it, and the smoke `#guard`s below plus the M1 round-trip fuzz are its +gate. +-/ + +namespace CclFormal + +open Lean (Json ToJson FromJson toJson fromJson?) + +def BaseTy.toWire : BaseTy → String + | .int => "Int" + | .uint => "UInt" + | .string => "String" + | .bool => "Bool" + | .unit => "Unit" + +def BaseTy.fromWire : String → Except String BaseTy + | "Int" => .ok .int + | "UInt" => .ok .uint + | "String" => .ok .string + | "Bool" => .ok .bool + | "Unit" => .ok .unit + | s => .error s!"unknown BaseType: {s}" + +def FunKind.toWire : FunKind → String + | .compute => "compute" + | .data => "data" + +def FunKind.fromWire : String → Except String FunKind + | "compute" => .ok .compute + | "data" => .ok .data + | s => .error s!"unknown FunKind: {s}" + +instance : ToJson FieldKey where + toJson + | .idx n => Json.mkObj [("k", "idx"), ("n", toJson n)] + | .name s => Json.mkObj [("k", "name"), ("s", toJson s)] + +instance : FromJson FieldKey where + fromJson? j := do + match (← j.getObjVal? "k").getStr? with + | .ok "idx" => return .idx (← fromJson? (← j.getObjVal? "n")) + | .ok "name" => return .name (← fromJson? (← j.getObjVal? "s")) + | _ => throw s!"unknown FieldKey: {j.compress}" + +partial def Pred.toJson : Pred → Json + | .elem => Json.mkObj [("k", "elem")] + | .var x => Json.mkObj [("k", "var"), ("x", Lean.toJson x)] + | .piBound k => Json.mkObj [("k", "piBound"), ("i", Lean.toJson k)] + | .litInt n => Json.mkObj [("k", "litInt"), ("n", Lean.toJson n)] + | .litBool b => Json.mkObj [("k", "litBool"), ("b", Lean.toJson b)] + | .litStr s => Json.mkObj [("k", "litStr"), ("s", Lean.toJson s)] + | .litUnit => Json.mkObj [("k", "litUnit")] + | .unop op a => Json.mkObj [("k", "unop"), ("op", Lean.toJson op), ("a", a.toJson)] + | .binop op a b => + Json.mkObj [("k", "binop"), ("op", Lean.toJson op), ("a", a.toJson), ("b", b.toJson)] + | .proj a key => Json.mkObj [("k", "proj"), ("a", a.toJson), ("key", Lean.toJson key)] + | .app f a => Json.mkObj [("k", "app"), ("f", f.toJson), ("a", a.toJson)] + +partial def Pred.fromJson? (j : Json) : Except String Pred := do + match (← j.getObjVal? "k").getStr? with + | .ok "elem" => return .elem + | .ok "var" => return .var (← Lean.fromJson? (← j.getObjVal? "x")) + | .ok "piBound" => return .piBound (← Lean.fromJson? (← j.getObjVal? "i")) + | .ok "litInt" => return .litInt (← Lean.fromJson? (← j.getObjVal? "n")) + | .ok "litBool" => return .litBool (← Lean.fromJson? (← j.getObjVal? "b")) + | .ok "litStr" => return .litStr (← Lean.fromJson? (← j.getObjVal? "s")) + | .ok "litUnit" => return .litUnit + | .ok "unop" => + return .unop (← Lean.fromJson? (← j.getObjVal? "op")) + (← Pred.fromJson? (← j.getObjVal? "a")) + | .ok "binop" => + return .binop (← Lean.fromJson? (← j.getObjVal? "op")) + (← Pred.fromJson? (← j.getObjVal? "a")) + (← Pred.fromJson? (← j.getObjVal? "b")) + | .ok "proj" => + return .proj (← Pred.fromJson? (← j.getObjVal? "a")) + (← Lean.fromJson? (← j.getObjVal? "key")) + | .ok "app" => + return .app (← Pred.fromJson? (← j.getObjVal? "f")) + (← Pred.fromJson? (← j.getObjVal? "a")) + | _ => throw s!"unknown Pred: {j.compress}" + +instance : ToJson Pred := ⟨Pred.toJson⟩ +instance : FromJson Pred := ⟨Pred.fromJson?⟩ + +partial def Ty.toJson : Ty → Json + | .base b => Json.mkObj [("k", "base"), ("base", Lean.toJson b.toWire)] + | .uintRange n => Json.mkObj [("k", "uintRange"), ("n", Lean.toJson n)] + | .dataSource s => Json.mkObj [("k", "dataSource"), ("name", Lean.toJson s)] + | .txn => Json.mkObj [("k", "txn")] + | .fn n k d c => + Json.mkObj [("k", "fn"), + ("binder", match n with | some s => Lean.toJson s | none => Json.null), + ("kind", Lean.toJson k.toWire), ("dom", d.toJson), ("cod", c.toJson)] + | .tuple ts => Json.mkObj [("k", "tuple"), ("ts", Json.arr (ts.map Ty.toJson).toArray)] + | .record fs => + Json.mkObj [("k", "record"), + ("fields", Json.arr (fs.map fun (n, t) => + Json.arr #[Lean.toJson n, t.toJson]).toArray)] + | .variant tags => + Json.mkObj [("k", "variant"), + ("tags", Json.arr (tags.map fun (key, t) => + Json.arr #[Lean.toJson key, t.toJson]).toArray)] + | .refined b ps => + Json.mkObj [("k", "refined"), ("base", b.toJson), + ("refinements", Json.arr (ps.map Lean.toJson).toArray)] + +mutual + +partial def Ty.fromJson? (j : Json) : Except String Ty := do + match (← j.getObjVal? "k").getStr? with + | .ok "base" => return .base (← BaseTy.fromWire (← (← j.getObjVal? "base").getStr?)) + | .ok "uintRange" => return .uintRange (← Lean.fromJson? (← j.getObjVal? "n")) + | .ok "dataSource" => return .dataSource (← Lean.fromJson? (← j.getObjVal? "name")) + | .ok "txn" => return .txn + | .ok "fn" => + let binder ← match ← j.getObjVal? "binder" with + | Json.null => pure none + | b => some <$> Lean.fromJson? b + return .fn binder (← FunKind.fromWire (← (← j.getObjVal? "kind").getStr?)) + (← Ty.fromJson? (← j.getObjVal? "dom")) (← Ty.fromJson? (← j.getObjVal? "cod")) + | .ok "tuple" => + let ts ← (← (← j.getObjVal? "ts").getArr?).toList.mapM Ty.fromJson? + return .tuple ts + | .ok "record" => + let fs ← (← (← j.getObjVal? "fields").getArr?).toList.mapM + (pairFromJson? Lean.fromJson?) + return .record fs + | .ok "variant" => + let tags ← (← (← j.getObjVal? "tags").getArr?).toList.mapM + (pairFromJson? Lean.fromJson?) + return .variant tags + | .ok "refined" => + return .refined (← Ty.fromJson? (← j.getObjVal? "base")) + (← Lean.fromJson? (← j.getObjVal? "refinements")) + | _ => throw s!"unknown Ty: {j.compress}" + +/-- A `[key, ty]` 2-array pair (record field / variant tag). -/ +partial def pairFromJson? (f : Json → Except String α) (e : Json) : + Except String (α × Ty) := do + match ← e.getArr? with + | #[k, t] => return (← f k, ← Ty.fromJson? t) + | _ => throw s!"expected a 2-array pair: {e.compress}" + +end + +instance : ToJson Ty := ⟨Ty.toJson⟩ +instance : FromJson Ty := ⟨Ty.fromJson?⟩ + +/-! ## The compact type + +`CTy` is the merge model's mirror of `CompactType` (`CclFormal/Merge.lean`), and +this codec is the contract `differential.rs` serializes a real `CompactType` to. +The two abstractions the model makes are applied *by the encoder*, so the wire +carries only what the model can express: the domain slot is `some d` for a single +alternative and `null` for two or more, and a conflicted slot's domain payload is +`null` because coalesce reads it only for a diagnostic. Variable identities and +history slots have no field — the model drops both. -/ + +def KindM.toWire : KindM → String + | .data => "data" + | .compute => "compute" + | .conflict => "conflict" + | .unknown => "unknown" + +def KindM.fromWire : String → Except String KindM + | "data" => .ok .data + | "compute" => .ok .compute + | "conflict" => .ok .conflict + | "unknown" => .ok .unknown + | s => .error s!"unknown KindMerge: {s}" + +def Atom.toJson : Atom → Json + | .prim b => Json.mkObj [("k", "prim"), ("base", Lean.toJson b.toWire)] + | .uintRange n => Json.mkObj [("k", "uintRange"), ("n", Lean.toJson n)] + | .source s => Json.mkObj [("k", "source"), ("s", Lean.toJson s)] + | .txn => Json.mkObj [("k", "txn")] + +def Atom.fromJson? (j : Json) : Except String Atom := do + match (← j.getObjVal? "k").getStr? with + | .ok "prim" => return .prim (← BaseTy.fromWire (← (← j.getObjVal? "base").getStr?)) + | .ok "uintRange" => return .uintRange (← Lean.fromJson? (← j.getObjVal? "n")) + | .ok "source" => return .source (← Lean.fromJson? (← j.getObjVal? "s")) + | .ok "txn" => return .txn + | _ => throw s!"unknown Atom: {j.compress}" + +instance : ToJson Atom := ⟨Atom.toJson⟩ +instance : FromJson Atom := ⟨Atom.fromJson?⟩ + +namespace CTy + +partial def toJson : CTy → Json + | .mk atoms recF varT fn refinements => + let mapJson : List (FieldKey × CTy) → Json := fun m => + Json.arr (m.map fun (k, w) => Json.arr #[Lean.toJson k, toJson w]).toArray + Json.mkObj + [("atoms", Json.arr (atoms.map Atom.toJson).toArray), + ("rec", match recF with | none => Json.null | some m => mapJson m), + ("var", match varT with | none => Json.null | some m => mapJson m), + ("fn", match fn with + | none => Json.null + | some (k, ds, cod) => + Json.mkObj [("kind", Lean.toJson k.toWire), + ("doms", Json.arr (ds.map toJson).toArray), + ("cod", toJson cod)]), + ("refinements", match refinements with + | none => Json.null + | some ps => Json.arr (ps.map Lean.toJson).toArray)] + +mutual + +partial def fromJson? (j : Json) : Except String CTy := do + let atoms ← (← (← j.getObjVal? "atoms").getArr?).toList.mapM Atom.fromJson? + let recF ← optMap (← j.getObjVal? "rec") + let varT ← optMap (← j.getObjVal? "var") + let fn ← match ← j.getObjVal? "fn" with + | Json.null => pure none + | f => do + let k ← KindM.fromWire (← (← f.getObjVal? "kind").getStr?) + let ds ← (← (← f.getObjVal? "doms").getArr?).toList.mapM fromJson? + let cod ← fromJson? (← f.getObjVal? "cod") + pure (some (k, ds, cod)) + let refinements ← match ← j.getObjVal? "refinements" with + | Json.null => pure none + | c => some <$> Lean.fromJson? c + return .mk atoms recF varT fn refinements + +/-- A `null`-or-array keyed map: the `Option (List (FieldKey × CTy))` slots. -/ +partial def optMap (j : Json) : Except String (Option (List (FieldKey × CTy))) := do + match j with + | Json.null => return none + | _ => + let entries ← (← j.getArr?).toList.mapM fun e => do + match ← e.getArr? with + | #[k, w] => do + let key : FieldKey ← Lean.fromJson? k + let payload ← fromJson? w + pure (key, payload) + | _ => throw s!"expected a 2-array pair: {e.compress}" + return some entries + +end + +end CTy + +instance : ToJson CTy := ⟨CTy.toJson⟩ +instance : FromJson CTy := ⟨CTy.fromJson?⟩ + +/-- Round-trip smoke checks (`BEq`-compared; `beq ↔ eq` is a later step). -/ +private def roundTrips (t : Ty) : Bool := + match (Lean.fromJson? (Lean.toJson t) : Except String Ty) with + | .ok t' => t == t' + | .error _ => false + +#guard roundTrips (.base .int) +#guard roundTrips (.fn (some "x") .data (.uintRange 3) + (.refined (.base .int) [.binop "eq" .elem (.var "x")])) +-- A multi-refinement position round-trips too: the wire carries the whole set. +#guard roundTrips (.refined (.base .int) + [.binop "eq" .elem (.var "x"), .binop "eq" .elem (.var "y")]) +#guard roundTrips (.record [("a", .base .bool), ("b", .tuple [.txn, .dataSource "s"])]) +#guard roundTrips (.variant [(.idx 0, .base .unit), (.name "tag", .base .string)]) + +/-- The same smoke check for the compact type. -/ +private def cRoundTrips (t : CTy) : Bool := + match (CTy.fromJson? (CTy.toJson t) : Except String CTy) with + | .ok t' => CTy.eqv t t' + | .error _ => false + +-- `none` refinements (no contribution) and `some []` (a value guaranteeing nothing) +-- are distinct on the wire, which is the whole point of the slot's sentinel. +#guard cRoundTrips (.mk [] none none none none) +#guard cRoundTrips (.mk [] none none none (some [])) +#guard !CTy.eqv (.mk [] none none none none) (.mk [] none none none (some [])) +#guard cRoundTrips (.mk [.prim .int, .txn, .uintRange 3, .source "s"] none none none + (some [.binop "eq" .elem (.litInt 1)])) +-- Every slot at once, including a `null` ("two or more") domain and a conflicted kind. +#guard cRoundTrips (.mk [.prim .bool] + (some [(.idx 0, .mk [.prim .int] none none none (some []))]) + (some [(.name "tag", .mk [] none none none none)]) + (some (.conflict, [], .mk [.prim .string] none none none (some []))) (some [])) +#guard cRoundTrips (.mk [] none none + (some (.unknown, [.mk [.prim .int] none none none (some []), + .mk [.prim .bool] none none none (some [])], + .mk [] (some []) none none none)) (some [])) + +end CclFormal diff --git a/formal/CclFormal/Merge.lean b/formal/CclFormal/Merge.lean new file mode 100644 index 00000000..afed2577 --- /dev/null +++ b/formal/CclFormal/Merge.lean @@ -0,0 +1,2845 @@ +import CclFormal.Ty + +/-! +# The solver's polar merge and its algebra + +The Lean mirror of `src/ccl/infer/solver/compact.rs`'s bound-merging — the +operation `coalesce` folds over a variable's bounds (`CompactType::merge`, +`CompactFun::merge`, `merge_refinements`, `merge_records`, `merge_variants`) — +and the theorems that make the solver's order-independence refinement a proof +obligation instead of a fuzz observation: + +- `eqv` is an equivalence relation (`eqv_refl`, `eqv_symm`, `eqv_trans`); +- `merge` is commutative (`merge_comm`), idempotent (`merge_idem`, under `wf`), + and a congruence for `eqv` (`merge_congr_left`/`_right`); +- `merge` is associative (`merge_assoc`), at either polarity and with no side + condition — the kinds join in a semilattice (`joinKind`) and the domains are + combined by polarity alone, so no step reads a value a later step can change; +- the fold `coalesce` performs is therefore invariant under permutation + (`foldMerge_perm`) and duplication (`foldMerge_dup`) of the bound list; +- `merge pol` is the least upper bound of the order it induces, and the *only* + one up to `eqv` (`merge_isLub`, `join_unique`), with the empty position as the + order's least element (`merge_cempty_left`, `le_cempty`). + +`differential.rs`'s `differential_bound_merge_vs_lean_model` is what keeps this +a statement about the solver: it folds generated bound lists through +`CompactType::merge` exactly as `compact_go` does and checks every step against +`merge` here, judged by `eqv`. + +## What the model is a mirror of, and what it drops + +`CTy` is the ground fragment of `CompactType`: atoms, the optional +record/variant maps, the optional function slot, and the refinement slot with its +`none` sentinel. Deliberately dropped, with the reasoning: + +- **Inference variables** (`vars`) — the ground algebra doesn't read them; + they union like atoms and would only pad every proof. +- **History slots** — transients erased before the strict wall, exactly as + `Ty` excludes `History` (same-polarity componentwise merge; nothing new). +- **The Pi binder** (`CompactFun::name`, merged `a.name.or(b.name)`) — + first-wins is order-dependent as written, but the slot carries no refinement + identity: a refinement's binding is its index (`Name::PiBound`), so the merged + refinements agree whatever spelling survives, and the slot is display plus the + frame's opening address; the asymmetry is unobservable. +- **A conflicted slot's domain payload** — `compact.rs` keeps `widest`, which + picks between two equal-length lists by arrival order. Coalesce prints those + alternatives and reads nothing from them, so the model drops the payload rather + than mirror an order-dependent choice, and the differential's encoder drops it + too. Every other slot's alternatives are mirrored in full: `fn`'s domain slot is + a `List CTy` matching `DomainSet`, because `coalesce_compact_go` folds the + contravariant meet over it and two slots differing in the tail materialize + differently. + +## The equivalence is the code's own equality + +`eqv` mirrors `CompactType`'s `PartialEq`: set-semantic on atoms and refinements +(mirroring `BTreeSet` and `RefinementSet`), key-set + payload on the maps +(mirroring `BTreeMap`), componentwise on the function slot. The merge's one +internal comparison — `union_domains` deduplicating two `Data` domains — uses +that same equality, which is what makes every theorem quotient-compatible: +the gate cannot distinguish two `eqv`-equal inputs. + +The empty position **is** an identity (`merge_cempty_left`), because every slot +including the refinement slot has a `none` that merges as one. `compact_go` still +folds a variable's bounds from the *first bound* rather than from +`CompactType::default()`, so the fold theorems are stated over nonempty lists, +but that is now the code's habit rather than an algebraic requirement. +-/ + +namespace CclFormal + +/-- Mirror of `compact.rs :: AtomKey` (ground fragment — `ChanDom` excluded, +the same adjudication as `Ty`'s exclusion of pipeline transients). -/ +inductive Atom where + | prim (b : BaseTy) + | uintRange (n : Nat) + | source (s : String) + | txn +deriving Repr, DecidableEq + +/-- Mirror of `compact.rs :: KindMerge`: the flat semilattice +`unknown < {data, compute} < conflict`. `unknown` is a kind variable nothing +pinned — the identity, since nothing *required* a kind there — and `conflict` is +the absorbing state a bad kind meeting leaves behind (coalesce turns it into an +error; it never materializes). -/ +inductive KindM where + | data | compute | conflict | unknown +deriving Repr, DecidableEq + +/-! ## The refinement slot + +`compact.rs`'s `refinements` is an `Option`, and the two states +are distinct. `none` is "no refinement contribution here" and merges as the identity +— a hole, or a bare variable whose content is its identity alone — while +`some []` is a *value* that guarantees nothing, which is absorbing under the +positive intersect. Collapsing them makes a bare variable erase the refinements a +sibling bound established, which is why the slot carries the same sentinel the +shape slots do. -/ + +/-- The refinement slot's merge: `none` is the identity, and two present sets +intersect at a positive position and unite at a negative one +(`merge_refinements`). -/ +def mergeRefinements (pol : Bool) : Option (List Pred) → Option (List Pred) → Option (List Pred) + | none, c => c + | c, none => c + | some p1, some p2 => some (if pol then p1.filter (p2.contains ·) else p1 ++ p2) + +/-- Set-semantic equality on the refinement slot, mirroring `RefinementSet`. -/ +def refinementsEqv : Option (List Pred) → Option (List Pred) → Bool + | none, none => true + | some p1, some p2 => p1.all (p2.contains ·) && p2.all (p1.contains ·) + | _, _ => false + +/-- `refinementsEqv`, read as mutual membership. -/ +theorem refinementsEqv_iff {p q : List Pred} : + refinementsEqv (some p) (some q) = true ↔ (∀ x ∈ p, x ∈ q) ∧ ∀ x ∈ q, x ∈ p := by + simp only [refinementsEqv, Bool.and_eq_true, List.all_eq_true, List.contains_iff_mem] + +theorem refinementsEqv_refl (c : Option (List Pred)) : refinementsEqv c c = true := by + rcases c with _ | p + · rfl + · exact refinementsEqv_iff.mpr ⟨fun _ h => h, fun _ h => h⟩ + +theorem refinementsEqv_symm {a b : Option (List Pred)} (h : refinementsEqv a b = true) : + refinementsEqv b a = true := by + rcases a with _ | p <;> rcases b with _ | q + · rfl + · exact absurd h (by simp [refinementsEqv]) + · exact absurd h (by simp [refinementsEqv]) + · exact refinementsEqv_iff.mpr (refinementsEqv_iff.mp h).symm + +theorem refinementsEqv_trans {a b c : Option (List Pred)} (hab : refinementsEqv a b = true) + (hbc : refinementsEqv b c = true) : refinementsEqv a c = true := by + rcases a with _ | p <;> rcases b with _ | q <;> rcases c with _ | r + case none.none.none => rfl + case some.some.some => + obtain ⟨hpq, hqp⟩ := refinementsEqv_iff.mp hab + obtain ⟨hqr, hrq⟩ := refinementsEqv_iff.mp hbc + exact refinementsEqv_iff.mpr ⟨fun x hx => hqr x (hpq x hx), fun x hx => hqp x (hrq x hx)⟩ + -- Every remaining case has one side `none` and the other `some`, which + -- `refinementsEqv` refuses. + all_goals simp_all [refinementsEqv] + +/-- The two present-set cases, read as membership: what every law below reduces +to once the `none` identity arms are out of the way. -/ +private theorem mergeRefinements_mem (pol : Bool) (p q : List Pred) (x : Pred) : + (x ∈ (mergeRefinements pol (some p) (some q)).getD [] ↔ + if pol then x ∈ p ∧ x ∈ q else x ∈ p ∨ x ∈ q) := by + cases pol <;> + simp only [mergeRefinements, Bool.false_eq_true, reduceIte, Option.getD_some, List.mem_append, + List.mem_filter, List.contains_iff_mem] + +theorem mergeRefinements_comm (pol : Bool) (a b : Option (List Pred)) : + refinementsEqv (mergeRefinements pol a b) (mergeRefinements pol b a) = true := by + rcases a with _ | p <;> rcases b with _ | q <;> + first + | exact refinementsEqv_refl _ + | skip + cases pol <;> + simp only [mergeRefinements, Bool.false_eq_true, reduceIte] <;> + refine refinementsEqv_iff.mpr ⟨fun x hx => ?_, fun x hx => ?_⟩ <;> + simp only [List.mem_append, List.mem_filter, List.contains_iff_mem] at hx ⊢ <;> + first + | exact hx.symm + | exact ⟨hx.2, hx.1⟩ + +theorem mergeRefinements_idem (pol : Bool) (a : Option (List Pred)) : + refinementsEqv (mergeRefinements pol a a) a = true := by + rcases a with _ | p + · rfl + cases pol <;> + simp only [mergeRefinements, Bool.false_eq_true, reduceIte] <;> + refine refinementsEqv_iff.mpr ⟨fun x hx => ?_, fun x hx => ?_⟩ <;> + simp only [List.mem_append, List.mem_filter, List.contains_iff_mem] at hx ⊢ <;> + first + | exact hx.elim id id + | exact Or.inl hx + | exact hx.1 + | exact ⟨hx, hx⟩ + +theorem mergeRefinements_assoc (pol : Bool) (a b c : Option (List Pred)) : + refinementsEqv (mergeRefinements pol (mergeRefinements pol a b) c) + (mergeRefinements pol a (mergeRefinements pol b c)) = true := by + rcases a with _ | p <;> rcases b with _ | q <;> rcases c with _ | r <;> + first + | exact refinementsEqv_refl _ + | skip + cases pol <;> + simp only [mergeRefinements, Bool.false_eq_true, reduceIte] <;> + refine refinementsEqv_iff.mpr ⟨fun x hx => ?_, fun x hx => ?_⟩ <;> + simp only [List.mem_append, List.mem_filter, List.contains_iff_mem] at hx ⊢ <;> + first + | exact or_assoc.mp hx + | exact or_assoc.mpr hx + | exact and_assoc.mp hx + | exact and_assoc.mpr hx + +theorem mergeRefinements_congr_left (pol : Bool) {a a' : Option (List Pred)} + (b : Option (List Pred)) (h : refinementsEqv a a' = true) : + refinementsEqv (mergeRefinements pol a b) (mergeRefinements pol a' b) = true := by + rcases a with _ | p <;> rcases a' with _ | p' + · exact refinementsEqv_refl _ + · exact absurd h (by simp [refinementsEqv]) + · exact absurd h (by simp [refinementsEqv]) + rcases b with _ | q + · exact h + obtain ⟨hpp, hpp'⟩ := refinementsEqv_iff.mp h + cases pol <;> + simp only [mergeRefinements, Bool.false_eq_true, reduceIte] <;> + refine refinementsEqv_iff.mpr ⟨fun x hx => ?_, fun x hx => ?_⟩ <;> + simp only [List.mem_append, List.mem_filter, List.contains_iff_mem] at hx ⊢ + · exact hx.imp (hpp x) id + · exact hx.imp (hpp' x) id + · exact ⟨hpp x hx.1, hx.2⟩ + · exact ⟨hpp' x hx.1, hx.2⟩ + +/-- The kind join at the head of `CompactFun::merge`: `unknown` is the identity +(nothing *required* a kind on that side, so the other side's answer stands), +`conflict` is absorbing, a kind meeting itself is itself, and the two concrete +kinds are incomparable — neither reading stands in for the other. One operation +for both polarities. -/ +def joinKind : KindM → KindM → KindM + | .conflict, _ => .conflict + | _, .conflict => .conflict + | .unknown, k => k + | k, .unknown => k + | k1, k2 => if k1 == k2 then k1 else .conflict + +theorem joinKind_comm (a b : KindM) : joinKind a b = joinKind b a := by + cases a <;> cases b <;> rfl + +theorem joinKind_assoc (a b c : KindM) : + joinKind (joinKind a b) c = joinKind a (joinKind b c) := by + cases a <;> cases b <;> cases c <;> rfl + +theorem joinKind_idem (a : KindM) : joinKind a a = a := by + cases a <;> rfl + +/-- Mirror of the ground fragment of `compact.rs :: CompactType`. + +The function slot is `(kind, domain, codomain)` with `domain : Option CTy` — +`some d` is a single domain alternative, `none` is "two or more distinct +alternatives" (see the module docs for why the tail of `union_domains`' list +is diagnostic-only). `recF`/`varT` mirror the `Option>` fields: +`none` is the merge identity ("no component here"), `some []` the absorbing +empty shape — the distinction `compact.rs` documents as load-bearing. -/ +inductive CTy where + | mk (atoms : List Atom) + (recF : Option (List (FieldKey × CTy))) + (varT : Option (List (FieldKey × CTy))) + (fn : Option (KindM × List CTy × CTy)) + (refinements : Option (List Pred)) +deriving Repr + +namespace CTy + +/-- `sizeOf` of a looked-up payload is below the map's. -/ +theorem lookup_sizeOf {m : List (FieldKey × CTy)} {k : FieldKey} {w : CTy} + (h : m.lookup k = some w) : sizeOf w < sizeOf m := by + induction m with + | nil => simp [List.lookup] at h + | cons hd tl ih => + rw [List.lookup] at h + split at h + · cases h + cases hd + simp + omega + · have := ih h + cases hd + simp + omega + +/-! ## The equivalence (`CompactType`'s `PartialEq`) -/ + +mutual + +/-- Set-semantic equality, mirroring `CompactType`'s `PartialEq` (see module +docs). Defined *before* `merge` because the merge's domain-dedup gate uses it, +exactly as `union_domains` uses `PartialEq`. -/ +def eqv : CTy → CTy → Bool + | .mk a1 r1 v1 f1 c1, .mk a2 r2 v2 f2 c2 => + a1.all (a2.contains ·) && a2.all (a1.contains ·) + && (match r1, r2 with + | none, none => true + | some m1, some m2 => + subKeys m1 m2 (m1.map Prod.fst) && subKeys m2 m1 (m2.map Prod.fst) + | _, _ => false) + && (match v1, v2 with + | none, none => true + | some m1, some m2 => + subKeys m1 m2 (m1.map Prod.fst) && subKeys m2 m1 (m2.map Prod.fst) + | _, _ => false) + && (match f1, f2 with + | none, none => true + | some (k1, d1, c1), some (k2, d2, c2) => + k1 == k2 + && (subDoms d2 d1 && subDoms d1 d2) + && eqv c1 c2 + | _, _ => false) + && refinementsEqv c1 c2 +termination_by a b => (sizeOf a + sizeOf b, 0) + +/-- Whether `m` holds an `eqv` partner for `d`. Structural in `m` so the +termination measure can see each element. -/ +def anyEqv (d : CTy) : List CTy → Bool + | [] => false + | y :: ys => eqv d y || anyEqv d ys +termination_by m => (sizeOf d + sizeOf m, 0) +decreasing_by all_goals (apply Prod.Lex.left; simp; omega) + +/-- Containment of one alternative list in another, over a worklist. The domain +alternatives compare as a **set**: `union_domains` deduplicates them, and their +only readers are a `Data` slot's refusal to have more than one and a `Compute` +slot's commutative meet-fold at coalesce, so their order carries no information. +This is the one place `eqv` is deliberately coarser than `CompactFun`'s derived +`PartialEq`, which compares the `Vec` positionally. -/ +def subDoms (m2 : List CTy) : List CTy → Bool + | [] => true + | d :: ds => anyEqv d m2 && subDoms m2 ds +termination_by ds => (sizeOf m2 + sizeOf ds, ds.length) +decreasing_by all_goals (apply Prod.Lex.left; simp; omega) + +/-- Keyed containment over a key worklist: every key in `ks` resolves in both +maps to `eqv` payloads. Driven by `lookup` on **both** sides (not the peeled +entry), so a shadowed duplicate binding is unobservable — mirroring +`BTreeMap`, which cannot hold one. `eqv` calls it with `ks = m1.map Prod.fst` +in both directions. -/ +def subKeys (m1 m2 : List (FieldKey × CTy)) : List FieldKey → Bool + | [] => true + | k :: ks => + (match h1 : m1.lookup k, h2 : m2.lookup k with + | some v, some w => eqv v w + | _, _ => false) + && subKeys m1 m2 ks +termination_by ks => (sizeOf m1 + sizeOf m2, ks.length) +decreasing_by + · have hv := lookup_sizeOf h1 + have hw := lookup_sizeOf h2 + apply Prod.Lex.left + omega + · apply Prod.Lex.right + simp + +end + +/-! ## The domain alternatives, read as a set + +`eqv`'s fn clause compares them with `subDoms`, and every law below reasons +through `anyEqv_iff`/`subDoms_iff`, so the representation is never touched again. +This is the one place `eqv` is deliberately coarser than `CompactFun`'s derived +`PartialEq`, which compares the `Vec` positionally: `union_domains` deduplicates +the alternatives and their only readers are a `Data` slot's refusal to hold more +than one and a `Compute` slot's commutative meet-fold at coalesce, so their order +carries no information. That the order is unobservable downstream is what +`tests/type_merge_fuzz.rs` checks, by comparing coalesced outcomes across arrival +orders. -/ + +/-- Set equality on the alternatives, the shape `eqv`'s fn clause checks. -/ +def domsEqv (a b : List CTy) : Bool := subDoms b a && subDoms a b + +theorem anyEqv_iff {d : CTy} {m : List CTy} : + anyEqv d m = true ↔ ∃ y ∈ m, eqv d y = true := by + induction m with + | nil => simp [anyEqv] + | cons y ys ih => + rw [anyEqv, Bool.or_eq_true, ih] + constructor + · rintro (h | ⟨z, hz, hzy⟩) + · exact ⟨y, by simp, h⟩ + · exact ⟨z, by simp [hz], hzy⟩ + · rintro ⟨z, hz, hzy⟩ + rcases List.mem_cons.mp hz with h | h + · exact Or.inl (h ▸ hzy) + · exact Or.inr ⟨z, h, hzy⟩ + +theorem subDoms_iff {m2 ds : List CTy} : + subDoms m2 ds = true ↔ ∀ x ∈ ds, ∃ y ∈ m2, eqv x y = true := by + induction ds with + | nil => simp [subDoms] + | cons d ds ih => + rw [subDoms, Bool.and_eq_true, ih, anyEqv_iff] + constructor + · rintro ⟨hd, htl⟩ x hx + rcases List.mem_cons.mp hx with h | h + · exact h ▸ hd + · exact htl x h + · intro h + exact ⟨h d (by simp), fun x hx => h x (by simp [hx])⟩ + +/-- `domsEqv` and the pair of containments its `Bool` unfolds to — the shape a +proof gets after `simp only [Bool.and_eq_true]` splits `eqv`'s clause. -/ +theorem domsEqv_iff_and {a b : List CTy} : + domsEqv a b = true ↔ subDoms b a = true ∧ subDoms a b = true := by + rw [domsEqv, Bool.and_eq_true] + +theorem domsEqv_iff {a b : List CTy} : + domsEqv a b = true ↔ + (∀ x ∈ a, ∃ y ∈ b, eqv x y = true) ∧ ∀ y ∈ b, ∃ x ∈ a, eqv y x = true := by + rw [domsEqv, Bool.and_eq_true, subDoms_iff, subDoms_iff] + +theorem domsEqv_symm {a b : List CTy} (h : domsEqv a b = true) : domsEqv b a = true := + domsEqv_iff.mpr (domsEqv_iff.mp h).symm + +/-! ## The merge -/ + +mutual + +/-- Mirror of `CompactType::merge` (ground fragment). `pol` is the polarity: +positive merges are joins (types union, refinements/record-keys intersect, variant +tags union), negative merges are meets (the duals). -/ +def merge (pol : Bool) : CTy → CTy → CTy + | .mk a1 r1 v1 f1 c1, .mk a2 r2 v2 f2 c2 => + .mk (a1 ++ a2) + (match r1, r2 with + | none, r | r, none => r + | some m1, some m2 => + some + (if pol then interMap pol m1 m2 + else unionMapGo pol m1 m2 ++ m2.filter (fun kw => (m1.lookup kw.1).isNone))) + (match v1, v2 with + | none, v | v, none => v + | some m1, some m2 => + some + (if pol then unionMapGo pol m1 m2 ++ m2.filter (fun kw => (m1.lookup kw.1).isNone) + else interMap pol m1 m2)) + (match f1, f2 with + | none, f | f, none => f + | some s1, some s2 => some (mergeFun pol s1 s2)) + (mergeRefinements pol c1 c2) +termination_by a b => sizeOf a + sizeOf b + +/-- Keyed merge, intersecting keys (records at positive polarity, variants at +negative): keep only keys present on both sides, payloads merged at the outer +polarity (covariant depth — `merge_keyed` with `intersect_keys = true`). -/ +def interMap (pol : Bool) : + List (FieldKey × CTy) → List (FieldKey × CTy) → List (FieldKey × CTy) + | [], _ => [] + | (k, v) :: rest, m2 => + match h : m2.lookup k with + | some w => (k, merge pol v w) :: interMap pol rest m2 + | none => interMap pol rest m2 +termination_by a b => sizeOf a + sizeOf b +decreasing_by + · have := lookup_sizeOf h + simp + omega + · simp + omega + · simp + omega + +/-- The `m1`-side of the key-uniting merge (records at negative polarity, +variants at positive — `merge_keyed` with `intersect_keys = false`): every key +of `m1`, merged with `m2`'s payload when present. The full union appends +`m2`'s leftover keys: `unionMapGo pol m1 m2 ++ m2.filter (·.1 ∉ keys m1)` — +see [`unionMap`]. -/ +def unionMapGo (pol : Bool) : + List (FieldKey × CTy) → List (FieldKey × CTy) → List (FieldKey × CTy) + | [], _ => [] + | (k, v) :: rest, m2 => + (k, + match h : m2.lookup k with + | some w => merge pol v w + | none => v) + :: unionMapGo pol rest m2 +termination_by a b => sizeOf a + sizeOf b +decreasing_by + · have := lookup_sizeOf h + simp + omega + · simp + omega + +/-- The contravariant domain meet: defined when each side has **one distinct +alternative**, and undefined otherwise — `compact.rs` flags the latter at +coalesce. Only ever used at a negative position, where `merge`'s polarity flip +makes the inner merge positive. + +"One distinct alternative" rather than "one alternative" because `DomainSet` +deduplicates, so on the lists it produces the two conditions agree — and only the +first is invisible to `domsEqv`, which cannot tell `[x]` from `[x, x]`. Testing +the length instead would make the merge fail to be a congruence. -/ +def meetDoms : List CTy → List CTy → Option (List CTy) + | x :: xs, y :: ys => + if subDoms [x] xs && subDoms [y] ys then some [merge true x y] else none + | _, _ => none +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp; omega) + +/-- Mirror of `union_domains`: the alternatives of both sides, deduplicated by +`eqv` — the same equality `contains` uses. Never a meet: a `Data` domain *is* the +data, and whether the slot reads as data is not known here. -/ +def unionDoms (a b : List CTy) : List CTy := + a ++ b.filter (fun d => !anyEqv d a) + +/-- Mirror of `CompactFun::merge` (see module docs for the `Option CTy` +domain encoding and the dropped binder/diagnostic payloads). + +The kinds join in the [`KindM`] semilattice, the same operation at both +polarities. The domains are then combined by *polarity alone*: a positive join +accumulates the alternatives and a negative merge takes the contravariant meet. +Neither reads the kind, which is what makes the operation associative — the kind +a slot ends at is not known until the last bound has merged, so a domain rule +selected from it would let association decide the outcome. `compact.rs` defers +the kind's own rule to `coalesce_compact_go`. + +The dedup gate on the accumulated alternatives is `eqv` — the same equality +`union_domains`' `contains` uses — which is what keeps the whole algebra +quotient-compatible. -/ +def mergeFun (pol : Bool) : + KindM × List CTy × CTy → KindM × List CTy × CTy → KindM × List CTy × CTy + | (k1, d1, c1), (k2, d2, c2) => + let cod := merge pol c1 c2 + let k := joinKind k1 k2 + if k == .conflict then + -- A conflicted slot's payload is diagnostic; coalesce reports rather than + -- reads it, so the model drops it. + (.conflict, [], cod) + else if pol then + -- The alternatives accumulate. What several of them *mean* is the resolved + -- kind's question, answered at coalesce. + (k, unionDoms d1 d2, cod) + else + -- Negative: the contravariant meet. + match meetDoms d1 d2 with + | some ds => (k, ds, cod) + | none => (.conflict, [], cod) +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp; omega) + + + +end + +/-- Keyed merge, uniting keys: keys of either side, payloads merged where both +are present. (Defined outside the mutual block — it makes no recursive call of +its own, and the well-founded measure cannot see through a same-size wrapper; +`merge` inlines this same expression.) -/ +def unionMap (pol : Bool) (m1 m2 : List (FieldKey × CTy)) : + List (FieldKey × CTy) := + unionMapGo pol m1 m2 ++ m2.filter (fun kw => (m1.lookup kw.1).isNone) + +/-! ## Pointwise readings + +Everything below reasons about maps through `lookup` — the merged maps are +characterized pointwise (`interMap_lookup`, `unionMap_lookup`), and `subKeys` +unfolds to a per-key statement (`subKeys_iff`), so the set-level proofs never +touch the association-list representation again. -/ + +/-- A `lookup` hit means the key occurs in the key list. -/ +theorem mem_keys_of_lookup {m : List (FieldKey × CTy)} {k : FieldKey} {v : CTy} + (h : m.lookup k = some v) : k ∈ m.map Prod.fst := by + induction m with + | nil => simp [List.lookup] at h + | cons hd tl ih => + rw [List.lookup] at h + split at h + · rename_i heq + simp at heq + simp [heq] + · simp only [List.map_cons, List.mem_cons] + exact Or.inr (ih h) + +/-- A key in the key list has a `lookup` hit. -/ +theorem lookup_of_mem_keys {m : List (FieldKey × CTy)} {k : FieldKey} + (h : k ∈ m.map Prod.fst) : (m.lookup k).isSome := by + induction m with + | nil => simp at h + | cons hd tl ih => + rw [List.lookup] + split + · simp + · rename_i hne + simp at hne + simp only [List.map_cons, List.mem_cons] at h + rcases h with h | h + · exact absurd h hne + · exact ih h + +/-- `subKeys`, read per key. -/ +theorem subKeys_iff {m1 m2 : List (FieldKey × CTy)} {ks : List FieldKey} : + subKeys m1 m2 ks = true ↔ + ∀ k ∈ ks, ∃ v w, m1.lookup k = some v ∧ m2.lookup k = some w ∧ eqv v w = true := by + induction ks with + | nil => simp [subKeys] + | cons k ks ih => + rw [subKeys, Bool.and_eq_true, ih] + constructor + · intro ⟨hhead, htail⟩ k' hk' + rcases List.mem_cons.mp hk' with h | h + · subst h + split at hhead + · rename_i v w h1 h2 + exact ⟨v, w, h1, h2, hhead⟩ + · exact absurd hhead (by simp) + · exact htail k' h + · intro h + obtain ⟨v, w, h1, h2, hvw⟩ := h k (by simp) + refine ⟨?_, fun k' hk' => h k' (by simp [hk'])⟩ + split + · rename_i v' w' h1' h2' + rw [h1] at h1' + rw [h2] at h2' + cases h1' + cases h2' + exact hvw + · rename_i hno + exact (hno v w (by rw [h1]) (by rw [h2])).elim + +/-! ## `eqv` is an equivalence relation -/ + +theorem eqv_refl : (t : CTy) → eqv t t = true + | .mk a r v f c => by + have hmap : ∀ (m : List (FieldKey × CTy)), sizeOf m < sizeOf (CTy.mk a r v f c) → + subKeys m m (m.map Prod.fst) = true := by + intro m hm + rw [subKeys_iff] + intro k hk + obtain ⟨w, hw⟩ := Option.isSome_iff_exists.mp (lookup_of_mem_keys hk) + have hsz : sizeOf w < sizeOf (CTy.mk a r v f c) := + Nat.lt_trans (lookup_sizeOf hw) hm + exact ⟨w, w, hw, hw, eqv_refl w⟩ + rw [eqv.eq_def] + simp only [Bool.and_eq_true] + refine ⟨⟨⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩, ?_⟩, ?_⟩ + · simp [List.all_eq_true] + · simp [List.all_eq_true] + · rcases r with _ | m + · rfl + · have hm : sizeOf m < sizeOf (CTy.mk a (some m) v f c) := by + simp + omega + simp [hmap m hm] + · rcases v with _ | m + · rfl + · have hm : sizeOf m < sizeOf (CTy.mk a r (some m) f c) := by + simp + omega + simp [hmap m hm] + · rcases f with _ | ⟨k, d, cod⟩ + · rfl + · have hszc : sizeOf cod < sizeOf (CTy.mk a r v (some (k, d, cod)) c) := by + simp + omega + have hd : subDoms d d = true := by + refine subDoms_iff.mpr fun x hx => ⟨x, hx, ?_⟩ + have hszx : sizeOf x < sizeOf (CTy.mk a r v (some (k, d, cod)) c) := by + have := List.sizeOf_lt_of_mem hx + simp + omega + exact eqv_refl x + simp [hd, eqv_refl cod] + · exact refinementsEqv_refl c +termination_by t => sizeOf t +decreasing_by all_goals omega + +/-- Unfolded, pointwise reading of the map clause both `eqv` map slots use. -/ +theorem mapClause_iff {m1 m2 : List (FieldKey × CTy)} : + (subKeys m1 m2 (m1.map Prod.fst) && subKeys m2 m1 (m2.map Prod.fst)) = true ↔ + (∀ k, (m1.lookup k).isSome ↔ (m2.lookup k).isSome) ∧ + (∀ k v w, m1.lookup k = some v → m2.lookup k = some w → eqv v w = true) + ∧ ∀ k v w, m1.lookup k = some v → m2.lookup k = some w → eqv w v = true := by + rw [Bool.and_eq_true, subKeys_iff, subKeys_iff] + constructor + · intro ⟨h12, h21⟩ + refine ⟨fun k => ?_, fun k v w hv hw => ?_, fun k v w hv hw => ?_⟩ + · constructor + · intro h1 + obtain ⟨v, hv⟩ := Option.isSome_iff_exists.mp h1 + obtain ⟨_, w, _, hw, _⟩ := h12 k (mem_keys_of_lookup hv) + simp [hw] + · intro h2 + obtain ⟨w, hw⟩ := Option.isSome_iff_exists.mp h2 + obtain ⟨_, v, _, hv, _⟩ := h21 k (mem_keys_of_lookup hw) + simp [hv] + · obtain ⟨v', w', hv', hw', hvw⟩ := h12 k (mem_keys_of_lookup hv) + rw [hv] at hv' + rw [hw] at hw' + cases hv' + cases hw' + exact hvw + · obtain ⟨w', v', hw', hv', hwv⟩ := h21 k (mem_keys_of_lookup hw) + rw [hv] at hv' + rw [hw] at hw' + cases hv' + cases hw' + exact hwv + · intro ⟨hdom, hfwd, hbwd⟩ + constructor + · intro k hk + obtain ⟨v, hv⟩ := Option.isSome_iff_exists.mp (lookup_of_mem_keys hk) + obtain ⟨w, hw⟩ := Option.isSome_iff_exists.mp ((hdom k).mp (by simp [hv])) + exact ⟨v, w, hv, hw, hfwd k v w hv hw⟩ + · intro k hk + obtain ⟨w, hw⟩ := Option.isSome_iff_exists.mp (lookup_of_mem_keys hk) + obtain ⟨v, hv⟩ := Option.isSome_iff_exists.mp ((hdom k).mpr (by simp [hw])) + exact ⟨w, v, hw, hv, hbwd k v w hv hw⟩ + +theorem eqv_symm : (a b : CTy) → eqv a b = true → eqv b a = true + | .mk a1 r1 v1 f1 c1, .mk a2 r2 v2 f2 c2 => by + intro h + rw [eqv.eq_def] at h + simp only [Bool.and_eq_true] at h + obtain ⟨⟨⟨⟨⟨h1, h2⟩, hr⟩, hv⟩, hf⟩, hc⟩ := h + rw [eqv.eq_def] + simp only [Bool.and_eq_true] + refine ⟨⟨⟨⟨⟨h2, h1⟩, ?_⟩, ?_⟩, ?_⟩, refinementsEqv_symm hc⟩ + · rcases r1 with _ | m1 <;> rcases r2 with _ | m2 <;> simp_all + · rcases v1 with _ | m1 <;> rcases v2 with _ | m2 <;> simp_all + · rcases f1 with _ | ⟨k1, d1, cod1⟩ <;> rcases f2 with _ | ⟨k2, d2, cod2⟩ + · rfl + · simp at hf + · simp at hf + · simp only [Bool.and_eq_true] at hf + obtain ⟨⟨hk, hd⟩, hcod⟩ := hf + simp only [Bool.and_eq_true] + have hszc : sizeOf cod2 + sizeOf cod1 < + sizeOf (CTy.mk a2 r2 v2 (some (k2, d2, cod2)) c2) + + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) := by + simp + omega + refine ⟨⟨?_, ?_⟩, eqv_symm cod1 cod2 hcod⟩ + · simp at hk + simp [hk] + · exact domsEqv_iff_and.mp (domsEqv_symm (domsEqv_iff_and.mpr hd)) +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals omega + +theorem eqv_trans : (a b c : CTy) → eqv a b = true → eqv b c = true → eqv a c = true + | .mk a1 r1 v1 f1 c1, .mk a2 r2 v2 f2 c2, .mk a3 r3 v3 f3 c3 => by + intro hab hbc + rw [eqv.eq_def] at hab hbc + simp only [Bool.and_eq_true] at hab hbc + obtain ⟨⟨⟨⟨⟨hab1, hab2⟩, habr⟩, habv⟩, habf⟩, habc⟩ := hab + obtain ⟨⟨⟨⟨⟨hbc1, hbc2⟩, hbcr⟩, hbcv⟩, hbcf⟩, hbcc⟩ := hbc + rw [eqv.eq_def] + simp only [Bool.and_eq_true] + have hsub : ∀ {α : Type} [inst : DecidableEq α] (x y z : List α), + (x.all (y.contains ·)) = true → (y.all (z.contains ·)) = true → + (x.all (z.contains ·)) = true := by + intro α _ x y z hxy hyz + simp only [List.all_eq_true] at * + intro p hp + have h1 := hxy p hp + simp only [List.contains_iff_mem] at h1 ⊢ + have h2 := hyz _ h1 + simpa using h2 + have hmapTrans : ∀ (m1 m2 m3 : List (FieldKey × CTy)), + sizeOf m1 < sizeOf (CTy.mk a1 r1 v1 f1 c1) → + sizeOf m3 < sizeOf (CTy.mk a3 r3 v3 f3 c3) → + (subKeys m1 m2 (m1.map Prod.fst) && subKeys m2 m1 (m2.map Prod.fst)) = true → + (subKeys m2 m3 (m2.map Prod.fst) && subKeys m3 m2 (m3.map Prod.fst)) = true → + (subKeys m1 m3 (m1.map Prod.fst) && subKeys m3 m1 (m3.map Prod.fst)) = true := by + intro m1 m2 m3 hs1 hs3 h12 h23 + rw [mapClause_iff] at h12 h23 ⊢ + obtain ⟨hdom12, hfwd12, hbwd12⟩ := h12 + obtain ⟨hdom23, hfwd23, hbwd23⟩ := h23 + refine ⟨fun k => (hdom12 k).trans (hdom23 k), fun k x z hx hz => ?_, fun k x z hx hz => ?_⟩ + · obtain ⟨y, hy⟩ := Option.isSome_iff_exists.mp ((hdom12 k).mp (by simp [hx])) + have hxy := hfwd12 k x y hx hy + have hyz := hfwd23 k y z hy hz + have hszx : sizeOf x < sizeOf (CTy.mk a1 r1 v1 f1 c1) := + Nat.lt_trans (lookup_sizeOf hx) hs1 + have hszz : sizeOf z < sizeOf (CTy.mk a3 r3 v3 f3 c3) := + Nat.lt_trans (lookup_sizeOf hz) hs3 + exact eqv_trans x y z hxy hyz + · obtain ⟨y, hy⟩ := Option.isSome_iff_exists.mp ((hdom12 k).mp (by simp [hx])) + have hzy := hbwd23 k y z hy hz + have hyx := hbwd12 k x y hx hy + have hszx : sizeOf x < sizeOf (CTy.mk a1 r1 v1 f1 c1) := + Nat.lt_trans (lookup_sizeOf hx) hs1 + have hszz : sizeOf z < sizeOf (CTy.mk a3 r3 v3 f3 c3) := + Nat.lt_trans (lookup_sizeOf hz) hs3 + exact eqv_trans z y x hzy hyx + refine ⟨⟨⟨⟨⟨hsub a1 a2 a3 hab1 hbc1, hsub a3 a2 a1 hbc2 hab2⟩, ?_⟩, ?_⟩, ?_⟩, + refinementsEqv_trans habc hbcc⟩ + · rcases r1 with _ | m1 <;> rcases r2 with _ | m2 <;> rcases r3 with _ | m3 <;> + first + | rfl + | (simp at habr; done) + | (simp at hbcr; done) + | (exact hmapTrans m1 m2 m3 (by simp; omega) (by simp; omega) habr hbcr) + · rcases v1 with _ | m1 <;> rcases v2 with _ | m2 <;> rcases v3 with _ | m3 <;> + first + | rfl + | (simp at habv; done) + | (simp at hbcv; done) + | (exact hmapTrans m1 m2 m3 (by simp; omega) (by simp; omega) habv hbcv) + · rcases f1 with _ | ⟨k1, d1, cod1⟩ <;> rcases f2 with _ | ⟨k2, d2, cod2⟩ <;> + rcases f3 with _ | ⟨k3, d3, cod3⟩ <;> + first + | rfl + | (simp at habf; done) + | (simp at hbcf; done) + | skip + simp only [Bool.and_eq_true] at habf hbcf + obtain ⟨⟨habk, habd⟩, habcod⟩ := habf + obtain ⟨⟨hbck, hbcd⟩, hbccod⟩ := hbcf + simp only [Bool.and_eq_true] + have hszc : sizeOf cod1 + sizeOf cod3 < + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) + + sizeOf (CTy.mk a3 r3 v3 (some (k3, d3, cod3)) c3) := by + simp + omega + refine ⟨⟨?_, ?_⟩, eqv_trans cod1 cod2 cod3 habcod hbccod⟩ + · simp at habk hbck + simp [habk, hbck] + · obtain ⟨hab1, hab2⟩ := domsEqv_iff.mp (domsEqv_iff_and.mpr habd) + obtain ⟨hbc1, hbc2⟩ := domsEqv_iff.mp (domsEqv_iff_and.mpr hbcd) + refine domsEqv_iff_and.mp (domsEqv_iff.mpr ⟨fun x hx => ?_, fun z hz => ?_⟩) + · obtain ⟨y, hy, hxy⟩ := hab1 x hx + obtain ⟨w, hw, hyw⟩ := hbc1 y hy + have hszd : sizeOf x + sizeOf w < + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) + + sizeOf (CTy.mk a3 r3 v3 (some (k3, d3, cod3)) c3) := by + have h1 := List.sizeOf_lt_of_mem hx + have h2 := List.sizeOf_lt_of_mem hw + simp + omega + exact ⟨w, hw, eqv_trans x y w hxy hyw⟩ + · obtain ⟨y, hy, hzy⟩ := hbc2 z hz + obtain ⟨x, hx, hyx⟩ := hab2 y hy + have hszd : sizeOf z + sizeOf x < + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) + + sizeOf (CTy.mk a3 r3 v3 (some (k3, d3, cod3)) c3) := by + have h1 := List.sizeOf_lt_of_mem hx + have h2 := List.sizeOf_lt_of_mem hz + simp + omega + exact ⟨x, hx, eqv_trans z y x hzy hyx⟩ +termination_by a _ c => sizeOf a + sizeOf c +decreasing_by all_goals omega + +/-! ## The domain alternatives: the algebra -/ + +/-! ### The negative arm, characterized + +`meetDoms` is defined on a singleton pair and nowhere else, so every proof about +a negative merge splits on that once, here, rather than over nine list shapes. -/ + +/-- One distinct alternative: non-empty, with everything `eqv` to a member. The +property `meetDoms` is defined on, and `domsEqv`-invariant (`oneDistinct_congr`). -/ +def OneDistinct (l : List CTy) : Prop := ∃ x, x ∈ l ∧ ∀ z ∈ l, eqv z x = true + +/-- `meetDoms`, read off its definition: the payload is built from the two lists' +*heads*, so the swapped call and a congruent call name the same representatives. -/ +theorem meetDoms_eq_some {a b ds : List CTy} (h : meetDoms a b = some ds) : + ∃ x xs y ys, a = x :: xs ∧ b = y :: ys + ∧ (subDoms [x] xs && subDoms [y] ys) = true ∧ ds = [merge true x y] := by + rcases a with _ | ⟨x, xs⟩ + · exact absurd h (by simp [meetDoms]) + · rcases b with _ | ⟨y, ys⟩ + · exact absurd h (by simp [meetDoms]) + · rw [meetDoms] at h + split at h + · rename_i hgate + cases h + exact ⟨x, xs, y, ys, rfl, rfl, hgate, rfl⟩ + · exact absurd h (by simp) + +theorem meetDoms_of_gate {x y : CTy} {xs ys : List CTy} + (h : (subDoms [x] xs && subDoms [y] ys) = true) : + meetDoms (x :: xs) (y :: ys) = some [merge true x y] := by + rw [meetDoms, if_pos h] + +/-- A single alternative on each side: what `wf` gives an input bound. -/ +theorem meetDoms_single (x y : CTy) : meetDoms [x] [y] = some [merge true x y] := + meetDoms_of_gate (by simp [subDoms]) + +/-- Under the gate, the head is a representative of the whole list. -/ +theorem all_eqv_head {x : CTy} {xs : List CTy} (h : subDoms [x] xs = true) : + ∀ z ∈ x :: xs, eqv z x = true := by + intro z hz + rcases List.mem_cons.mp hz with h' | h' + · exact h' ▸ eqv_refl x + · obtain ⟨w, hw, hzw⟩ := (subDoms_iff.mp h) z h' + exact (List.mem_singleton.mp hw) ▸ hzw + +theorem oneDistinct_cons {x : CTy} {xs : List CTy} (h : subDoms [x] xs = true) : + OneDistinct (x :: xs) := ⟨x, by simp, all_eqv_head h⟩ + +theorem gate_of_oneDistinct {x : CTy} {xs : List CTy} (h : OneDistinct (x :: xs)) : + subDoms [x] xs = true := by + obtain ⟨u, _, hall⟩ := h + refine subDoms_iff.mpr fun z hz => ⟨x, by simp, ?_⟩ + exact eqv_trans _ _ _ (hall z (by simp [hz])) (eqv_symm _ _ (hall x (by simp))) + +theorem oneDistinct_of_meetDoms {a b ds : List CTy} (h : meetDoms a b = some ds) : + OneDistinct a ∧ OneDistinct b := by + obtain ⟨x, xs, y, ys, ha, hb, hgate, _⟩ := meetDoms_eq_some h + rw [Bool.and_eq_true] at hgate + exact ⟨ha ▸ oneDistinct_cons hgate.1, hb ▸ oneDistinct_cons hgate.2⟩ + +theorem meetDoms_isSome_of {a b : List CTy} (ha : OneDistinct a) (hb : OneDistinct b) : + ∃ ds, meetDoms a b = some ds := by + rcases a with _ | ⟨x, xs⟩ + · exact absurd ha (by simp [OneDistinct]) + · rcases b with _ | ⟨y, ys⟩ + · exact absurd hb (by simp [OneDistinct]) + · exact ⟨_, meetDoms_of_gate (by + rw [Bool.and_eq_true] + exact ⟨gate_of_oneDistinct ha, gate_of_oneDistinct hb⟩)⟩ + +/-- The property is `domsEqv`-invariant, which is what keeps the negative arm a +congruence: `domsEqv` cannot tell `[x]` from `[x, x]`, and neither can this. -/ +theorem oneDistinct_congr {a a' : List CTy} (h : domsEqv a a' = true) (ha : OneDistinct a) : + OneDistinct a' := by + obtain ⟨x, hx, hax⟩ := ha + obtain ⟨h1, h2⟩ := domsEqv_iff.mp h + obtain ⟨x', hx', hxx'⟩ := h1 x hx + refine ⟨x', hx', fun z hz => ?_⟩ + obtain ⟨w, hw, hzw⟩ := h2 z hz + exact eqv_trans _ _ _ hzw (eqv_trans _ _ _ (hax w hw) hxx') + +theorem meetDoms_none_of_left {a b : List CTy} (h : ¬OneDistinct a) : meetDoms a b = none := by + rcases hm : meetDoms a b with _ | ds + · rfl + · exact absurd (oneDistinct_of_meetDoms hm).1 h + +theorem meetDoms_none_of_right {a b : List CTy} (h : ¬OneDistinct b) : meetDoms a b = none := by + rcases hm : meetDoms a b with _ | ds + · rfl + · exact absurd (oneDistinct_of_meetDoms hm).2 h + +/-- A singleton always has one distinct alternative — the shape the inner meet +leaves for the outer one. -/ +theorem oneDistinct_single (x : CTy) : OneDistinct [x] := ⟨x, by simp, by simp [eqv_refl]⟩ + +theorem meetDoms_none_comm {a b : List CTy} (h : meetDoms a b = none) : + meetDoms b a = none := by + rcases hm : meetDoms b a with _ | ds + · rfl + · obtain ⟨hb, ha⟩ := oneDistinct_of_meetDoms hm + obtain ⟨ds', hds'⟩ := meetDoms_isSome_of ha hb + rw [hds'] at h + exact absurd h (by simp) + +theorem domsEqv_singleton {x y : CTy} (h : eqv x y = true) : domsEqv [x] [y] = true := + domsEqv_iff.mpr + ⟨fun _ hx => ⟨y, by simp, by simpa [List.mem_singleton.mp hx] using h⟩, + fun _ hy => ⟨x, by simp, by simpa [List.mem_singleton.mp hy] using eqv_symm _ _ h⟩⟩ + +theorem domsEqv_refl (a : List CTy) : domsEqv a a = true := + domsEqv_iff.mpr ⟨fun x hx => ⟨x, hx, eqv_refl x⟩, fun y hy => ⟨y, hy, eqv_refl y⟩⟩ + +theorem domsEqv_trans {a b c : List CTy} (hab : domsEqv a b = true) + (hbc : domsEqv b c = true) : domsEqv a c = true := by + obtain ⟨hab1, hab2⟩ := domsEqv_iff.mp hab + obtain ⟨hbc1, hbc2⟩ := domsEqv_iff.mp hbc + refine domsEqv_iff.mpr ⟨fun x hx => ?_, fun z hz => ?_⟩ + · obtain ⟨y, hy, hxy⟩ := hab1 x hx + obtain ⟨w, hw, hyw⟩ := hbc1 y hy + exact ⟨w, hw, eqv_trans _ _ _ hxy hyw⟩ + · obtain ⟨y, hy, hzy⟩ := hbc2 z hz + obtain ⟨x, hx, hyx⟩ := hab2 y hy + exact ⟨x, hx, eqv_trans _ _ _ hzy hyx⟩ + +/-- The union holds nothing new. -/ +theorem mem_unionDoms {a b : List CTy} {x : CTy} (h : x ∈ unionDoms a b) : + x ∈ a ∨ x ∈ b := by + rcases List.mem_append.mp h with h | h + · exact Or.inl h + · exact Or.inr (List.mem_filter.mp h).1 + +/-- …and loses nothing: the dedup only drops an alternative that already has a +partner. -/ +theorem unionDoms_covers {a b : List CTy} {x : CTy} (h : x ∈ a ∨ x ∈ b) : + ∃ y ∈ unionDoms a b, eqv x y = true := by + rcases h with h | h + · exact ⟨x, List.mem_append.mpr (Or.inl h), eqv_refl x⟩ + · rcases hk : anyEqv x a with _ | _ + · exact ⟨x, List.mem_append.mpr (Or.inr (List.mem_filter.mpr ⟨h, by simp [hk]⟩)), + eqv_refl x⟩ + · obtain ⟨y, hy, hxy⟩ := anyEqv_iff.mp hk + exact ⟨y, List.mem_append.mpr (Or.inl hy), hxy⟩ + +/-- Cover a member of any of three lists, through either nesting. -/ +theorem unionDoms_coversR {a b c : List CTy} {x : CTy} (h : x ∈ a ∨ x ∈ b ∨ x ∈ c) : + ∃ y ∈ unionDoms a (unionDoms b c), eqv x y = true := by + rcases h with h | h + · exact unionDoms_covers (Or.inl h) + · obtain ⟨z, hz, hxz⟩ := unionDoms_covers (a := b) (b := c) h + obtain ⟨w, hw, hzw⟩ := unionDoms_covers (a := a) (b := unionDoms b c) (Or.inr hz) + exact ⟨w, hw, eqv_trans _ _ _ hxz hzw⟩ + +theorem unionDoms_coversL {a b c : List CTy} {x : CTy} (h : x ∈ a ∨ x ∈ b ∨ x ∈ c) : + ∃ y ∈ unionDoms (unionDoms a b) c, eqv x y = true := by + rcases h with h | h + · obtain ⟨z, hz, hxz⟩ := unionDoms_covers (a := a) (b := b) (Or.inl h) + obtain ⟨w, hw, hzw⟩ := unionDoms_covers (a := unionDoms a b) (b := c) (Or.inl hz) + exact ⟨w, hw, eqv_trans _ _ _ hxz hzw⟩ + · rcases h with h | h + · obtain ⟨z, hz, hxz⟩ := unionDoms_covers (a := a) (b := b) (Or.inr h) + obtain ⟨w, hw, hzw⟩ := unionDoms_covers (a := unionDoms a b) (b := c) (Or.inl hz) + exact ⟨w, hw, eqv_trans _ _ _ hxz hzw⟩ + · exact unionDoms_covers (Or.inr h) + +theorem mem_unionDomsL {a b c : List CTy} {x : CTy} (h : x ∈ unionDoms (unionDoms a b) c) : + x ∈ a ∨ x ∈ b ∨ x ∈ c := by + rcases mem_unionDoms h with h | h + · exact (mem_unionDoms h).imp id Or.inl + · exact Or.inr (Or.inr h) + +theorem mem_unionDomsR {a b c : List CTy} {x : CTy} (h : x ∈ unionDoms a (unionDoms b c)) : + x ∈ a ∨ x ∈ b ∨ x ∈ c := by + rcases mem_unionDoms h with h | h + · exact Or.inl h + · exact Or.inr (mem_unionDoms h) + +theorem unionDoms_comm (a b : List CTy) : domsEqv (unionDoms a b) (unionDoms b a) = true := + domsEqv_iff.mpr + ⟨fun _ hx => unionDoms_covers (mem_unionDoms hx).symm, + fun _ hy => unionDoms_covers (mem_unionDoms hy).symm⟩ + +theorem unionDoms_idem (a : List CTy) : domsEqv (unionDoms a a) a = true := + domsEqv_iff.mpr + ⟨fun x hx => ⟨x, (mem_unionDoms hx).elim id id, eqv_refl x⟩, + fun _ hy => unionDoms_covers (Or.inl hy)⟩ + +theorem unionDoms_assoc (a b c : List CTy) : + domsEqv (unionDoms (unionDoms a b) c) (unionDoms a (unionDoms b c)) = true := + domsEqv_iff.mpr + ⟨fun _ hx => unionDoms_coversR (mem_unionDomsL hx), + fun _ hy => unionDoms_coversL (mem_unionDomsR hy)⟩ + +theorem unionDoms_congr_left {a a' : List CTy} (b : List CTy) (h : domsEqv a a' = true) : + domsEqv (unionDoms a b) (unionDoms a' b) = true := by + obtain ⟨h1, h2⟩ := domsEqv_iff.mp h + refine domsEqv_iff.mpr ⟨fun x hx => ?_, fun y hy => ?_⟩ + · rcases mem_unionDoms hx with hm | hm + · obtain ⟨x', hx', hxx'⟩ := h1 x hm + obtain ⟨z, hz, hx'z⟩ := unionDoms_covers (a := a') (b := b) (Or.inl hx') + exact ⟨z, hz, eqv_trans _ _ _ hxx' hx'z⟩ + · exact unionDoms_covers (Or.inr hm) + · rcases mem_unionDoms hy with hm | hm + · obtain ⟨y', hy', hyy'⟩ := h2 y hm + obtain ⟨z, hz, hy'z⟩ := unionDoms_covers (a := a) (b := b) (Or.inl hy') + exact ⟨z, hz, eqv_trans _ _ _ hyy' hy'z⟩ + · exact unionDoms_covers (Or.inr hm) + + +/-! ## Pointwise readings of the merged maps -/ + +/-- `interMap`, read through `lookup`: defined exactly when both sides have +the key, payload the merge of the two firsts. -/ +theorem interMap_lookup {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {k : FieldKey} : + (interMap pol m1 m2).lookup k = + match m1.lookup k, m2.lookup k with + | some v, some w => some (merge pol v w) + | _, _ => none := by + induction m1 with + | nil => simp [interMap, List.lookup] + | cons hd tl ih => + obtain ⟨k', v'⟩ := hd + rw [interMap] + rcases h2 : m2.lookup k' with _ | w' + · rcases hk : k == k' with _ | _ + · rw [List.lookup_cons] + simp only [hk, ih] + · have : k = k' := by simpa using hk + subst this + rw [ih, List.lookup_cons] + simp [h2] + · rcases hk : k == k' with _ | _ + · rw [List.lookup_cons, List.lookup_cons] + simp only [hk, ih] + · have : k = k' := by simpa using hk + subst this + rw [List.lookup_cons, List.lookup_cons] + simp [h2] + +/-- `unionMapGo`, read through `lookup`: defined exactly on `m1`'s keys, +payload merged with `m2`'s when present. -/ +theorem unionMapGo_lookup {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {k : FieldKey} : + (unionMapGo pol m1 m2).lookup k = + match m1.lookup k, m2.lookup k with + | some v, some w => some (merge pol v w) + | some v, none => some v + | none, _ => none := by + induction m1 with + | nil => simp [unionMapGo, List.lookup] + | cons hd tl ih => + obtain ⟨k', v'⟩ := hd + rw [unionMapGo, List.lookup_cons, List.lookup_cons] + rcases hk : k == k' with _ | _ + · simp only [hk, ih] + · have : k = k' := by simpa using hk + subst this + rcases h2 : m2.lookup k with _ | w' <;> simp [h2] + +/-- Looking up in the `m2` leftovers (keys absent from `m1`): the filter +predicate depends only on the key, so the first `k`-entry survives exactly +when `m1` lacks `k`. -/ +theorem lookup_filter_leftover {m1 m2 : List (FieldKey × CTy)} {k : FieldKey} : + (m2.filter (fun kw => (m1.lookup kw.1).isNone)).lookup k = + if (m1.lookup k).isNone then m2.lookup k else none := by + induction m2 with + | nil => simp [List.lookup] + | cons hd tl ih => + obtain ⟨k', w'⟩ := hd + rw [List.filter_cons] + rcases h1 : (m1.lookup k').isNone with _ | _ + · simp only [h1, Bool.false_eq_true, if_false, ih] + rcases hk : k == k' with _ | _ + · rw [List.lookup_cons] + simp [hk] + · have : k = k' := by simpa using hk + subst this + rw [List.lookup_cons] + simp [h1] + · simp only [h1, if_true] + rw [List.lookup_cons, List.lookup_cons] + rcases hk : k == k' with _ | _ + · simp only [hk, ih] + · have : k = k' := by simpa using hk + subst this + simp [h1, ih] + +/-- `unionMap`, read through `lookup`. -/ +theorem unionMap_lookup {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {k : FieldKey} : + (unionMap pol m1 m2).lookup k = + match m1.lookup k, m2.lookup k with + | some v, some w => some (merge pol v w) + | some v, none => some v + | none, some w => some w + | none, none => none := by + rw [unionMap, List.lookup_append, unionMapGo_lookup, lookup_filter_leftover] + rcases h1 : m1.lookup k with _ | v <;> rcases h2 : m2.lookup k with _ | w <;> simp [h1, h2] + +/-! ## The merge algebra: commutativity -/ + +/-- The dedup gate is symmetric as a *Bool*: `eqv x y = eqv y x`. -/ +theorem eqv_comm_bool (x y : CTy) : eqv x y = eqv y x := by + rcases h : eqv y x with _ | _ + · rcases h' : eqv x y with _ | _ + · rfl + · rw [eqv_symm x y h'] at h + exact h + · exact eqv_symm y x h + +/-- `subKeys` is reflexive on any map (shadowed duplicates are unobservable). -/ +theorem subKeys_self (m : List (FieldKey × CTy)) : subKeys m m (m.map Prod.fst) = true := by + rw [subKeys_iff] + intro k hk + obtain ⟨v, hv⟩ := Option.isSome_iff_exists.mp (lookup_of_mem_keys hk) + exact ⟨v, v, hv, hv, eqv_refl v⟩ + +/-- The function-slot equivalence, as a `Prop` (the shape `eqv`'s fn clause +checks, lifted off the Bool so case analyses stay readable). -/ +def FunEqv : KindM × List CTy × CTy → KindM × List CTy × CTy → Prop + | (k1, d1, c1), (k2, d2, c2) => + k1 = k2 + ∧ domsEqv d1 d2 = true + ∧ eqv c1 c2 = true + +/-- `FunEqv` is exactly `eqv`'s fn clause. -/ +theorem funClause_of_funEqv {s1 s2 : KindM × List CTy × CTy} (h : FunEqv s1 s2) : + (s1.1 == s2.1 + && domsEqv s1.2.1 s2.2.1 + && eqv s1.2.2 s2.2.2) = true := by + obtain ⟨k1, d1, c1⟩ := s1 + obtain ⟨k2, d2, c2⟩ := s2 + obtain ⟨hk, hd, hc⟩ := h + subst hk + simp only [Bool.and_eq_true] + refine ⟨⟨by simp, ?_⟩, hc⟩ + rcases d1 with _ | x <;> rcases d2 with _ | y <;> simp_all + +mutual + +theorem merge_comm (pol : Bool) : (a b : CTy) → eqv (merge pol a b) (merge pol b a) = true + | .mk a1 r1 v1 f1 c1, .mk a2 r2 v2 f2 c2 => by + -- Pointwise commutativity of the two keyed merges, packaged with the size + -- bounds the recursive calls need. + have hinter : ∀ (p : Bool) (m1 m2 : List (FieldKey × CTy)), + (∀ x y k, m1.lookup k = some x → m2.lookup k = some y → + eqv (merge p x y) (merge p y x) = true) → + (subKeys (interMap p m1 m2) (interMap p m2 m1) + ((interMap p m1 m2).map Prod.fst) && + subKeys (interMap p m2 m1) (interMap p m1 m2) + ((interMap p m2 m1).map Prod.fst)) = true := by + intro p m1 m2 hcomm + rw [mapClause_iff] + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [interMap_lookup, interMap_lookup] + rcases m1.lookup k with _ | v <;> rcases m2.lookup k with _ | w <;> simp + · rw [interMap_lookup] at hx hy + rcases h1 : m1.lookup k with _ | v <;> rcases h2 : m2.lookup k with _ | w <;> + rw [h1, h2] at hx hy <;> dsimp only at hx hy + · exact absurd hx (by simp) + · exact absurd hx (by simp) + · exact absurd hx (by simp) + · cases hx + cases hy + exact hcomm v w k h1 h2 + · rw [interMap_lookup] at hx hy + rcases h1 : m1.lookup k with _ | v <;> rcases h2 : m2.lookup k with _ | w <;> + rw [h1, h2] at hx hy <;> dsimp only at hx hy + · exact absurd hx (by simp) + · exact absurd hx (by simp) + · exact absurd hx (by simp) + · cases hx + cases hy + exact eqv_symm _ _ (hcomm v w k h1 h2) + have hunion : ∀ (p : Bool) (m1 m2 : List (FieldKey × CTy)), + (∀ x y k, m1.lookup k = some x → m2.lookup k = some y → + eqv (merge p x y) (merge p y x) = true) → + (subKeys (unionMap p m1 m2) (unionMap p m2 m1) + ((unionMap p m1 m2).map Prod.fst) && + subKeys (unionMap p m2 m1) (unionMap p m1 m2) + ((unionMap p m2 m1).map Prod.fst)) = true := by + intro p m1 m2 hcomm + rw [mapClause_iff] + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [unionMap_lookup, unionMap_lookup] + rcases m1.lookup k with _ | v <;> rcases m2.lookup k with _ | w <;> simp + · rw [unionMap_lookup] at hx hy + rcases h1 : m1.lookup k with _ | v <;> rcases h2 : m2.lookup k with _ | w <;> + rw [h1, h2] at hx hy <;> dsimp only at hx hy + · exact absurd hx (by simp) + · cases hx + cases hy + exact eqv_refl _ + · cases hx + cases hy + exact eqv_refl _ + · cases hx + cases hy + exact hcomm v w k h1 h2 + · rw [unionMap_lookup] at hx hy + rcases h1 : m1.lookup k with _ | v <;> rcases h2 : m2.lookup k with _ | w <;> + rw [h1, h2] at hx hy <;> dsimp only at hx hy + · exact absurd hx (by simp) + · cases hx + cases hy + exact eqv_refl _ + · cases hx + cases hy + exact eqv_refl _ + · cases hx + cases hy + exact eqv_symm _ _ (hcomm v w k h1 h2) + rw [merge.eq_def, merge.eq_def, eqv.eq_def] + simp only [Bool.and_eq_true] + refine ⟨⟨⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩, ?_⟩, ?_⟩ + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + intro x hx + exact hx.symm + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + intro x hx + exact hx.symm + · rcases r1 with _ | m1 <;> rcases r2 with _ | m2 + · rfl + · simp [subKeys_self] + · simp [subKeys_self] + · have hpay : ∀ x y k, m1.lookup k = some x → m2.lookup k = some y → + eqv (merge pol x y) (merge pol y x) = true := by + intro x y k hx hy + have hszx := lookup_sizeOf hx + have hszy := lookup_sizeOf hy + exact merge_comm pol x y + cases pol + · simpa [unionMap] using hunion false m1 m2 hpay + · simpa [unionMap] using hinter true m1 m2 hpay + · rcases v1 with _ | m1 <;> rcases v2 with _ | m2 + · rfl + · simp [subKeys_self] + · simp [subKeys_self] + · have hpay : ∀ x y k, m1.lookup k = some x → m2.lookup k = some y → + eqv (merge pol x y) (merge pol y x) = true := by + intro x y k hx hy + have hszx := lookup_sizeOf hx + have hszy := lookup_sizeOf hy + exact merge_comm pol x y + cases pol + · simpa [unionMap] using hinter false m1 m2 hpay + · simpa [unionMap] using hunion true m1 m2 hpay + · rcases f1 with _ | ⟨k1, d1, cod1⟩ <;> rcases f2 with _ | ⟨k2, d2, cod2⟩ + · rfl + · simpa [domsEqv] using funClause_of_funEqv (s1 := (k2, d2, cod2)) (s2 := (k2, d2, cod2)) + ⟨rfl, domsEqv_refl d2, eqv_refl cod2⟩ + · simpa [domsEqv] using funClause_of_funEqv (s1 := (k1, d1, cod1)) (s2 := (k1, d1, cod1)) + ⟨rfl, domsEqv_refl d1, eqv_refl cod1⟩ + · have hsz : sizeOf (k1, d1, cod1) + sizeOf (k2, d2, cod2) < + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) + + sizeOf (CTy.mk a2 r2 v2 (some (k2, d2, cod2)) c2) := by + simp + omega + simpa [domsEqv] using funClause_of_funEqv (mergeFun_comm pol (k1, d1, cod1) (k2, d2, cod2)) + · exact mergeRefinements_comm pol c1 c2 +termination_by a b => (sizeOf a + sizeOf b, 1) +decreasing_by all_goals + first + | (apply Prod.Lex.left; simp; omega) + | (apply Prod.Lex.right; simp; omega) + +theorem mergeFun_comm (pol : Bool) : (s1 s2 : KindM × List CTy × CTy) → + FunEqv (mergeFun pol s1 s2) (mergeFun pol s2 s1) + | (k1, d1, c1), (k2, d2, c2) => by + have hszc : sizeOf c1 + sizeOf c2 < sizeOf (k1, d1, c1) + sizeOf (k2, d2, c2) := by + simp + omega + have hcod : eqv (merge pol c1 c2) (merge pol c2 c1) = true := merge_comm pol c1 c2 + rw [mergeFun.eq_def, mergeFun.eq_def] + simp only [joinKind_comm k2 k1] + rcases hk : joinKind k1 k2 == KindM.conflict with _ | _ <;> + simp only [hk, Bool.false_eq_true, reduceIte] + case true => exact ⟨rfl, domsEqv_refl [], hcod⟩ + cases pol + · -- Negative: the contravariant meet, defined only on singletons; every other + -- shape conflicts on both sides. + simp only [Bool.false_eq_true, reduceIte] + rcases hm : meetDoms d1 d2 with _ | ds + · rw [meetDoms_none_comm hm] + exact ⟨rfl, domsEqv_refl [], hcod⟩ + · obtain ⟨x, xs, y, ys, ha, hb, hgate, hds⟩ := meetDoms_eq_some hm + rw [Bool.and_eq_true] at hgate + -- The swapped call meets the same two heads, with the gate mirrored. + have hswap : meetDoms d2 d1 = some [merge true y x] := by + rw [ha, hb] + exact meetDoms_of_gate (by rw [Bool.and_eq_true]; exact ⟨hgate.2, hgate.1⟩) + -- The bound stays in terms of the parameters, which is the form the + -- termination measure is stated over; only the goal is rewritten. + have hszd : sizeOf x + sizeOf y < sizeOf (k1, d1, c1) + sizeOf (k2, d2, c2) := by + rw [ha, hb] + simp + omega + rw [hswap, hds] + exact ⟨rfl, domsEqv_singleton (merge_comm true x y), hcod⟩ + · -- Positive: the alternatives are a set, and the union of two sets is + -- symmetric up to `eqv`. + simp only [reduceIte] + exact ⟨rfl, unionDoms_comm d1 d2, hcod⟩ +termination_by s1 s2 => (sizeOf s1 + sizeOf s2, 0) +decreasing_by all_goals + first + | (apply Prod.Lex.left; omega) + | (apply Prod.Lex.left; simp; omega) + | (apply Prod.Lex.right; simp; omega) + +end + +/-! ## Depth + +The measure materialization terminates on. `merge` combines contributions +pointwise and never nests one inside another, so a merged position is no deeper +than the deeper of its inputs (`merge_depth_le`) — which is what bounds +`coalesce`'s recursion through a `Compute` slot's folded alternatives, a call no +`sizeOf` measure reaches. -/ + +mutual + +/-- Nesting depth: one for the position, plus the deepest child. Atoms and refinements +do not nest, so they do not count. -/ +def depth : CTy → Nat + | .mk _ recF varT fn _ => + 1 + Nat.max (optMapDepth recF) (Nat.max (optMapDepth varT) (optFnDepth fn)) + +def optMapDepth : Option (List (FieldKey × CTy)) → Nat + | none => 0 + | some m => mapDepth m + +def mapDepth : List (FieldKey × CTy) → Nat + | [] => 0 + | (_, w) :: rest => Nat.max (depth w) (mapDepth rest) + +def optFnDepth : Option (KindM × List CTy × CTy) → Nat + | none => 0 + | some (_, ds, cod) => Nat.max (listDepth ds) (depth cod) + +def listDepth : List CTy → Nat + | [] => 0 + | d :: ds => Nat.max (depth d) (listDepth ds) + +end + +/-! ### Reading `depth` -/ + +theorem depth_pos (t : CTy) : 1 ≤ depth t := by + rcases t with ⟨a, r, v, f, c⟩ + rw [depth] + omega + +theorem le_mapDepth {m : List (FieldKey × CTy)} {p : FieldKey × CTy} (h : p ∈ m) : + depth p.2 ≤ mapDepth m := by + induction m with + | nil => exact absurd h (by simp) + | cons hd tl ih => + rw [mapDepth] + rcases List.mem_cons.mp h with h' | h' + · rcases hd with ⟨k, w⟩ + rw [h'] + exact Nat.le_max_left _ _ + · exact Nat.le_trans (ih h') (by rcases hd with ⟨k, w⟩; exact Nat.le_max_right _ _) + +theorem mapDepth_le {m : List (FieldKey × CTy)} {b : Nat} + (h : ∀ p ∈ m, depth p.2 ≤ b) : mapDepth m ≤ b := by + induction m with + | nil => simp [mapDepth] + | cons hd tl ih => + rcases hd with ⟨k, w⟩ + rw [mapDepth] + exact Nat.max_le.mpr ⟨h (k, w) (by simp), ih fun p hp => h p (by simp [hp])⟩ + +theorem le_listDepth {l : List CTy} {x : CTy} (h : x ∈ l) : depth x ≤ listDepth l := by + induction l with + | nil => exact absurd h (by simp) + | cons hd tl ih => + rw [listDepth] + rcases List.mem_cons.mp h with h' | h' + · rw [h'] + exact Nat.le_max_left _ _ + · exact Nat.le_trans (ih h') (Nat.le_max_right _ _) + +theorem listDepth_le {l : List CTy} {b : Nat} (h : ∀ x ∈ l, depth x ≤ b) : + listDepth l ≤ b := by + induction l with + | nil => simp [listDepth] + | cons hd tl ih => + rw [listDepth] + exact Nat.max_le.mpr ⟨h hd (by simp), ih fun x hx => h x (by simp [hx])⟩ + +theorem mem_of_lookup {m : List (FieldKey × CTy)} {k : FieldKey} {w : CTy} + (h : m.lookup k = some w) : (k, w) ∈ m := by + induction m with + | nil => simp [List.lookup] at h + | cons hd tl ih => + rw [List.lookup] at h + split at h + · rename_i heq + cases h + rcases hd with ⟨k', w'⟩ + simp only [beq_iff_eq] at heq + rw [heq] + simp + · exact List.mem_cons.mpr (Or.inr (ih h)) + +/-- Every entry of `interMap` is a merge of one from each side. -/ +theorem mem_interMap {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {p : FieldKey × CTy} + (hp : p ∈ interMap pol m1 m2) : + ∃ v w, (p.1, v) ∈ m1 ∧ (p.1, w) ∈ m2 ∧ p.2 = merge pol v w := by + induction m1 with + | nil => exact absurd hp (by simp [interMap]) + | cons hd tl ih => + rcases hd with ⟨k, v⟩ + rw [interMap] at hp + split at hp + · rename_i w hw + rcases List.mem_cons.mp hp with h' | h' + · subst h' + exact ⟨v, w, by simp, mem_of_lookup hw, rfl⟩ + · obtain ⟨v', w', hv', hw', he⟩ := ih h' + exact ⟨v', w', List.mem_cons.mpr (Or.inr hv'), hw', he⟩ + · obtain ⟨v', w', hv', hw', he⟩ := ih hp + exact ⟨v', w', List.mem_cons.mpr (Or.inr hv'), hw', he⟩ + +/-- Every entry of `unionMapGo` is one of `m1`'s, merged with `m2`'s when present. -/ +theorem mem_unionMapGo {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {p : FieldKey × CTy} + (hp : p ∈ unionMapGo pol m1 m2) : + ∃ v, (p.1, v) ∈ m1 ∧ + (p.2 = v ∨ ∃ w, (p.1, w) ∈ m2 ∧ p.2 = merge pol v w) := by + induction m1 with + | nil => exact absurd hp (by simp [unionMapGo]) + | cons hd tl ih => + rcases hd with ⟨k, v⟩ + rw [unionMapGo] at hp + rcases List.mem_cons.mp hp with h' | h' + · subst h' + rcases hw : m2.lookup k with _ | w + · exact ⟨v, by simp, Or.inl (by simp [hw])⟩ + · exact ⟨v, by simp, Or.inr ⟨w, mem_of_lookup hw, by simp [hw]⟩⟩ + · obtain ⟨v', hv', hrest⟩ := ih h' + exact ⟨v', List.mem_cons.mpr (Or.inr hv'), hrest⟩ + +/-- The codomain is merged whatever else the slots do. -/ +theorem mergeFun_cod (pol : Bool) (s1 s2 : KindM × List CTy × CTy) : + (mergeFun pol s1 s2).2.2 = merge pol s1.2.2 s2.2.2 := by + obtain ⟨k1, d1, c1⟩ := s1 + obtain ⟨k2, d2, c2⟩ := s2 + rw [mergeFun.eq_def] + dsimp only + split + · rfl + · split + · rfl + · split <;> rfl + +/-- A slot whose kinds join to a conflict merges to the conflicted slot, at +either polarity and whatever the domains hold. -/ +theorem mergeFun_of_conflict (pol : Bool) (s1 s2 : KindM × List CTy × CTy) + (h : joinKind s1.1 s2.1 = .conflict) : + mergeFun pol s1 s2 = (.conflict, [], merge pol s1.2.2 s2.2.2) := by + obtain ⟨k1, d1, c1⟩ := s1 + obtain ⟨k2, d2, c2⟩ := s2 + rw [mergeFun.eq_def] + simp only [h] + rfl + +/-! ### `merge` does not deepen a position + +Each component of the merged position is built from components of the inputs, so +the whole is no deeper than the deeper input. The three lemmas below take the +recursion as a hypothesis, which keeps them out of any mutual block; `merge_depth_le` +supplies it by induction on a depth bound. -/ + +theorem interMap_depth_le {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {bnd : Nat} + (h1 : mapDepth m1 ≤ bnd) (h2 : mapDepth m2 ≤ bnd) + (hrec : ∀ v w, depth v ≤ mapDepth m1 → depth w ≤ mapDepth m2 → + depth (merge pol v w) ≤ Nat.max (depth v) (depth w)) : + mapDepth (interMap pol m1 m2) ≤ bnd := by + refine mapDepth_le fun p hp => ?_ + obtain ⟨v, w, hv, hw, he⟩ := mem_interMap hp + rw [he] + exact Nat.le_trans (hrec v w (le_mapDepth (p := (p.1, v)) hv) (le_mapDepth (p := (p.1, w)) hw)) + (Nat.max_le.mpr ⟨Nat.le_trans (le_mapDepth (p := (p.1, v)) hv) h1, + Nat.le_trans (le_mapDepth (p := (p.1, w)) hw) h2⟩) + +theorem unionMap_depth_le {pol : Bool} {m1 m2 : List (FieldKey × CTy)} {bnd : Nat} + (h1 : mapDepth m1 ≤ bnd) (h2 : mapDepth m2 ≤ bnd) + (hrec : ∀ v w, depth v ≤ mapDepth m1 → depth w ≤ mapDepth m2 → + depth (merge pol v w) ≤ Nat.max (depth v) (depth w)) : + mapDepth (unionMapGo pol m1 m2 ++ m2.filter (fun kw => (m1.lookup kw.1).isNone)) + ≤ bnd := by + refine mapDepth_le fun p hp => ?_ + rcases List.mem_append.mp hp with hp | hp + · obtain ⟨v, hv, hcase⟩ := mem_unionMapGo hp + rcases hcase with he | ⟨w, hw, he⟩ + · rw [he] + exact Nat.le_trans (le_mapDepth (p := (p.1, v)) hv) h1 + · rw [he] + exact Nat.le_trans + (hrec v w (le_mapDepth (p := (p.1, v)) hv) (le_mapDepth (p := (p.1, w)) hw)) + (Nat.max_le.mpr ⟨Nat.le_trans (le_mapDepth (p := (p.1, v)) hv) h1, + Nat.le_trans (le_mapDepth (p := (p.1, w)) hw) h2⟩) + · exact Nat.le_trans (le_mapDepth (List.mem_filter.mp hp).1) h2 + +theorem mergeFun_depth_le {pol : Bool} {k1 k2 : KindM} {d1 d2 : List CTy} {c1 c2 : CTy} + (hdom : ∀ x y, depth x ≤ listDepth d1 → depth y ≤ listDepth d2 → + depth (merge true x y) ≤ Nat.max (depth x) (depth y)) + (hcod : depth (merge pol c1 c2) ≤ Nat.max (depth c1) (depth c2)) : + optFnDepth (some (mergeFun pol (k1, d1, c1) (k2, d2, c2))) + ≤ Nat.max (optFnDepth (some (k1, d1, c1))) (optFnDepth (some (k2, d2, c2))) := by + have hb1 : listDepth d1 ≤ Nat.max (optFnDepth (some (k1, d1, c1))) + (optFnDepth (some (k2, d2, c2))) := by + rw [optFnDepth] + exact Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_left _ _) + have hb2 : listDepth d2 ≤ Nat.max (optFnDepth (some (k1, d1, c1))) + (optFnDepth (some (k2, d2, c2))) := by + show listDepth d2 ≤ _ + exact Nat.le_trans (Nat.le_trans (Nat.le_max_left _ (depth c2)) (Nat.le_max_right _ _)) + (Nat.le_refl _) + have hcb : depth (merge pol c1 c2) ≤ Nat.max (optFnDepth (some (k1, d1, c1))) + (optFnDepth (some (k2, d2, c2))) := by + refine Nat.le_trans hcod (Nat.max_le.mpr ⟨?_, ?_⟩) + · rw [optFnDepth] + exact Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_left _ _) + · exact Nat.le_trans (Nat.le_max_right (listDepth d2) _) (Nat.le_max_right _ _) + -- Every alternative the merge keeps comes from one side, or is a meet of one + -- from each; the codomain is a merge of the two codomains. + have hds : listDepth (mergeFun pol (k1, d1, c1) (k2, d2, c2)).2.1 + ≤ Nat.max (optFnDepth (some (k1, d1, c1))) (optFnDepth (some (k2, d2, c2))) := by + rw [mergeFun.eq_def] + dsimp only + split + · simpa [listDepth] using Nat.zero_le _ + · split + · refine listDepth_le fun x hx => ?_ + rcases mem_unionDoms hx with h | h + · exact Nat.le_trans (le_listDepth h) hb1 + · exact Nat.le_trans (le_listDepth h) hb2 + · rcases hm : meetDoms d1 d2 with _ | ds + · simpa [listDepth] using Nat.zero_le _ + · obtain ⟨x, xs, y, ys, ha1, ha2, _, hds⟩ := meetDoms_eq_some hm + rw [hds] + refine listDepth_le fun z hz => ?_ + rw [List.mem_singleton.mp hz] + exact Nat.le_trans + (hdom x y (le_listDepth (ha1 ▸ by simp)) (le_listDepth (ha2 ▸ by simp))) + (Nat.max_le.mpr + ⟨Nat.le_trans (le_listDepth (ha1 ▸ by simp)) hb1, + Nat.le_trans (le_listDepth (ha2 ▸ by simp)) hb2⟩) + have hc : depth (mergeFun pol (k1, d1, c1) (k2, d2, c2)).2.2 + ≤ Nat.max (optFnDepth (some (k1, d1, c1))) (optFnDepth (some (k2, d2, c2))) := by + rw [mergeFun_cod] + exact hcb + rcases hs : mergeFun pol (k1, d1, c1) (k2, d2, c2) with ⟨k, ds, cod⟩ + rw [optFnDepth] + rw [hs] at hds hc + exact Nat.max_le.mpr ⟨hds, hc⟩ + +theorem succ_max_le (A B : Nat) : 1 + Nat.max A B ≤ Nat.max (1 + A) (1 + B) := by + simp only [Nat.max_def] + split <;> split <;> omega + +/-- A position is one deeper than its deepest component. -/ +theorem depth_mk_le {a1 : List Atom} {r v : Option (List (FieldKey × CTy))} + {f : Option (KindM × List CTy × CTy)} {c : Option (List Pred)} {bnd : Nat} + (hr : optMapDepth r ≤ bnd) (hv : optMapDepth v ≤ bnd) (hf : optFnDepth f ≤ bnd) : + depth (CTy.mk a1 r v f c) ≤ 1 + bnd := by + rw [depth] + exact Nat.add_le_add_left (Nat.max_le.mpr ⟨hr, Nat.max_le.mpr ⟨hv, hf⟩⟩) 1 + +/-- **`merge` does not deepen a position.** Every component of the merged position +is built from components of the inputs — atoms and refinements union, map payloads +merge pointwise, a function slot's alternatives come from one side or are a meet of +one from each, and its codomain is a merge of the two — so the whole is no deeper +than the deeper input. + +By induction on a depth bound rather than on the term, because the statement is +needed exactly where no structural measure works: `coalesce`'s recursion through a +`Compute` slot's folded alternatives materializes a `merge` result, not a subterm. +`compact.rs` relies on this and states it nowhere. -/ +theorem merge_depth_le_bounded : ∀ (n : Nat) (pol : Bool) (a b : CTy), + depth a ≤ n → depth b ≤ n → + depth (merge pol a b) ≤ Nat.max (depth a) (depth b) := by + intro n + induction n with + | zero => + intro _ a _ ha _ + exact absurd (Nat.le_trans (depth_pos a) ha) (by omega) + | succ n ih => + intro pol a b ha hb + rcases a with ⟨a1, r1, v1, f1, c1⟩ + rcases b with ⟨a2, r2, v2, f2, c2⟩ + -- Children are shallower than their position, so the bound drops by one and the + -- induction hypothesis applies to any pair of them. + have hchild : ∀ x y : CTy, + depth x ≤ Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1)) → + depth y ≤ Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2)) → + depth (merge pol x y) ≤ Nat.max (depth x) (depth y) := by + intro x y hx hy + have hA : Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1)) ≤ n := by + rw [depth] at ha + omega + have hB : Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2)) ≤ n := by + rw [depth] at hb + omega + exact ih pol x y (Nat.le_trans hx hA) (Nat.le_trans hy hB) + have hchild' : ∀ x y : CTy, + depth x ≤ Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1)) → + depth y ≤ Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2)) → + depth (merge true x y) ≤ Nat.max (depth x) (depth y) := by + intro x y hx hy + have hA : Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1)) ≤ n := by + rw [depth] at ha + omega + have hB : Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2)) ≤ n := by + rw [depth] at hb + omega + exact ih true x y (Nat.le_trans hx hA) (Nat.le_trans hy hB) + -- The three components, each bounded by the deeper input's deepest component. + have hB1 := Nat.le_max_left + (Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1))) + (Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2))) + have hB2 := Nat.le_max_right + (Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1))) + (Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2))) + rw [merge.eq_def] + dsimp only + refine Nat.le_trans + (depth_mk_le + (bnd := Nat.max (Nat.max (optMapDepth r1) (Nat.max (optMapDepth v1) (optFnDepth f1))) + (Nat.max (optMapDepth r2) (Nat.max (optMapDepth v2) (optFnDepth f2)))) + ?_ ?_ ?_) ?_ + · -- Records: intersected at a positive position, united at a negative one. + rcases r1 with _ | m1 + · rcases r2 with _ | m2 + · simp [optMapDepth] + · exact Nat.le_trans (Nat.le_max_left _ _) hB2 + · rcases r2 with _ | m2 + · exact Nat.le_trans (Nat.le_max_left _ _) hB1 + · have h1 : mapDepth m1 ≤ _ := Nat.le_trans (Nat.le_max_left _ _) hB1 + have h2 : mapDepth m2 ≤ _ := Nat.le_trans (Nat.le_max_left _ _) hB2 + have hr : ∀ v w, depth v ≤ mapDepth m1 → depth w ≤ mapDepth m2 → + depth (merge pol v w) ≤ Nat.max (depth v) (depth w) := fun v w hv hw => + hchild v w (Nat.le_trans hv (Nat.le_max_left _ _)) + (Nat.le_trans hw (Nat.le_max_left _ _)) + cases pol + · simpa [optMapDepth] using unionMap_depth_le h1 h2 hr + · simpa [optMapDepth] using interMap_depth_le h1 h2 hr + · -- Variants: the dual. + rcases v1 with _ | m1 + · rcases v2 with _ | m2 + · simp [optMapDepth] + · exact Nat.le_trans (Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _)) hB2 + · rcases v2 with _ | m2 + · exact Nat.le_trans (Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _)) hB1 + · have h1 : mapDepth m1 ≤ _ := + Nat.le_trans (Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _)) hB1 + have h2 : mapDepth m2 ≤ _ := + Nat.le_trans (Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _)) hB2 + have hr : ∀ v w, depth v ≤ mapDepth m1 → depth w ≤ mapDepth m2 → + depth (merge pol v w) ≤ Nat.max (depth v) (depth w) := fun v w hv hw => + hchild v w + (Nat.le_trans hv (Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _))) + (Nat.le_trans hw (Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _))) + cases pol + · simpa [optMapDepth] using interMap_depth_le h1 h2 hr + · simpa [optMapDepth] using unionMap_depth_le h1 h2 hr + · -- The function slot. + rcases f1 with _ | ⟨k1, d1, cod1⟩ + · rcases f2 with _ | s2 + · simp [optFnDepth] + · exact Nat.le_trans (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)) hB2 + · rcases f2 with _ | ⟨k2, d2, cod2⟩ + · exact Nat.le_trans (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)) hB1 + · have hin1 : optFnDepth (some (k1, d1, cod1)) ≤ _ := + Nat.le_trans (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)) hB1 + have hin2 : optFnDepth (some (k2, d2, cod2)) ≤ _ := + Nat.le_trans (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)) hB2 + have hdom : ∀ x y, depth x ≤ listDepth d1 → depth y ≤ listDepth d2 → + depth (merge true x y) ≤ Nat.max (depth x) (depth y) := fun x y hx hy => + hchild' x y + (Nat.le_trans hx (Nat.le_trans (Nat.le_max_left _ _) + (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)))) + (Nat.le_trans hy (Nat.le_trans (Nat.le_max_left _ _) + (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)))) + have hcodb : depth (merge pol cod1 cod2) ≤ Nat.max (depth cod1) (depth cod2) := + hchild cod1 cod2 + (Nat.le_trans (Nat.le_max_right _ _) + (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _))) + (Nat.le_trans (Nat.le_max_right _ _) + (Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _))) + exact Nat.le_trans (mergeFun_depth_le hdom hcodb) + (Nat.max_le.mpr ⟨hin1, hin2⟩) + · rw [depth, depth] + exact succ_max_le _ _ + +/-- `merge` does not deepen a position, with no bound to supply. -/ +theorem merge_depth_le (pol : Bool) (a b : CTy) : + depth (merge pol a b) ≤ Nat.max (depth a) (depth b) := + merge_depth_le_bounded (Nat.max (depth a) (depth b)) pol a b + (Nat.le_max_left _ _) (Nat.le_max_right _ _) + +/-- The meet of a slot's alternatives, folded left as `coalesce_compact_go` folds +them. Named rather than written as `List.foldl` so the depth bound below states a +term the termination checker sees unchanged. -/ +def meetAll (pol : Bool) : CTy → List CTy → CTy + | acc, [] => acc + | acc, x :: xs => meetAll pol (merge pol acc x) xs + +/-- Folding the meet over a slot's alternatives stays within their depth — the +bound `coalesce` needs for the one recursive call no subterm ordering reaches. -/ +theorem meetAll_depth_le (pol : Bool) : (d : CTy) → (rest : List CTy) → + depth (meetAll pol d rest) ≤ Nat.max (depth d) (listDepth rest) + | d, [] => by + rw [meetAll, listDepth] + exact Nat.le_max_left _ _ + | d, x :: xs => by + rw [meetAll] + refine Nat.le_trans (meetAll_depth_le pol (merge pol d x) xs) ?_ + refine Nat.max_le.mpr ⟨Nat.le_trans (merge_depth_le pol d x) ?_, ?_⟩ + · rw [listDepth] + exact Nat.max_le.mpr + ⟨Nat.le_max_left _ _, + Nat.le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _)⟩ + · rw [listDepth] + exact Nat.le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _) + +/-! ## Well-formedness of input bounds + +`compact_go` builds every bound's `CTy` from a `Type`: a function contributes +exactly one domain and a ground kind (`AtomKey::from_type` / the `Type::Fun` +arm), so an *input* bound never carries a `conflict` kind or a multi-domain +slot — those states are only ever *produced* by merging. Idempotence (and the +fold's duplicate-invariance) is stated under this invariant: a conflicted or +domain-less slot is an error state the solver never feeds back in, and +`eqv`-idempotence genuinely fails there (the model's conflict arm canonicalizes +the diagnostic payload away). -/ + +mutual + +/-- Keys are duplicate-free, mirroring the `BTreeMap` the map stands for, which +cannot hold two bindings for one key. `eqv` is blind to a shadowed duplicate +because it compares by `lookup`, but `coalesce` materializes every entry and +`subTags` checks every one, so a duplicate is observable in the type. -/ +def nodupKeys : List FieldKey → Bool + | [] => true + | k :: ks => !ks.contains k && nodupKeys ks + +/-- The input-bound invariant (see the section header). -/ +def wf : CTy → Bool + | .mk atoms r v f c => + (match r with + | none => true + | some m => wfKeys m (m.map Prod.fst) && nodupKeys (m.map Prod.fst)) + && (match v with + | none => true + | some m => wfKeys m (m.map Prod.fst) && nodupKeys (m.map Prod.fst)) + && (match f with + | none => true + | some (k, d, cod) => + (k != .conflict) + && (match d with + | [x] => wf x + | _ => false) + && wf cod) + -- The refinement slot's `none` is the merge identity, and `compact_go` gives it + -- only to the two contributions that are not values: a hole and a bare + -- variable, neither of which carries content. A position with content and + -- no refinement slot would absorb a sibling bound's refinements instead of + -- intersecting with none of its own, so `Int` joined with `{Int | p}` would + -- keep `p`. + && (match c with + | none => atoms.isEmpty && r.isNone && v.isNone && f.isNone + | some _ => true) +termination_by t => (sizeOf t, 0) + +/-- All payloads of a map are `wf` (worklist form, like `subKeys`). -/ +def wfKeys (m : List (FieldKey × CTy)) : List FieldKey → Bool + | [] => true + | k :: ks => + (match h : m.lookup k with + | some v => wf v + | none => true) + && wfKeys m ks +termination_by ks => (sizeOf m, ks.length) +decreasing_by + · have := lookup_sizeOf h + apply Prod.Lex.left + omega + · apply Prod.Lex.right + simp + +end + +/-- Pointwise reading of `wfKeys`. -/ +theorem wfKeys_iff {m : List (FieldKey × CTy)} {ks : List FieldKey} : + wfKeys m ks = true ↔ ∀ k ∈ ks, ∀ v, m.lookup k = some v → wf v = true := by + induction ks with + | nil => simp [wfKeys] + | cons k ks ih => + rw [wfKeys, Bool.and_eq_true, ih] + constructor + · intro ⟨hhead, htail⟩ k' hk' + rcases List.mem_cons.mp hk' with h | h + · subst h + intro v hv + rw [hv] at hhead + exact hhead + · exact htail k' h + · intro h + refine ⟨?_, fun k' hk' => h k' (by simp [hk'])⟩ + rcases hv : m.lookup k with _ | v + · rfl + · exact h k (by simp) v hv + +/-! ## Idempotence -/ + +theorem merge_idem (pol : Bool) : (a : CTy) → wf a = true → eqv (merge pol a a) a = true + | .mk a1 r1 v1 f1 c1 => by + intro hwf + rw [wf.eq_def] at hwf + simp only [Bool.and_eq_true] at hwf + obtain ⟨⟨⟨hwr, hwv⟩, hwfn⟩, _hwc⟩ := hwf + -- Both keyed self-merges are pointwise `merge pol v v`, closed by the + -- recursive call on the (wf) payload. + have hmap : ∀ (p : Bool) (m : List (FieldKey × CTy)), + (∀ x k, m.lookup k = some x → eqv (merge p x x) x = true) → + ∀ (mm : List (FieldKey × CTy)), + (∀ k, mm.lookup k = + match m.lookup k, m.lookup k with + | some v, some w => some (merge p v w) + | some v, none => some v + | none, some _ => none + | none, none => none) → + (subKeys mm m (mm.map Prod.fst) && subKeys m mm (m.map Prod.fst)) = true := by + intro p m hidem mm hmm + rw [mapClause_iff] + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [hmm k] + rcases m.lookup k with _ | v <;> simp + · rw [hmm k] at hx + cases h1 : m.lookup k with + | none => + rw [h1] at hx + exact absurd hx (by simp) + | some v => + rw [h1] at hx + dsimp only at hx + cases hx + rw [h1] at hy + cases hy + exact hidem _ k h1 + · rw [hmm k] at hx + cases h1 : m.lookup k with + | none => + rw [h1] at hx + exact absurd hx (by simp) + | some v => + rw [h1] at hx + dsimp only at hx + cases hx + rw [h1] at hy + cases hy + exact eqv_symm _ _ (hidem _ k h1) + rw [merge.eq_def, eqv.eq_def] + simp only [Bool.and_eq_true] + refine ⟨⟨⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩, ?_⟩, ?_⟩ + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + exact fun x hx => hx.elim id id + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + exact fun x hx => Or.inl hx + · rcases r1 with _ | m + · rfl + · have hpay : ∀ x k, m.lookup k = some x → eqv (merge pol x x) x = true := by + intro x k hx + have hszx := lookup_sizeOf hx + have hwx : wf x = true := (wfKeys_iff.mp (by simp only [Bool.and_eq_true] at hwr; simpa using hwr.1)) k + (mem_keys_of_lookup hx) x hx + exact merge_idem pol x hwx + cases pol + · simpa [unionMap] using hmap false m hpay (unionMap false m m) + (fun k => by + rw [unionMap_lookup] + rcases m.lookup k with _ | v <;> rfl) + · simpa using hmap true m hpay (interMap true m m) + (fun k => by + rw [interMap_lookup] + rcases m.lookup k with _ | v <;> rfl) + · rcases v1 with _ | m + · rfl + · have hpay : ∀ x k, m.lookup k = some x → eqv (merge pol x x) x = true := by + intro x k hx + have hszx := lookup_sizeOf hx + have hwx : wf x = true := (wfKeys_iff.mp (by simp only [Bool.and_eq_true] at hwv; simpa using hwv.1)) k + (mem_keys_of_lookup hx) x hx + exact merge_idem pol x hwx + cases pol + · simpa using hmap false m hpay (interMap false m m) + (fun k => by + rw [interMap_lookup] + rcases m.lookup k with _ | v <;> rfl) + · simpa [unionMap] using hmap true m hpay (unionMap true m m) + (fun k => by + rw [unionMap_lookup] + rcases m.lookup k with _ | v <;> rfl) + · rcases f1 with _ | ⟨k1, d1, cod1⟩ + · rfl + · rcases d1 with _ | ⟨x, xs⟩ + · simp [wf] at hwfn + · rcases xs with _ | ⟨x2, xs2⟩ + case cons => simp [wf] at hwfn + simp only [Bool.and_eq_true, bne_iff_ne, ne_eq] at hwfn + obtain ⟨⟨hk1, hwx⟩, hwcod⟩ := hwfn + have hszx : sizeOf x < sizeOf (CTy.mk a1 r1 v1 (some (k1, [x], cod1)) c1) := by + simp + omega + have hszc : sizeOf cod1 < + sizeOf (CTy.mk a1 r1 v1 (some (k1, [x], cod1)) c1) := by + simp + omega + have hx : eqv (merge (!pol) x x) x = true := merge_idem (!pol) x hwx + have hcod : eqv (merge pol cod1 cod1) cod1 = true := merge_idem pol cod1 hwcod + dsimp only + rw [mergeFun.eq_def] + -- The kind is idempotent and `wf` rules out a conflict, so the slot's + -- kind survives untouched and only the domain and codomain recurse. + simp only [joinKind_idem k1, beq_iff_eq, if_neg hk1] + cases pol + · simp only [Bool.false_eq_true, reduceIte, meetDoms_single] + simpa [domsEqv] using funClause_of_funEqv + (s1 := (k1, [merge true x x], merge false cod1 cod1)) + (s2 := (k1, [x], cod1)) + ⟨rfl, domsEqv_singleton (by simpa using hx), hcod⟩ + · simp only [reduceIte] + simpa [domsEqv] using funClause_of_funEqv + (s1 := (k1, unionDoms [x] [x], merge true cod1 cod1)) + (s2 := (k1, [x], cod1)) ⟨rfl, unionDoms_idem [x], hcod⟩ + · exact mergeRefinements_idem pol c1 +termination_by a => sizeOf a +decreasing_by all_goals (simp; omega) + +/-! ## Congruence: `merge` respects `eqv` + +The one gate inside `merge` — the positive `data ⊔ data` domain dedup — is +`eqv` itself, so it cannot distinguish `eqv`-equal inputs (`eqv_congr_bool`). +That is the whole reason congruence holds; a gate keyed on anything finer +(e.g. structural equality, with `eqv` coarser than it) would break it. -/ + +/-- Replacing one side of the gate by an `eqv`-equal value leaves the gate's +verdict unchanged. -/ +theorem eqv_congr_bool {x x' : CTy} (h : eqv x x' = true) (y : CTy) : + eqv x y = eqv x' y := by + rcases hg : eqv x' y with _ | _ + · rcases hg' : eqv x y with _ | _ + · rfl + · rw [eqv_trans x' x y (eqv_symm x x' h) hg'] at hg + exact hg + · exact eqv_trans x x' y h hg + +/-- `FunEqv` is reflexive. -/ +theorem funEqv_refl (s : KindM × List CTy × CTy) : FunEqv s s := by + obtain ⟨k, d, c⟩ := s + exact ⟨rfl, domsEqv_refl d, eqv_refl c⟩ + +mutual + +theorem merge_congr_left (pol : Bool) : + (a a' b : CTy) → eqv a a' = true → eqv (merge pol a b) (merge pol a' b) = true + | .mk a1 r1 v1 f1 c1, .mk a1' r1' v1' f1' c1', .mk b1 rb vb fb cb => by + intro h + rw [eqv.eq_def] at h + simp only [Bool.and_eq_true] at h + obtain ⟨⟨⟨⟨⟨h1, h2⟩, hr⟩, hv⟩, hf⟩, hcl⟩ := h + -- Pointwise congruence for the two keyed merges. + have hinterC : ∀ (p : Bool) (m1 m1' m2 : List (FieldKey × CTy)), + (subKeys m1 m1' (m1.map Prod.fst) && subKeys m1' m1 (m1'.map Prod.fst)) = true → + (∀ x x' y k, m1.lookup k = some x → m1'.lookup k = some x' → m2.lookup k = some y → + eqv (merge p x y) (merge p x' y) = true) → + (subKeys (interMap p m1 m2) (interMap p m1' m2) + ((interMap p m1 m2).map Prod.fst) && + subKeys (interMap p m1' m2) (interMap p m1 m2) + ((interMap p m1' m2).map Prod.fst)) = true := by + intro p m1 m1' m2 hcl hcong + rw [mapClause_iff] at hcl ⊢ + obtain ⟨hdom, hfwd, hbwd⟩ := hcl + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [interMap_lookup, interMap_lookup] + rcases hl1 : m1.lookup k with _ | v <;> rcases hl2 : m2.lookup k with _ | w <;> + rcases hl1' : m1'.lookup k with _ | v' <;> + first + | (simp; done) + | (have hcontra := hdom k; simp [hl1, hl1'] at hcontra) + · rw [interMap_lookup] at hx hy + cases hl1 : m1.lookup k with + | none => + rw [hl1] at hx + exact absurd hx (by simp) + | some v => + rw [hl1] at hx + cases hl2 : m2.lookup k with + | none => + rw [hl2] at hx + exact absurd hx (by simp) + | some w => + rw [hl2] at hx + dsimp only at hx + obtain ⟨v', hv'⟩ := Option.isSome_iff_exists.mp ((hdom k).mp (by simp [hl1])) + rw [hv', hl2] at hy + dsimp only at hy + cases hx + cases hy + exact hcong _ _ _ k hl1 hv' hl2 + · rw [interMap_lookup] at hx hy + cases hl1' : m1'.lookup k with + | none => + rw [hl1'] at hy + exact absurd hy (by simp) + | some v' => + rw [hl1'] at hy + cases hl2 : m2.lookup k with + | none => + rw [hl2] at hy + exact absurd hy (by simp) + | some w => + rw [hl2] at hy + dsimp only at hy + obtain ⟨v, hv⟩ := Option.isSome_iff_exists.mp ((hdom k).mpr (by simp [hl1'])) + rw [hv, hl2] at hx + dsimp only at hx + cases hx + cases hy + exact eqv_symm _ _ (hcong _ _ _ k hv hl1' hl2) + have hunionC : ∀ (p : Bool) (m1 m1' m2 : List (FieldKey × CTy)), + (subKeys m1 m1' (m1.map Prod.fst) && subKeys m1' m1 (m1'.map Prod.fst)) = true → + (∀ x x' y k, m1.lookup k = some x → m1'.lookup k = some x' → m2.lookup k = some y → + eqv (merge p x y) (merge p x' y) = true) → + (subKeys (unionMap p m1 m2) (unionMap p m1' m2) + ((unionMap p m1 m2).map Prod.fst) && + subKeys (unionMap p m1' m2) (unionMap p m1 m2) + ((unionMap p m1' m2).map Prod.fst)) = true := by + intro p m1 m1' m2 hcl hcong + have hpay : ∀ x x' k, m1.lookup k = some x → m1'.lookup k = some x' → + eqv x x' = true := (mapClause_iff.mp hcl).2.1 |> fun hh => fun x x' k hx hx' => + hh k x x' hx hx' + rw [mapClause_iff] at hcl ⊢ + obtain ⟨hdom, hfwd, hbwd⟩ := hcl + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [unionMap_lookup, unionMap_lookup] + rcases hl1 : m1.lookup k with _ | v <;> rcases hl2 : m2.lookup k with _ | w <;> + rcases hl1' : m1'.lookup k with _ | v' <;> + first + | (simp; done) + | (have hcontra := hdom k; simp [hl1, hl1'] at hcontra) + · rw [unionMap_lookup] at hx hy + cases hl1 : m1.lookup k with + | none => + rw [hl1] at hx + cases hl2 : m2.lookup k with + | none => + rw [hl2] at hx + exact absurd hx (by simp) + | some w => + rw [hl2] at hx + dsimp only at hx + have hno : m1'.lookup k = none := by + rcases hl1' : m1'.lookup k with _ | v' + · rfl + · exact absurd ((hdom k).mpr (by simp [hl1'])) (by simp [hl1]) + rw [hno, hl2] at hy + dsimp only at hy + cases hx + cases hy + exact eqv_refl _ + | some v => + rw [hl1] at hx + obtain ⟨v', hv'⟩ := Option.isSome_iff_exists.mp ((hdom k).mp (by simp [hl1])) + rw [hv'] at hy + cases hl2 : m2.lookup k with + | none => + rw [hl2] at hx hy + dsimp only at hx hy + cases hx + cases hy + exact hpay _ _ k hl1 hv' + | some w => + rw [hl2] at hx hy + dsimp only at hx hy + cases hx + cases hy + exact hcong _ _ _ k hl1 hv' hl2 + · rw [unionMap_lookup] at hx hy + cases hl1' : m1'.lookup k with + | none => + rw [hl1'] at hy + cases hl2 : m2.lookup k with + | none => + rw [hl2] at hy + exact absurd hy (by simp) + | some w => + rw [hl2] at hy + dsimp only at hy + have hno : m1.lookup k = none := by + rcases hl1 : m1.lookup k with _ | v + · rfl + · exact absurd ((hdom k).mp (by simp [hl1])) (by simp [hl1']) + rw [hno, hl2] at hx + dsimp only at hx + cases hx + cases hy + exact eqv_refl _ + | some v' => + rw [hl1'] at hy + obtain ⟨v, hv⟩ := Option.isSome_iff_exists.mp ((hdom k).mpr (by simp [hl1'])) + rw [hv] at hx + cases hl2 : m2.lookup k with + | none => + rw [hl2] at hx hy + dsimp only at hx hy + cases hx + cases hy + exact eqv_symm _ _ (hpay _ _ k hv hl1') + | some w => + rw [hl2] at hx hy + dsimp only at hx hy + cases hx + cases hy + exact eqv_symm _ _ (hcong _ _ _ k hv hl1' hl2) + rw [merge.eq_def, merge.eq_def, eqv.eq_def] + simp only [Bool.and_eq_true] + simp only [List.all_eq_true, List.contains_iff_mem] at h1 h2 + refine ⟨⟨⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩, ?_⟩, ?_⟩ + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + exact fun x hx => hx.imp (fun hm => by simpa using h1 x hm) id + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + exact fun x hx => hx.imp (fun hm => by simpa using h2 x hm) id + · rcases r1 with _ | m1 <;> rcases r1' with _ | m1' <;> + first + | (simp at hr; done) + | skip + · rcases rb with _ | mb + · rfl + · simp [subKeys_self] + · rcases rb with _ | mb + · simpa using hr + · have hcong : ∀ x x' y k, m1.lookup k = some x → m1'.lookup k = some x' → + mb.lookup k = some y → eqv (merge pol x y) (merge pol x' y) = true := by + intro x x' y k hx hx' hy + have hszx := lookup_sizeOf hx + have hszx' := lookup_sizeOf hx' + have hszy := lookup_sizeOf hy + have hxx' : eqv x x' = true := + (mapClause_iff.mp (by simpa using hr)).2.1 k x x' hx hx' + exact merge_congr_left pol x x' y hxx' + cases pol + · simpa [unionMap] using hunionC false m1 m1' mb (by simpa using hr) hcong + · simpa using hinterC true m1 m1' mb (by simpa using hr) hcong + · rcases v1 with _ | m1 <;> rcases v1' with _ | m1' <;> + first + | (simp at hv; done) + | skip + · rcases vb with _ | mb + · rfl + · simp [subKeys_self] + · rcases vb with _ | mb + · simpa using hv + · have hcong : ∀ x x' y k, m1.lookup k = some x → m1'.lookup k = some x' → + mb.lookup k = some y → eqv (merge pol x y) (merge pol x' y) = true := by + intro x x' y k hx hx' hy + have hszx := lookup_sizeOf hx + have hszx' := lookup_sizeOf hx' + have hszy := lookup_sizeOf hy + have hxx' : eqv x x' = true := + (mapClause_iff.mp (by simpa using hv)).2.1 k x x' hx hx' + exact merge_congr_left pol x x' y hxx' + cases pol + · simpa using hinterC false m1 m1' mb (by simpa using hv) hcong + · simpa [unionMap] using hunionC true m1 m1' mb (by simpa using hv) hcong + · rcases f1 with _ | s1 <;> rcases f1' with _ | s1' <;> + first + | (simp at hf; done) + | skip + · rcases fb with _ | sb + · rfl + · simpa [domsEqv] using funClause_of_funEqv (funEqv_refl sb) + · rcases fb with _ | sb + · simpa using hf + · obtain ⟨k1, d1, cod1⟩ := s1 + obtain ⟨k1', d1', cod1'⟩ := s1' + simp only [Bool.and_eq_true] at hf + obtain ⟨⟨hk, hd⟩, hcod⟩ := hf + have hk' : k1 = k1' := by simpa using hk + have hsz : sizeOf (k1, d1, cod1) + sizeOf (k1', d1', cod1') + sizeOf sb < + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) + + sizeOf (CTy.mk a1' r1' v1' (some (k1', d1', cod1')) c1') + + sizeOf (CTy.mk b1 rb vb (some sb) cb) := by + simp + omega + have hde : FunEqv (k1, d1, cod1) (k1', d1', cod1') := + ⟨hk', domsEqv_iff_and.mpr hd, hcod⟩ + simpa [domsEqv] using funClause_of_funEqv + (mergeFun_congr_left pol (k1, d1, cod1) (k1', d1', cod1') sb hde) + · exact mergeRefinements_congr_left pol cb hcl +termination_by a a' b => (sizeOf a + sizeOf a' + sizeOf b, 1) +decreasing_by all_goals + first + | (apply Prod.Lex.left; omega) + | (apply Prod.Lex.left; simp; omega) + | (apply Prod.Lex.right; simp; omega) + +theorem mergeFun_congr_left (pol : Bool) : + (s1 s1' sb : KindM × List CTy × CTy) → FunEqv s1 s1' → + FunEqv (mergeFun pol s1 sb) (mergeFun pol s1' sb) + | (k1, d1, c1), (k1', d1', c1'), (kb, db, cb) => by + intro ⟨hk, hd, hc⟩ + subst hk + have hszc : sizeOf c1 + sizeOf c1' + sizeOf cb < + sizeOf (k1, d1, c1) + sizeOf (k1, d1', c1') + sizeOf (kb, db, cb) := by + simp + omega + have hcod : eqv (merge pol c1 cb) (merge pol c1' cb) = true := + merge_congr_left pol c1 c1' cb hc + -- The domain recursion, hoisted so its size bound sits beside its call: the + -- alternatives are members of the slots, which is what bounds them. + have hdom : ∀ x x' y, x ∈ d1 → x' ∈ d1' → y ∈ db → eqv x x' = true → + eqv (merge true x y) (merge true x' y) = true := by + intro x x' y hx hx' hy hxx' + have h1 := List.sizeOf_lt_of_mem hx + have h2 := List.sizeOf_lt_of_mem hx' + have h3 := List.sizeOf_lt_of_mem hy + have hszd : sizeOf x + sizeOf x' + sizeOf y < + sizeOf (k1, d1, c1) + sizeOf (k1, d1', c1') + sizeOf (kb, db, cb) := by + simp + omega + exact merge_congr_left true x x' y hxx' + rw [mergeFun.eq_def, mergeFun.eq_def] + simp only + -- The kinds are equal, so both sides join to the same kind and only the + -- domain and codomain are left to compare. + rcases hkc : joinKind k1 kb == KindM.conflict with _ | _ <;> + simp only [hkc, Bool.false_eq_true, reduceIte] + case true => exact ⟨rfl, domsEqv_refl [], hcod⟩ + cases pol + · -- Negative: the meet. `OneDistinct` is `domsEqv`-invariant, so the two sides + -- are defined together, and their heads are `eqv`-related. + simp only [Bool.false_eq_true, reduceIte] + rcases hm : meetDoms d1 db with _ | ds + · have hm' : meetDoms d1' db = none := by + rcases hm' : meetDoms d1' db with _ | ds' + · rfl + · obtain ⟨ha', hb⟩ := oneDistinct_of_meetDoms hm' + obtain ⟨ds'', hds''⟩ := + meetDoms_isSome_of (oneDistinct_congr (domsEqv_symm hd) ha') hb + rw [hds''] at hm + exact absurd hm (by simp) + rw [hm'] + exact ⟨rfl, domsEqv_refl [], hcod⟩ + · obtain ⟨x, xs, y, ys, ha, hb, hgate, hds⟩ := meetDoms_eq_some hm + rw [Bool.and_eq_true] at hgate + obtain ⟨hoa, hob⟩ := oneDistinct_of_meetDoms hm + obtain ⟨ds', hds'⟩ := meetDoms_isSome_of (oneDistinct_congr hd hoa) hob + obtain ⟨x', xs', y', ys', ha', hb', hgate', hds2⟩ := meetDoms_eq_some hds' + rw [Bool.and_eq_true] at hgate' + -- The two heads are `eqv`: each is the sole distinct alternative of its + -- side, and the sides are `domsEqv`. + have hxx' : eqv x x' = true := by + obtain ⟨h1, _⟩ := domsEqv_iff.mp hd + obtain ⟨w, hw, hxw⟩ := h1 x (by rw [ha]; simp) + exact eqv_trans _ _ _ hxw (all_eqv_head hgate'.1 w (ha' ▸ hw)) + -- The base's head is literally the same on both sides. + have hyy' : y = y' := by + rw [hb] at hb' + exact (List.cons.injEq .. ▸ hb').1 + rw [hds', hds, hds2, hyy'] + exact ⟨rfl, + domsEqv_singleton + (hdom x x' y' (ha ▸ by simp) (ha' ▸ by simp) (hb' ▸ by simp) hxx'), + hcod⟩ + · -- Positive: the union is a congruence because its dedup gate is `eqv`. + simp only [reduceIte] + exact ⟨rfl, unionDoms_congr_left db hd, hcod⟩ +termination_by s1 s1' sb => (sizeOf s1 + sizeOf s1' + sizeOf sb, 0) +decreasing_by all_goals + first + | (apply Prod.Lex.left; assumption) + | (apply Prod.Lex.left; omega) + | (apply Prod.Lex.left; simp; omega) + | (apply Prod.Lex.right; simp; omega) + +end + +/-- Congruence in the right argument (via commutativity). -/ +theorem merge_congr_right (pol : Bool) (a b b' : CTy) (h : eqv b b' = true) : + eqv (merge pol a b) (merge pol a b') = true := + eqv_trans _ _ _ (merge_comm pol a b) + (eqv_trans _ _ _ (merge_congr_left pol b b' a h) (merge_comm pol b' a)) + +/-- Full congruence. -/ +theorem merge_congr (pol : Bool) {a a' b b' : CTy} + (ha : eqv a a' = true) (hb : eqv b b' = true) : + eqv (merge pol a b) (merge pol a' b') = true := + eqv_trans _ _ _ (merge_congr_left pol a a' b ha) (merge_congr_right pol a' b b' hb) + +/-! ## Associativity + +The kinds join in a semilattice and the domains are combined by polarity alone +([`mergeFun`]), so no step of the fold reads a value that a later step can +change, and the merge is associative with no side condition. That is what makes +the fold below a function of the bound *set*. + +An earlier rule selected the domain combination from the slot's kind, and that +was **not** associative: three bounds at one position — a `data` function over +one domain and two whose kind variable nothing had pinned, over two others — +merged to a conflict in one association and to an accepted `data` function in +another, whose domain was the meet of two of the three. `compact.rs` now defers +that choice to `coalesce_compact_go`, where the kind is resolved +(`undetermined_kinds_join_without_deciding_the_domain_rule` pins the exhibit). -/ + +/-- A negative merge whose domain meet is undefined is the conflicted slot — the +same shape a conflicted kind produces. -/ +theorem mergeFun_neg_none (s1 s2 : KindM × List CTy × CTy) + (h : meetDoms s1.2.1 s2.2.1 = none) : + mergeFun false s1 s2 = (.conflict, [], merge false s1.2.2 s2.2.2) := by + obtain ⟨k1, d1, c1⟩ := s1 + obtain ⟨k2, d2, c2⟩ := s2 + rw [mergeFun.eq_def] + dsimp only + split + · rfl + · simp only [Bool.false_eq_true, reduceIte] + rw [h] + +/-- A merged slot's kind is the kinds' join, or a conflict the domains forced +(the negative meet has no single domain to take). -/ +theorem mergeFun_kind (pol : Bool) (s1 s2 : KindM × List CTy × CTy) : + (mergeFun pol s1 s2).1 = joinKind s1.1 s2.1 ∨ (mergeFun pol s1 s2).1 = .conflict := by + obtain ⟨k1, d1, c1⟩ := s1 + obtain ⟨k2, d2, c2⟩ := s2 + rw [mergeFun.eq_def] + dsimp only + split + · rename_i hc + exact Or.inr rfl + · split + · exact Or.inl rfl + · split + · exact Or.inl rfl + · exact Or.inr rfl + +/-- `joinKind` is absorbed by a conflict on either side. -/ +theorem joinKind_conflict_left (k : KindM) : joinKind .conflict k = .conflict := by + cases k <;> rfl + +theorem joinKind_conflict_right (k : KindM) : joinKind k .conflict = .conflict := by + cases k <;> rfl + +mutual + +theorem merge_assoc (pol : Bool) : + (a b c : CTy) → + eqv (merge pol (merge pol a b) c) (merge pol a (merge pol b c)) = true + | .mk a1 r1 v1 f1 c1, .mk a2 r2 v2 f2 c2, .mk a3 r3 v3 f3 c3 => by + -- Pointwise associativity for the two keyed merges. + have hinterA : ∀ (p : Bool) (m1 m2 m3 : List (FieldKey × CTy)), + (∀ x y z k, m1.lookup k = some x → m2.lookup k = some y → m3.lookup k = some z → + eqv (merge p (merge p x y) z) (merge p x (merge p y z)) = true) → + (subKeys (interMap p (interMap p m1 m2) m3) (interMap p m1 (interMap p m2 m3)) + ((interMap p (interMap p m1 m2) m3).map Prod.fst) && + subKeys (interMap p m1 (interMap p m2 m3)) (interMap p (interMap p m1 m2) m3) + ((interMap p m1 (interMap p m2 m3)).map Prod.fst)) = true := by + intro p m1 m2 m3 hassoc + rw [mapClause_iff] + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [interMap_lookup, interMap_lookup, interMap_lookup, interMap_lookup] + rcases m1.lookup k with _ | v <;> rcases m2.lookup k with _ | w <;> + rcases m3.lookup k with _ | u <;> simp + · rw [interMap_lookup, interMap_lookup] at hx + rw [interMap_lookup, interMap_lookup] at hy + rcases h1 : m1.lookup k with _ | v <;> rw [h1] at hx hy <;> + rcases h2 : m2.lookup k with _ | w <;> rw [h2] at hx hy <;> + rcases h3 : m3.lookup k with _ | u <;> rw [h3] at hx hy <;> + dsimp only at hx hy <;> + first + | (simp only [reduceCtorEq] at hx) + | (cases hx; cases hy; exact hassoc _ _ _ k h1 h2 h3) + · rw [interMap_lookup, interMap_lookup] at hx + rw [interMap_lookup, interMap_lookup] at hy + rcases h1 : m1.lookup k with _ | v <;> rw [h1] at hx hy <;> + rcases h2 : m2.lookup k with _ | w <;> rw [h2] at hx hy <;> + rcases h3 : m3.lookup k with _ | u <;> rw [h3] at hx hy <;> + dsimp only at hx hy <;> + first + | (simp only [reduceCtorEq] at hx) + | (cases hx; cases hy; exact eqv_symm _ _ (hassoc _ _ _ k h1 h2 h3)) + have hunionA : ∀ (p : Bool) (m1 m2 m3 : List (FieldKey × CTy)), + (∀ x y z k, m1.lookup k = some x → m2.lookup k = some y → m3.lookup k = some z → + eqv (merge p (merge p x y) z) (merge p x (merge p y z)) = true) → + (subKeys (unionMap p (unionMap p m1 m2) m3) (unionMap p m1 (unionMap p m2 m3)) + ((unionMap p (unionMap p m1 m2) m3).map Prod.fst) && + subKeys (unionMap p m1 (unionMap p m2 m3)) (unionMap p (unionMap p m1 m2) m3) + ((unionMap p m1 (unionMap p m2 m3)).map Prod.fst)) = true := by + intro p m1 m2 m3 hassoc + rw [mapClause_iff] + refine ⟨fun k => ?_, fun k x y hx hy => ?_, fun k x y hx hy => ?_⟩ + · rw [unionMap_lookup, unionMap_lookup, unionMap_lookup, unionMap_lookup] + rcases m1.lookup k with _ | v <;> rcases m2.lookup k with _ | w <;> + rcases m3.lookup k with _ | u <;> simp + · rw [unionMap_lookup, unionMap_lookup] at hx + rw [unionMap_lookup, unionMap_lookup] at hy + rcases h1 : m1.lookup k with _ | v <;> rw [h1] at hx hy <;> + rcases h2 : m2.lookup k with _ | w <;> rw [h2] at hx hy <;> + rcases h3 : m3.lookup k with _ | u <;> rw [h3] at hx hy <;> + dsimp only at hx hy <;> + first + | (simp only [reduceCtorEq] at hx) + | (cases hx; cases hy; + first + | exact eqv_refl _ + | exact hassoc _ _ _ k h1 h2 h3) + · rw [unionMap_lookup, unionMap_lookup] at hx + rw [unionMap_lookup, unionMap_lookup] at hy + rcases h1 : m1.lookup k with _ | v <;> rw [h1] at hx hy <;> + rcases h2 : m2.lookup k with _ | w <;> rw [h2] at hx hy <;> + rcases h3 : m3.lookup k with _ | u <;> rw [h3] at hx hy <;> + dsimp only at hx hy <;> + first + | (simp only [reduceCtorEq] at hx) + | (cases hx; cases hy; + first + | exact eqv_refl _ + | exact eqv_symm _ _ (hassoc _ _ _ k h1 h2 h3)) + rw [merge.eq_def, merge.eq_def, merge.eq_def, merge.eq_def, eqv.eq_def] + dsimp only + simp only [Bool.and_eq_true] + refine ⟨⟨⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩, ?_⟩, ?_⟩ + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + exact fun x hx => by simpa [or_assoc] using hx + · simp only [List.all_eq_true, List.contains_iff_mem, List.mem_append] + exact fun x hx => by simpa [or_assoc] using hx + · rcases r1 with _ | m1 <;> rcases r2 with _ | m2 <;> rcases r3 with _ | m3 <;> + first + | rfl + | (simp [subKeys_self]; done) + | skip + have hassoc : ∀ x y z k, m1.lookup k = some x → m2.lookup k = some y → + m3.lookup k = some z → + eqv (merge pol (merge pol x y) z) (merge pol x (merge pol y z)) = true := by + intro x y z k hx hy hz + have hszx := lookup_sizeOf hx + have hszy := lookup_sizeOf hy + have hszz := lookup_sizeOf hz + exact merge_assoc pol x y z + cases pol + · simpa [unionMap] using hunionA false m1 m2 m3 hassoc + · simpa using hinterA true m1 m2 m3 hassoc + · rcases v1 with _ | m1 <;> rcases v2 with _ | m2 <;> rcases v3 with _ | m3 <;> + first + | rfl + | (simp [subKeys_self]; done) + | skip + have hassoc : ∀ x y z k, m1.lookup k = some x → m2.lookup k = some y → + m3.lookup k = some z → + eqv (merge pol (merge pol x y) z) (merge pol x (merge pol y z)) = true := by + intro x y z k hx hy hz + have hszx := lookup_sizeOf hx + have hszy := lookup_sizeOf hy + have hszz := lookup_sizeOf hz + exact merge_assoc pol x y z + cases pol + · simpa using hinterA false m1 m2 m3 hassoc + · simpa [unionMap] using hunionA true m1 m2 m3 hassoc + · rcases f1 with _ | s1 <;> rcases f2 with _ | s2 <;> rcases f3 with _ | s3 <;> + first + | rfl + | (simpa [domsEqv] using funClause_of_funEqv (funEqv_refl _)) + | skip + obtain ⟨k1, d1, cod1⟩ := s1 + obtain ⟨k2, d2, cod2⟩ := s2 + obtain ⟨k3, d3, cod3⟩ := s3 + have hsz : sizeOf (k1, d1, cod1) + sizeOf (k2, d2, cod2) + sizeOf (k3, d3, cod3) < + sizeOf (CTy.mk a1 r1 v1 (some (k1, d1, cod1)) c1) + + sizeOf (CTy.mk a2 r2 v2 (some (k2, d2, cod2)) c2) + + sizeOf (CTy.mk a3 r3 v3 (some (k3, d3, cod3)) c3) := by + simp + omega + simpa [domsEqv] using funClause_of_funEqv + (mergeFun_assoc pol (k1, d1, cod1) (k2, d2, cod2) (k3, d3, cod3)) + · exact mergeRefinements_assoc pol c1 c2 c3 +termination_by a b c => (sizeOf a + sizeOf b + sizeOf c, 1) +decreasing_by all_goals + first + | (apply Prod.Lex.left; omega) + | (apply Prod.Lex.left; simp; omega) + | (apply Prod.Lex.right; simp; omega) + +theorem mergeFun_assoc (pol : Bool) : + (s1 s2 s3 : KindM × List CTy × CTy) → + FunEqv (mergeFun pol (mergeFun pol s1 s2) s3) (mergeFun pol s1 (mergeFun pol s2 s3)) + | (k1, d1, c1), (k2, d2, c2), (k3, d3, c3) => by + have hszc : sizeOf c1 + sizeOf c2 + sizeOf c3 < + sizeOf (k1, d1, c1) + sizeOf (k2, d2, c2) + sizeOf (k3, d3, c3) := by + simp + omega + have hcod : eqv (merge pol (merge pol c1 c2) c3) (merge pol c1 (merge pol c2 c3)) = true := + merge_assoc pol c1 c2 c3 + -- The domain recursion, hoisted so its size bound sits beside its call. + have hassoc : ∀ x y z, x ∈ d1 → y ∈ d2 → z ∈ d3 → + eqv (merge true (merge true x y) z) (merge true x (merge true y z)) = true := by + intro x y z hx hy hz + have h1 := List.sizeOf_lt_of_mem hx + have h2 := List.sizeOf_lt_of_mem hy + have h3 := List.sizeOf_lt_of_mem hz + have hszd : sizeOf x + sizeOf y + sizeOf z < + sizeOf (k1, d1, c1) + sizeOf (k2, d2, c2) + sizeOf (k3, d3, c3) := by + simp + omega + exact merge_assoc true x y z + have hK : joinKind (joinKind k1 k2) k3 = joinKind k1 (joinKind k2 k3) := + joinKind_assoc k1 k2 k3 + rcases hk : joinKind (joinKind k1 k2) k3 with _ | _ | _ | _ + -- The three kinds join to a conflict: absorbing, so whichever pairwise join + -- the association takes first, both outer slots are the conflicted one. + case conflict => + have hl : mergeFun pol (mergeFun pol (k1, d1, c1) (k2, d2, c2)) (k3, d3, c3) = + (.conflict, [], merge pol (merge pol c1 c2) c3) := by + have := mergeFun_of_conflict pol (mergeFun pol (k1, d1, c1) (k2, d2, c2)) (k3, d3, c3) + (by + rcases mergeFun_kind pol (k1, d1, c1) (k2, d2, c2) with h | h + · simpa only [h] using hk + · simpa only [h] using joinKind_conflict_left k3) + rw [this, mergeFun_cod] + have hr : mergeFun pol (k1, d1, c1) (mergeFun pol (k2, d2, c2) (k3, d3, c3)) = + (.conflict, [], merge pol c1 (merge pol c2 c3)) := by + have := mergeFun_of_conflict pol (k1, d1, c1) (mergeFun pol (k2, d2, c2) (k3, d3, c3)) + (by + rcases mergeFun_kind pol (k2, d2, c2) (k3, d3, c3) with h | h + · simpa only [h] using hK.symm.trans hk + · simpa only [h] using joinKind_conflict_right k1) + rw [this, mergeFun_cod] + rw [hl, hr] + exact ⟨rfl, domsEqv_refl [], hcod⟩ + all_goals + -- No conflict anywhere: a conflicted pairwise join would absorb into `hk`, + -- so both inner merges carry the joined kind and both sides reduce. + have h12 : (joinKind k1 k2 == KindM.conflict) = false := by + rcases h : joinKind k1 k2 with _ | _ | _ | _ + case conflict => + rw [h, joinKind_conflict_left] at hk + simp at hk + all_goals rfl + have h23 : (joinKind k2 k3 == KindM.conflict) = false := by + rcases h : joinKind k2 k3 with _ | _ | _ | _ + case conflict => + rw [hK, h, joinKind_conflict_right] at hk + simp at hk + all_goals rfl + have hkl : (joinKind (joinKind k1 k2) k3 == KindM.conflict) = false := by + rw [hk]; rfl + have hkr : (joinKind k1 (joinKind k2 k3) == KindM.conflict) = false := by + rw [← hK, hk]; rfl + cases pol + · -- Negative: nested contravariant meets. Both nestings are defined exactly + -- when all three slots have one distinct alternative, and otherwise both + -- conflict — whichever slot is the culprit. + by_cases hd1 : OneDistinct d1 + · by_cases hd2 : OneDistinct d2 + · by_cases hd3 : OneDistinct d3 + · obtain ⟨_, h12s⟩ := meetDoms_isSome_of hd1 hd2 + obtain ⟨x, xs, y, ys, ha1, ha2, _, hds12⟩ := meetDoms_eq_some h12s + obtain ⟨_, h23s⟩ := meetDoms_isSome_of hd2 hd3 + obtain ⟨y', ys', z, zs, ha2', ha3, _, hds23⟩ := meetDoms_eq_some h23s + -- Both decompositions of `d2` are the same cons, so they name one head. + have hy : y = y' := by + rw [ha2] at ha2' + exact (List.cons.injEq .. ▸ ha2').1 + -- Reduce each inner slot first, so the outer kind test is a `joinKind` + -- the kind facts decide. + have hil : mergeFun false (k1, d1, c1) (k2, d2, c2) + = (joinKind k1 k2, [merge true x y], merge false c1 c2) := by + rw [mergeFun.eq_def] + simp only [h12, Bool.false_eq_true, reduceIte, h12s, hds12] + have hir : mergeFun false (k2, d2, c2) (k3, d3, c3) + = (joinKind k2 k3, [merge true y z], merge false c2 c3) := by + rw [mergeFun.eq_def] + simp only [h23, Bool.false_eq_true, reduceIte, h23s, hds23, ← hy] + rw [hil, hir, mergeFun.eq_def, mergeFun.eq_def] + simp only [hkl, hkr, Bool.false_eq_true, reduceIte] + rw [show meetDoms [merge true x y] d3 + = some [merge true (merge true x y) z] from by + rw [ha3] + exact meetDoms_of_gate (by + rw [Bool.and_eq_true] + exact ⟨by simp [subDoms], gate_of_oneDistinct (ha3 ▸ hd3)⟩), + show meetDoms d1 [merge true y z] + = some [merge true x (merge true y z)] from by + rw [ha1] + exact meetDoms_of_gate (by + rw [Bool.and_eq_true] + exact ⟨gate_of_oneDistinct (ha1 ▸ hd1), by simp [subDoms]⟩)] + exact ⟨by rw [hK], + domsEqv_singleton + (hassoc x y z (ha1 ▸ by simp) (ha2 ▸ by simp) (ha3 ▸ by simp)), + hcod⟩ + · -- `d3` has no single alternative: the left's outer meet is undefined, + -- and the right's inner one is. + rw [mergeFun_neg_none (k2, d2, c2) (k3, d3, c3) (meetDoms_none_of_right hd3), + mergeFun_of_conflict false (k1, d1, c1) + (KindM.conflict, [], merge false c2 c3) + (by simpa using joinKind_conflict_right k1), + mergeFun_neg_none _ (k3, d3, c3) (meetDoms_none_of_right hd3)] + refine ⟨rfl, domsEqv_refl [], ?_⟩ + simpa [mergeFun_cod] using hcod + · -- `d2` fails on both sides: as the right argument of one inner meet and + -- the left argument of the other. + rw [mergeFun_neg_none (k1, d1, c1) (k2, d2, c2) (meetDoms_none_of_right hd2), + mergeFun_neg_none (k2, d2, c2) (k3, d3, c3) (meetDoms_none_of_left hd2), + mergeFun_of_conflict false (KindM.conflict, [], merge false c1 c2) (k3, d3, c3) + (by simpa using joinKind_conflict_left k3), + mergeFun_of_conflict false (k1, d1, c1) + (KindM.conflict, [], merge false c2 c3) + (by simpa using joinKind_conflict_right k1)] + refine ⟨rfl, domsEqv_refl [], ?_⟩ + simpa [mergeFun_cod] using hcod + · -- `d1` fails: the left's inner meet is undefined, the right's outer one is. + rw [mergeFun_neg_none (k1, d1, c1) (k2, d2, c2) (meetDoms_none_of_left hd1), + mergeFun_of_conflict false (KindM.conflict, [], merge false c1 c2) (k3, d3, c3) + (by simpa using joinKind_conflict_left k3), + mergeFun_neg_none (k1, d1, c1) _ (meetDoms_none_of_left hd1)] + refine ⟨rfl, domsEqv_refl [], ?_⟩ + simpa [mergeFun_cod] using hcod + · -- Positive: the alternatives are a set, and set union is associative. + simp only [mergeFun.eq_def, h12, h23, hkl, hkr, joinKind_conflict_left, + joinKind_conflict_right, Bool.false_eq_true, reduceIte, beq_self_eq_true, if_true] + exact ⟨by rw [hK], unionDoms_assoc d1 d2 d3, hcod⟩ +termination_by s1 s2 s3 => (sizeOf s1 + sizeOf s2 + sizeOf s3, 0) +decreasing_by all_goals + first + | (apply Prod.Lex.left; omega) + | (apply Prod.Lex.left; simp; omega) + | (apply Prod.Lex.right; simp; omega) + +end + +/-! ## The fold: coalescing a bound list is order- and duplicate-invariant + +`compact_go` folds a variable's bounds through `merge` from the first bound +(no identity element exists — see the module docs). The outcome is a function of +the bound *set*: permutations (`foldMerge_perm`) cannot change it, and neither +can duplicates (`foldMerge_dup`, which needs `wf` on the repeated bound because +idempotence does). This is the algebraic statement behind the type-merge fuzz's +\"outcomes agree under permuted constraint orders\". -/ + +/-- The fold `compact_go` performs over a variable's bound list, seeded at the +first bound. -/ +def foldMerge (pol : Bool) (t : CTy) (ts : List CTy) : CTy := + ts.foldl (merge pol) t + +/-- The fold respects `eqv` in its seed (any polarity). -/ +theorem foldMerge_congr (pol : Bool) {t t' : CTy} (ts : List CTy) (h : eqv t t' = true) : + eqv (foldMerge pol t ts) (foldMerge pol t' ts) = true := by + induction ts generalizing t t' with + | nil => exact h + | cons x ts ih => exact ih (merge_congr_left pol t t' x h) + +/-- **Order-invariance**: permuting the bound list cannot change the coalesced +outcome (up to `eqv`), at either polarity and with no side condition. -/ +theorem foldMerge_perm (pol : Bool) {l1 l2 : List CTy} (h : l1.Perm l2) : + ∀ (t : CTy), eqv (foldMerge pol t l1) (foldMerge pol t l2) = true := by + induction h with + | nil => exact fun t => eqv_refl _ + | @cons x l1 l2 hp ih => exact fun t => ih (merge pol t x) + | @swap x y l => + intro t + -- merge (merge t y) x ~ merge t (merge y x) ~ merge t (merge x y) + -- ~ merge (merge t x) y + have hseed : eqv (merge pol (merge pol t y) x) (merge pol (merge pol t x) y) = true := + eqv_trans _ _ _ (merge_assoc pol t y x) + (eqv_trans _ _ _ (merge_congr_right pol t _ _ (merge_comm pol y x)) + (eqv_symm _ _ (merge_assoc pol t x y))) + simpa [foldMerge, List.foldl_cons] using foldMerge_congr pol l hseed + | @trans l1 l2 l3 h12 h23 ih1 ih2 => exact fun t => eqv_trans _ _ _ (ih1 t) (ih2 t) + +/-- **Duplicate-invariance**: a bound occurring twice contributes once — the +other half of \"the outcome is a function of the bound set\". Needs `wf` for +the duplicated bound (idempotence does). -/ +theorem foldMerge_dup (pol : Bool) {t x : CTy} (l : List CTy) (hwx : wf x = true) : + eqv (foldMerge pol t (x :: x :: l)) (foldMerge pol t (x :: l)) = true := by + -- merge (merge t x) x ~ merge t (merge x x) ~ merge t x + have hseed : eqv (merge pol (merge pol t x) x) (merge pol t x) = true := + eqv_trans _ _ _ (merge_assoc pol t x x) + (merge_congr_right pol t _ _ (merge_idem pol x hwx)) + simpa [foldMerge, List.foldl_cons] using foldMerge_congr pol l hseed + +/-! ## The order the merge induces, and uniqueness + +`merge pol` is commutative, associative and idempotent, so it comes with an +order: `le pol a b` reads "merging `a` into `b` adds nothing". `merge pol` is that +order's least upper bound, and any least upper bound is `eqv`-equal to it +(`join_unique`). + +The scope is narrow and worth stating. These proofs use only commutativity, +associativity, idempotence and congruence, so they are the semilattice-to-poset +correspondence and carry exactly that content — `merge` is a join *of the order it +defines*. That it is the join with respect to **subtyping** is a different +statement, needing a denotation into a lattice of types, and it is not made here +(`formal/design.md`, "M4c — the lattice, and what a merge means *(planned)*"). + +Absorption and distributivity hold of the types and are not stated here, because +`CTy` is the wrong carrier for them. There is one type lattice, and `merge true` +computes its join while `merge false` computes its meet; what is polarity-indexed +is the *denotation*. One `CTy` denotes two types — a contribution set is the union +of its contributions read positively and their intersection read negatively — so +`CTy` is one syntax carrying two representations rather than a lattice carrier. + +Writing `a ⊓ (a ⊔ b) = a` over `CTy` needs one syntactic `a` in both a join +argument (read positively) and a meet argument (read negatively), which needs +`⟦a⟧⁺ = ⟦a⟧⁻`. That holds for a single contribution (`{Int}` is `Int` either way) +and fails once a set holds two, which is the case the law is about. So the laws +proved here are the ones a single polarity's operation has, and the cross-polarity +laws wait on a carrier where both operations act on the same object +(`formal/design.md`, "M4c — the lattice, and what a merge means *(planned)*"). + +Reflexivity needs `wf` because idempotence does; nothing else here has a side +condition. -/ + +/-- The empty position: no contribution at any slot, which is what a `Hole` +compacts to (`CompactType::empty`). -/ +def cempty : CTy := .mk [] none none none none + +/-- The empty position is the merge identity, at either polarity. Every slot's +`none` is its own identity, the atom list unions, and the refinement slot's sentinel +supplies the one the refinement *set* cannot (an empty set is absorbing under the +positive intersect, not neutral) — so the merged position is the other side +itself, not merely `eqv` to it. `compact_go` still folds from the first bound, +but nothing in the algebra requires that any more. -/ +theorem merge_cempty_left (pol : Bool) (a : CTy) : merge pol cempty a = a := by + rcases a with ⟨a1, r1, v1, f1, c1⟩ + rw [merge.eq_def] + rfl + +theorem merge_cempty_right (pol : Bool) (a : CTy) : eqv (merge pol a cempty) a = true := by + exact eqv_trans _ _ _ (merge_comm pol a cempty) + (by rw [merge_cempty_left]; exact eqv_refl a) + +/-- The order `merge pol` induces: `a ≤ b` when merging `a` into `b` adds +nothing. -/ +def le (pol : Bool) (a b : CTy) : Prop := eqv (merge pol a b) b = true + +theorem le_refl (pol : Bool) {a : CTy} (h : wf a = true) : le pol a a := + merge_idem pol a h + +theorem le_trans (pol : Bool) {a b c : CTy} (hab : le pol a b) (hbc : le pol b c) : + le pol a c := by + -- a ⊔ c ~ a ⊔ (b ⊔ c) ~ (a ⊔ b) ⊔ c ~ b ⊔ c ~ c + have h1 : eqv (merge pol a c) (merge pol a (merge pol b c)) = true := + merge_congr_right pol a c (merge pol b c) (eqv_symm _ _ hbc) + have h2 : eqv (merge pol a (merge pol b c)) (merge pol (merge pol a b) c) = true := + eqv_symm _ _ (merge_assoc pol a b c) + have h3 : eqv (merge pol (merge pol a b) c) c = true := + eqv_trans _ _ _ (merge_congr_left pol (merge pol a b) b c hab) hbc + exact eqv_trans _ _ _ h1 (eqv_trans _ _ _ h2 h3) + +/-- Antisymmetry up to `eqv`: the order is a partial order on the quotient. -/ +theorem le_antisymm (pol : Bool) {a b : CTy} (hab : le pol a b) (hba : le pol b a) : + eqv a b = true := + eqv_trans _ _ _ (eqv_symm _ _ hba) (eqv_trans _ _ _ (merge_comm pol b a) hab) + +/-- `merge pol a b` is an upper bound of `a`. -/ +theorem le_merge_left (pol : Bool) (a b : CTy) (ha : wf a = true) : + le pol a (merge pol a b) := by + -- a ⊔ (a ⊔ b) ~ (a ⊔ a) ⊔ b ~ a ⊔ b + exact eqv_trans _ _ _ (eqv_symm _ _ (merge_assoc pol a a b)) + (merge_congr_left pol (merge pol a a) a b (merge_idem pol a ha)) + +/-- …and of `b`. -/ +theorem le_merge_right (pol : Bool) (a b : CTy) (hb : wf b = true) : + le pol b (merge pol a b) := + eqv_trans _ _ _ (merge_congr_right pol b (merge pol a b) (merge pol b a) + (merge_comm pol a b)) + (eqv_trans _ _ _ (le_merge_left pol b a hb) (merge_comm pol b a)) + +/-- …and it is the *least* one: anything above both is above it. No side +condition — this is associativity and congruence alone. -/ +theorem merge_le (pol : Bool) {a b c : CTy} (ha : le pol a c) (hb : le pol b c) : + le pol (merge pol a b) c := + eqv_trans _ _ _ (merge_assoc pol a b c) + (eqv_trans _ _ _ (merge_congr_right pol a (merge pol b c) c hb) ha) + +/-- Least upper bound, spelled out. -/ +def IsLub (pol : Bool) (a b m : CTy) : Prop := + le pol a m ∧ le pol b m ∧ ∀ u : CTy, le pol a u → le pol b u → le pol m u + +/-- `cempty` is the order's least element: it is below everything, with no side +condition (`le_refl` needs `wf`; this does not). -/ +theorem le_cempty (pol : Bool) (a : CTy) : le pol cempty a := by + rw [le, merge_cempty_left] + exact eqv_refl a + +theorem merge_isLub (pol : Bool) (a b : CTy) (ha : wf a = true) (hb : wf b = true) : + IsLub pol a b (merge pol a b) := + ⟨le_merge_left pol a b ha, le_merge_right pol a b hb, fun _ hau hbu => merge_le pol hau hbu⟩ + +/-- **Uniqueness**: a least upper bound of two positions is the merge, up to +`eqv`. The merge is not *a* way to combine two bounds; it is the only one the +order admits. -/ +theorem join_unique (pol : Bool) {a b m : CTy} (ha : wf a = true) (hb : wf b = true) + (h : IsLub pol a b m) : eqv m (merge pol a b) = true := + le_antisymm pol + (h.2.2 (merge pol a b) (le_merge_left pol a b ha) (le_merge_right pol a b hb)) + (merge_le pol h.1 h.2.1) + +end CTy + +end CclFormal diff --git a/formal/CclFormal/Props.lean b/formal/CclFormal/Props.lean new file mode 100644 index 00000000..51dbdc90 --- /dev/null +++ b/formal/CclFormal/Props.lean @@ -0,0 +1,136 @@ +import CclFormal.Sub + +/-! +# First metatheory: reflexivity + +`constrain_go` opens with a trivial-equality short-circuit (`lhs == rhs` +under identity morphisms → `Ok`). The model deliberately has no such rule; +`Sub.refl` proves it *derivable* — which is the faithfulness condition for +omitting it. The proof goes through only for `Ty.WF` (uniquely-keyed) types: +on a duplicate-keyed record the short-circuit and the find-first record arm +genuinely disagree, so the hypothesis is the model naming a builder +invariant the Rust leaves implicit. + +With refinements closed into indices this file is most of what the rename machinery's +deletion buys: the old proof threaded identity-acting morphisms through +every rule (`Ren.IsId`, its preservation under the diagonal codomain +extension, and predicate-transport invariance); with refinements closed there is +no transport, and reflexivity needs only well-formedness. +-/ + +namespace CclFormal + +/-- Identical refinement sets have no deficit. -/ +theorem deficit_self (S : List Pred) : deficit S S = [] := by + unfold deficit + apply List.filter_eq_nil_iff.mpr + intro r hm + simpa using hm + +/-- Find-first lookup returns the member itself when keys are unique. -/ +theorem lookupBy_of_mem_nodup [BEq α] [LawfulBEq α] {l : List (α × Ty)} + {k : α} {t : Ty} (hnd : (l.map (·.1)).Nodup) (hm : (k, t) ∈ l) : + lookupBy l k = some t := by + induction l with + | nil => cases hm + | cons e rest ih => + obtain ⟨a, u⟩ := e + have hnd' : (∀ (x : Ty), (a, x) ∉ rest) ∧ + (List.map (fun x => x.fst) rest).Nodup := by simpa using hnd + rcases List.mem_cons.mp hm with heq | hmem + · injection heq with h1 h2 + subst h1; subst h2 + simp [lookupBy] + · have hak : (a == k) = false := by + cases hab : a == k with + | false => rfl + | true => + have ha : a = k := eq_of_beq hab + subst ha + exact absurd hmem (hnd'.1 t) + have hfind : ((a, u) :: rest).find? (fun e => e.1 == k) = + rest.find? (fun e => e.1 == k) := by + rw [List.find?_cons_of_neg] + simpa using hak + have := ih hnd'.2 hmem + unfold lookupBy at this ⊢ + rw [hfind] + exact this + +/-- The refined case's termination shape: peeling the base stays under the +refined node's size, whatever the predicate contributes. -/ +theorem Ty.peel_fst_lt_one_add (b : Ty) (n : Nat) : + sizeOf b.peel.1 < 1 + sizeOf b + n := by + have := Ty.peel_fst_sizeOf_le b + omega + +/-- Peeling preserves well-formedness. -/ +theorem Ty.WF.peel_fst : {t : Ty} → t.WF → t.peel.1.WF + | .base _, h | .uintRange _, h | .dataSource _, h | .txn, h + | .fn .., h | .tuple _, h | .record _, h | .variant _, h => by + simpa [Ty.peel] using h + | .refined _ _, .refined _ _ hb => by + simpa [Ty.peel] using hb.peel_fst + +/-- **Reflexivity is derivable** (for uniquely-keyed types): the model needs +no analog of `constrain_go`'s trivial-equality short-circuit. -/ +theorem Sub.refl : (t : Ty) → t.WF → Sub t t + | .base b, _ => .base b + | .uintRange n, _ => .uintRange n + | .dataSource s, _ => .dataSource s + | .txn, _ => .txn + | .fn n k d c, hwf => by + cases hwf with + | fn hd hc => + have hcod := Sub.refl c hc + cases k with + | data => exact .fnData (Sub.refl d hd) (Sub.refl d hd) hcod + | compute => + exact .fnCompute trivial (fun h => nomatch h.1) (Sub.refl d hd) hcod + | .tuple ts, hwf => by + cases hwf with + | tuple hts => + refine .tuple (Nat.le_refl _) fun i t0 t1 h0 h1 => ?_ + rw [h0] at h1 + injection h1 with h + subst h + have hm : t0 ∈ ts := List.mem_of_getElem? h0 + have hsz : sizeOf t0 < sizeOf ts := List.sizeOf_lt_of_mem hm + exact Sub.refl t0 (hts t0 hm) + | .record fs, hwf => by + cases hwf with + | record hnd hf => + refine .record (fun n t1 hm => ?_) (fun n t0 t1 hm hlk => ?_) + · rw [lookupBy_of_mem_nodup hnd hm]; rfl + · rw [lookupBy_of_mem_nodup hnd hm] at hlk + injection hlk with h + subst h + exact Sub.refl t1 (hf (n, t1) hm) + | .variant tags, hwf => by + cases hwf with + | variant hnd ht => + refine .variant (fun k t0 hm => ?_) (fun k t0 t1 hm hlk => ?_) + · rw [lookupBy_of_mem_nodup hnd hm]; rfl + · rw [lookupBy_of_mem_nodup hnd hm] at hlk + injection hlk with h + subst h + exact Sub.refl t0 (ht (k, t0) hm) + | .refined b ps, hwf => by + cases hwf with + | refined hne _ hb => + refine .refined rfl rfl + (.inl (by simp; exact fun hc => absurd hc hne)) + (deficit_self _) ?_ + show Sub b.peel.1 b.peel.1 + exact Sub.refl b.peel.1 (Ty.WF.peel_fst hb) +termination_by t _ => sizeOf t +decreasing_by + all_goals simp_wf + all_goals try simp + all_goals first + | omega + | (have := List.sizeOf_lt_of_mem ‹_ ∈ _›; try simp at this; omega) + | apply Ty.peel_fst_lt_one_add + | (simp at hsz; omega) + +end CclFormal diff --git a/formal/CclFormal/Safety.lean b/formal/CclFormal/Safety.lean new file mode 100644 index 00000000..7e27f05f --- /dev/null +++ b/formal/CclFormal/Safety.lean @@ -0,0 +1,1129 @@ +import CclFormal.Term + +/-! +# M2 — Safety: progress, preservation, and refinement soundness + +The proof battery over `Term.lean`'s judgment: weakening and the +substitution lemma (the de Bruijn payoff), `Sub` inversion and canonical +forms modulo refinement peeling, progress (a well-typed closed term is a +value, steps, or is filter-blocked at a cast), preservation, and the two +corollaries — refinement soundness and case-binder soundness. + +Two structural choices keep the proofs out of transitivity's territory: + +- **`Sub` inversions are case analyses, not inductions.** Every `Sub` + constructor pins both sides' head constructors, and the `refined` arm + recurses on fully-peeled bases — so `Sub.to_peel` (peel both sides) plus + one non-recursive `cases` per head is all the inversion there is. +- **Typing inversions absorb subsumption chains with typing transport, not + `Sub` composition.** Inverting a derivation that ends in `sub` would + otherwise lean on transitivity of `Sub`. Instead `HasTy.lam_inv` returns + implications of the form "whatever is typed at `X` is typed at `Y`" — + reflexive without `Sub.refl`'s `WF` side condition, and composable across + a chain link-by-link, each link re-entering the typing via `HasTy.sub` + directly: the relation carries no environments, so the rename-invariance + lemma this transport used to need is gone with the machinery it + compensated for. +-/ + +namespace CclFormal + +/-! ## Peeling -/ + +theorem Ty.peel_fst_not_refined : (t : Ty) → t.peel.1.isRefined = false + | .refined b _ => by simpa [Ty.peel] using Ty.peel_fst_not_refined b + | .base _ | .uintRange _ | .dataSource _ | .txn + | .fn .. | .tuple _ | .record _ | .variant _ => by simp [Ty.peel, Ty.isRefined] + +theorem Ty.TermFrag.peel_fst : {t : Ty} → t.TermFrag → t.peel.1.TermFrag + | .refined _ _, .refined _ hb => by simpa [Ty.peel] using hb.peel_fst + | .base _, h | .uintRange _, h | .dataSource _, h | .txn, h + | .fn .., h | .tuple _, h | .record _, h | .variant _, h => by + simpa [Ty.peel] using h + +theorem Ty.TermFrag.peel_refinements : {t : Ty} → t.TermFrag → + ∀ p ∈ t.peel.2, p.elemOnly = true + | .refined _ _, .refined hps hb => by + intro p hp + simp [Ty.peel] at hp + rcases hp with hp | hp + · exact hps p hp + · exact hb.peel_refinements p hp + | .base _, h | .uintRange _, h | .dataSource _, h | .txn, h + | .fn .., h | .tuple _, h | .record _, h | .variant _, h => by + simp [Ty.peel] + +/-! ## The deficit is refinement containment -/ + +/-- An empty deficit is refinement containment. -/ +theorem deficit_nil_mono {l r : List Pred} (h : deficit l r = []) : + ∀ p ∈ r, p ∈ l := by + intro p hp + unfold deficit at h + rw [List.filter_eq_nil_iff] at h + have hc := h p hp + simpa using hc + +/-! ## Keyed lookup bridges + +The typing rules use `List.lookup`, the relation's arms use `lookupBy` — +both are find-first by key, and the proofs cross between them. -/ + +theorem lookupBy_eq_lookup {α} [BEq α] [LawfulBEq α] + (l : List (α × Ty)) (k : α) : lookupBy l k = l.lookup k := by + induction l with + | nil => rfl + | cons a t ih => + obtain ⟨x, y⟩ := a + by_cases hx : x = k + · subst hx; simp [lookupBy, List.lookup, List.find?] + · have h1 : (x == k) = false := by simpa using hx + have h2 : (k == x) = false := by simpa using (Ne.symm hx) + simp [lookupBy, List.lookup, List.find?, h1, h2] at ih ⊢ + exact ih + +theorem lookupBy_mem {α} [BEq α] [LawfulBEq α] {l : List (α × Ty)} {k : α} + {t : Ty} (h : lookupBy l k = some t) : (k, t) ∈ l := by + unfold lookupBy at h + cases hf : l.find? (fun e => e.1 == k) with + | none => simp [hf] at h + | some e => + have hm := List.mem_of_find?_eq_some hf + have hk := List.find?_some hf + obtain ⟨a, b⟩ := e + simp [hf] at h + simp at hk + subst hk h + exact hm + +/-! ## `Sub` inversion: peel, then one `cases` per head -/ + +/-- Peel both sides of a subtyping: the `refined` arm *is* this move, and +every other arm pins two unrefined heads that peel to themselves. -/ +theorem Sub.to_peel {S W : Ty} (h : Sub S W) : + Sub S.peel.1 W.peel.1 := by + cases h with + | refined hl hr _ _ hbase => rw [hl, hr]; exact hbase + | base b => simpa [Ty.peel] using Sub.base b + | uintRange n => simpa [Ty.peel] using Sub.uintRange n + | dataSource s => simpa [Ty.peel] using Sub.dataSource s + | txn => simpa [Ty.peel] using Sub.txn + | fnCompute h1 h2 h3 h4 => + simpa [Ty.peel] using Sub.fnCompute h1 h2 h3 h4 + | fnData h1 h2 h3 => simpa [Ty.peel] using Sub.fnData h1 h2 h3 + | tuple h1 h2 => simpa [Ty.peel] using Sub.tuple h1 h2 + | record h1 h2 => simpa [Ty.peel] using Sub.record h1 h2 + | variant h1 h2 => simpa [Ty.peel] using Sub.variant h1 h2 + +/-- Claim containment at identity morphisms: everything the supertype +refinements (across all its peeled layers), the subtype already claimed. -/ +theorem Sub.refinements_mono {S W : Ty} (h : Sub S W) : + ∀ p ∈ W.peel.2, p ∈ S.peel.2 := by + cases h with + | refined hl hr _ hdef _ => + rw [hl, hr] + exact deficit_nil_mono hdef + | base b => simp [Ty.peel] + | uintRange n => simp [Ty.peel] + | dataSource s => simp [Ty.peel] + | txn => simp [Ty.peel] + | fnCompute h1 h2 h3 h4 => simp [Ty.peel] + | fnData h1 h2 h3 => simp [Ty.peel] + | tuple h1 h2 => simp [Ty.peel] + | record h1 h2 => simp [Ty.peel] + | variant h1 h2 => simp [Ty.peel] + +/-- An unrefined subtype of a function type is a function type. (The +`refined` arm cannot apply: both sides peel trivially, starving its +at-least-one-layer guard.) -/ +theorem Sub.fn_src {S : Ty} {n k d c} + (h : Sub S (.fn n k d c)) (hS : S.isRefined = false) : + ∃ n' k' d' c', S = .fn n' k' d' c' := by + cases h with + | fnCompute _ _ _ _ => exact ⟨_, _, _, _, rfl⟩ + | fnData _ _ _ => exact ⟨_, _, _, _, rfl⟩ + | refined hl hr hne _ _ => + rw [Ty.peel_of_not_refined hS] at hl + simp [Ty.peel] at hl hr + obtain ⟨-, hl2⟩ := hl + obtain ⟨-, hr2⟩ := hr + simp [hl2, hr2] at hne + +/-- Function edge inversion: exactly the contravariant domain and the +codomain edge. -/ +theorem Sub.fn_inv {n0 n1 : Option String} {k0 k1 : FunKind} + {d0 d1 c0 c1 : Ty} + (h : Sub (.fn n0 k0 d0 c0) (.fn n1 k1 d1 c1)) : + Sub d1 d0 ∧ Sub c0 c1 := by + cases h with + | fnCompute _ _ hdom hcod => exact ⟨hdom, hcod⟩ + | fnData hd1 _ hcod => exact ⟨hd1, hcod⟩ + | refined hl hr hne _ _ => + simp [Ty.peel] at hl hr + obtain ⟨-, hl2⟩ := hl + obtain ⟨-, hr2⟩ := hr + simp [hl2, hr2] at hne + +/-- An unrefined subtype of a tuple type is a tuple type, at least as wide, +elementwise below it. -/ +theorem Sub.tuple_inv {S : Ty} {Ts : List Ty} + (h : Sub S (.tuple Ts)) (hS : S.isRefined = false) : + ∃ Ss, S = .tuple Ss ∧ Ts.length ≤ Ss.length ∧ + ∀ (i : Nat) t0 t1, Ss[i]? = some t0 → Ts[i]? = some t1 → + Sub t0 t1 := by + cases h with + | tuple hlen helem => exact ⟨_, rfl, hlen, helem⟩ + | refined hl hr hne _ _ => + rw [Ty.peel_of_not_refined hS] at hl + simp [Ty.peel] at hl hr + obtain ⟨-, hl2⟩ := hl + obtain ⟨-, hr2⟩ := hr + simp [hl2, hr2] at hne + +/-- An unrefined subtype of a variant type is a variant type, every tag it +may produce accepted (find-first) with its payload below the acceptor's. -/ +theorem Sub.variant_inv {S : Ty} {tagsW : List (FieldKey × Ty)} + (h : Sub S (.variant tagsW)) (hS : S.isRefined = false) : + ∃ tagsS, S = .variant tagsS ∧ + ∀ tg t0, (tg, t0) ∈ tagsS → + ∃ t1, lookupBy tagsW tg = some t1 ∧ Sub t0 t1 := by + cases h with + | variant hcov hpay => + refine ⟨_, rfl, fun tg t0 hmem => ?_⟩ + obtain ⟨t1, ht1⟩ := Option.isSome_iff_exists.mp (hcov tg t0 hmem) + exact ⟨t1, ht1, hpay tg t0 t1 hmem ht1⟩ + | refined hl hr hne _ _ => + rw [Ty.peel_of_not_refined hS] at hl + simp [Ty.peel] at hl hr + obtain ⟨-, hl2⟩ := hl + obtain ⟨-, hr2⟩ := hr + simp [hl2, hr2] at hne + +/-! ## The fragment is a derivation invariant -/ + +/-- Under a fragment context, every derivable type is in the fragment: the +free-choice premises on `lam`/`variant`/`caseE`/`sub` are exactly what +closes the loop. -/ +theorem hasTy_frag {Γ : List Ty} {e : Tm} {T : Ty} (h : HasTy Γ e T) : + (∀ X ∈ Γ, X.TermFrag) → T.TermFrag := by + induction h with + | lit l => exact fun _ => by cases l <;> exact .base _ + | var hn => exact fun hΓ => hΓ _ (List.mem_of_getElem? hn) + | lam hfrag _ ih => + intro hΓ + refine .fn hfrag (ih fun X hX => ?_) + rcases List.mem_cons.mp hX with rfl | hX + · exact hfrag + · exact hΓ _ hX + | app _ _ ihf _ => + intro hΓ + cases ihf hΓ with | fn _ hc => exact hc + | letE _ _ ihb ihbody => + intro hΓ + refine ihbody fun X hX => ?_ + rcases List.mem_cons.mp hX with rfl | hX + · exact ihb hΓ + · exact hΓ _ hX + | @tuple Γ es Ts hlen _ ih => + intro hΓ + refine .tuple fun t ht => ?_ + obtain ⟨i, hi⟩ := List.getElem?_of_mem ht + have hilt : i < Ts.length := (List.getElem?_eq_some_iff.mp hi).1 + have hes : es[i]? = some es[i] := + List.getElem?_eq_getElem (by omega) + exact ih i es[i] t hes hi hΓ + | proj _ hi ih => + intro hΓ + cases ih hΓ with | tuple ha => exact ha _ (List.mem_of_getElem? hi) + | variant hfrag _ _ _ => exact fun _ => hfrag + | caseE hU _ _ _ _ _ => exact fun _ => hU + | cast _ _ hrefinements _ ih => exact fun hΓ => .refined hrefinements (ih hΓ) + | refineV _ _ _ _ hrefinements _ ih => exact fun hΓ => .refined hrefinements (ih hΓ) + | sub _ _ hfrag _ => exact fun _ => hfrag + +/-! ## Shift and substitution, constructor-wise + +`shift`/`subst` recurse through lists via `attach` (their termination +device); these unfoldings restate them as plain `map`s so the typing +proofs never see a subtype. -/ + +namespace Tm + +@[simp] theorem shift_lit {c : Nat} {l : Lit} : + (Tm.lit l).shift c = .lit l := by simp [Tm.shift] + +@[simp] theorem shift_var {c n : Nat} : + (Tm.var n).shift c = if n < c then .var n else .var (n + 1) := by + simp [Tm.shift] + +@[simp] theorem shift_lam {c : Nat} {dom : Ty} {body : Tm} : + (Tm.lam dom body).shift c = .lam dom (body.shift (c + 1)) := by + simp [Tm.shift] + +@[simp] theorem shift_app {c : Nat} {f a : Tm} : + (Tm.app f a).shift c = .app (f.shift c) (a.shift c) := by + simp [Tm.shift] + +@[simp] theorem shift_letE {c : Nat} {bound body : Tm} : + (Tm.letE bound body).shift c = .letE (bound.shift c) (body.shift (c + 1)) := by + simp [Tm.shift] + +@[simp] theorem shift_tuple {c : Nat} {es : List Tm} : + (Tm.tuple es).shift c = .tuple (es.map (Tm.shift c)) := by + rw [Tm.shift] + congr 1 + exact List.attach_map_val + +@[simp] theorem shift_proj {c : Nat} {e : Tm} {i : Nat} : + (Tm.proj e i).shift c = .proj (e.shift c) i := by + simp [Tm.shift] + +@[simp] theorem shift_variant {c : Nat} {tag : FieldKey} {e : Tm} : + (Tm.variant tag e).shift c = .variant tag (e.shift c) := by + simp [Tm.shift] + +@[simp] theorem shift_caseE {c : Nat} {scrut : Tm} {arms : List (FieldKey × Tm)} : + (Tm.caseE scrut arms).shift c = + .caseE (scrut.shift c) (arms.map fun a => (a.1, a.2.shift (c + 1))) := by + rw [Tm.shift] + congr 1 + show arms.attach.map (fun x => (x.1.1, Tm.shift (c + 1) x.1.2)) = _ + rw [List.map_attach_eq_pmap] + show arms.pmap (fun a _ => (a.1, Tm.shift (c + 1) a.2)) _ = _ + exact List.pmap_eq_map _ + +@[simp] theorem shift_cast {c : Nat} {refinements : List Pred} {e : Tm} : + (Tm.cast refinements e).shift c = .cast refinements (e.shift c) := by + simp [Tm.shift] + +@[simp] theorem subst_lit {k : Nat} {v : Tm} {l : Lit} : + Tm.subst k v (.lit l) = .lit l := by rw [Tm.subst.eq_def] + +@[simp] theorem subst_var {k : Nat} {v : Tm} {n : Nat} : + Tm.subst k v (.var n) = + if n = k then v else if n < k then .var n else .var (n - 1) := by + rw [Tm.subst.eq_def] + +@[simp] theorem subst_lam {k : Nat} {v : Tm} {dom : Ty} {body : Tm} : + Tm.subst k v (.lam dom body) = + .lam dom (Tm.subst (k + 1) (v.shift 0) body) := by + rw [Tm.subst.eq_def] + +@[simp] theorem subst_app {k : Nat} {v f a : Tm} : + Tm.subst k v (.app f a) = .app (Tm.subst k v f) (Tm.subst k v a) := by + rw [Tm.subst.eq_def] + +@[simp] theorem subst_letE {k : Nat} {v bound body : Tm} : + Tm.subst k v (.letE bound body) = + .letE (Tm.subst k v bound) (Tm.subst (k + 1) (v.shift 0) body) := by + rw [Tm.subst.eq_def] + +@[simp] theorem subst_tuple {k : Nat} {v : Tm} {es : List Tm} : + Tm.subst k v (.tuple es) = .tuple (es.map (Tm.subst k v)) := by + rw [Tm.subst.eq_def] + show Tm.tuple (es.attach.map fun x => Tm.subst k v x.1) = _ + congr 1 + exact List.attach_map_val + +@[simp] theorem subst_proj {k : Nat} {v e : Tm} {i : Nat} : + Tm.subst k v (.proj e i) = .proj (Tm.subst k v e) i := by + rw [Tm.subst.eq_def] + +@[simp] theorem subst_variant {k : Nat} {v : Tm} {tag : FieldKey} {e : Tm} : + Tm.subst k v (.variant tag e) = .variant tag (Tm.subst k v e) := by + rw [Tm.subst.eq_def] + +@[simp] theorem subst_caseE {k : Nat} {v scrut : Tm} + {arms : List (FieldKey × Tm)} : + Tm.subst k v (.caseE scrut arms) = + .caseE (Tm.subst k v scrut) + (arms.map fun a => (a.1, Tm.subst (k + 1) (v.shift 0) a.2)) := by + rw [Tm.subst.eq_def] + show Tm.caseE (Tm.subst k v scrut) + (arms.attach.map fun x => (x.1.1, Tm.subst (k + 1) (Tm.shift 0 v) x.1.2)) = _ + congr 1 + rw [List.map_attach_eq_pmap] + show arms.pmap (fun a _ => (a.1, Tm.subst (k + 1) (Tm.shift 0 v) a.2)) _ = _ + exact List.pmap_eq_map _ + +@[simp] theorem subst_cast {k : Nat} {v : Tm} {refinements : List Pred} {e : Tm} : + Tm.subst k v (.cast refinements e) = .cast refinements (Tm.subst k v e) := by + rw [Tm.subst.eq_def] + +/-! ## Values, refinements, and the two term transports -/ + +theorem IsVal.shift {v : Tm} (hv : v.IsVal) (c : Nat) : (v.shift c).IsVal := by + induction hv generalizing c with + | lit l => simpa using .lit l + | lam dom body => simpa using .lam dom (body.shift (c + 1)) + | tuple _ ih => + rw [shift_tuple] + refine .tuple fun e he => ?_ + obtain ⟨x, hx, rfl⟩ := List.mem_map.mp he + exact ih x hx c + | variant tag hv ih => + rw [shift_variant] + exact .variant tag (ih c) + +theorem IsVal.subst {v : Tm} (hv : v.IsVal) (k : Nat) (u : Tm) : + (Tm.subst k u v).IsVal := by + induction hv generalizing k u with + | lit l => simpa using .lit l + | lam dom body => simpa using .lam dom (Tm.subst (k + 1) (u.shift 0) body) + | tuple _ ih => + rw [subst_tuple] + refine .tuple fun e he => ?_ + obtain ⟨x, hx, rfl⟩ := List.mem_map.mp he + exact ih x hx k u + | variant tag hv ih => + rw [subst_variant] + exact .variant tag (ih k u) + +/-- Predicate evaluation reads a value only through its literal shape, and +shifting never changes that shape. -/ +theorem eval_shift {v : Tm} (c : Nat) (p : Pred) : + Pred.eval (v.shift c) p = Pred.eval v p := by + induction p with + | elem => + cases v with + | var n => by_cases h : n < c <;> simp [h, Pred.eval] + | lit l => simp [Pred.eval] + | lam dom body => simp [Pred.eval] + | app f a => simp [Pred.eval] + | letE b body => simp [Pred.eval] + | tuple es => simp [Pred.eval] + | proj e i => simp [Pred.eval] + | variant tag e => simp [Pred.eval] + | caseE sc arms => simp [Pred.eval] + | cast cl e => simp [Pred.eval] + | unop op a iha => simp [Pred.eval, iha] + | binop op a b iha ihb => simp [Pred.eval, iha, ihb] + | proj a k iha => simp [Pred.eval] + | app f a _ _ => simp [Pred.eval] + | _ => simp [Pred.eval] + +/-- Same for substitution into a *value*: values have no free variables at +their literal-observable surface. -/ +theorem eval_subst {v : Tm} (hv : v.IsVal) (k : Nat) (u : Tm) (p : Pred) : + Pred.eval (Tm.subst k u v) p = Pred.eval v p := by + induction p with + | elem => cases hv <;> simp [Pred.eval] + | unop op a iha => simp [Pred.eval, iha] + | binop op a b iha ihb => simp [Pred.eval, iha, ihb] + | proj a k iha => simp [Pred.eval] + | app f a _ _ => simp [Pred.eval] + | _ => simp [Pred.eval] + +theorem refinementsHold_shift {v : Tm} {refinements : List Pred} (c : Nat) : + Tm.refinementsHold refinements (v.shift c) = Tm.refinementsHold refinements v := by + unfold Tm.refinementsHold + congr 1 + funext p + rw [eval_shift] + +theorem refinementsHold_subst {v : Tm} (hv : v.IsVal) {refinements : List Pred} + (k : Nat) (u : Tm) : + Tm.refinementsHold refinements (Tm.subst k u v) = Tm.refinementsHold refinements v := by + unfold Tm.refinementsHold + congr 1 + funext p + rw [eval_subst hv] + +end Tm + +/-- `List.lookup` through a second-component map. -/ +theorem lookup_map_snd {α β γ : Type} [BEq α] {l : List (α × β)} {f : β → γ} + {k : α} : + (l.map fun a => (a.1, f a.2)).lookup k = (l.lookup k).map f := by + induction l with + | nil => rfl + | cons a t ih => + obtain ⟨x, y⟩ := a + simp only [List.map_cons, List.lookup] + split <;> simp [ih] + +/-! ## Weakening -/ + +/-- Inserting `U` at cut `Γ₁.length` retypes the shifted term. -/ +theorem HasTy.weaken {Γ : List Ty} {e : Tm} {W : Ty} (h : HasTy Γ e W) : + ∀ (Γ₁ Γ₂ : List Ty) (U : Ty), Γ = Γ₁ ++ Γ₂ → + HasTy (Γ₁ ++ U :: Γ₂) (e.shift Γ₁.length) W := by + induction h with + | lit l => + intro Γ₁ Γ₂ U hΓ + rw [Tm.shift_lit]; exact .lit l + | @var Γ n T hn => + intro Γ₁ Γ₂ U hΓ + subst hΓ + rw [Tm.shift_var] + by_cases hc : n < Γ₁.length + · rw [if_pos hc] + refine .var ?_ + rw [List.getElem?_append_left hc] at hn ⊢ + exact hn + · rw [if_neg hc] + replace hc := Nat.le_of_not_lt hc + refine .var ?_ + rw [List.getElem?_append_right hc] at hn + rw [List.getElem?_append_right (by omega : Γ₁.length ≤ n + 1)] + have hidx : n + 1 - Γ₁.length = (n - Γ₁.length) + 1 := by omega + rw [hidx, List.getElem?_cons_succ] + exact hn + | @lam Γ dom body cod hfrag _ ih => + intro Γ₁ Γ₂ U hΓ + subst hΓ + rw [Tm.shift_lam] + exact .lam hfrag (by simpa using ih (dom :: Γ₁) Γ₂ U rfl) + | app _ _ ihf iha => + intro Γ₁ Γ₂ U hΓ + rw [Tm.shift_app] + exact .app (ihf Γ₁ Γ₂ U hΓ) (iha Γ₁ Γ₂ U hΓ) + | @letE Γ bound body T' U' _ _ ihb ihbody => + intro Γ₁ Γ₂ U hΓ + subst hΓ + rw [Tm.shift_letE] + exact .letE (ihb Γ₁ Γ₂ U rfl) (by simpa using ihbody (T' :: Γ₁) Γ₂ U rfl) + | @tuple Γ es Ts hlen _ ih => + intro Γ₁ Γ₂ U hΓ + rw [Tm.shift_tuple] + refine .tuple (by simpa using hlen) ?_ + intro i e T h1 h2 + rw [List.getElem?_map] at h1 + cases hes : es[i]? with + | none => rw [hes] at h1; simp at h1 + | some e0 => + rw [hes] at h1 + simp at h1 + subst h1 + exact ih i e0 T hes h2 Γ₁ Γ₂ U hΓ + | proj _ hi ih => + intro Γ₁ Γ₂ U hΓ + rw [Tm.shift_proj] + exact .proj (ih Γ₁ Γ₂ U hΓ) hi + | variant hfrag _ hlk ih => + intro Γ₁ Γ₂ U hΓ + rw [Tm.shift_variant] + exact .variant hfrag (ih Γ₁ Γ₂ U hΓ) hlk + | @caseE Γ scrut arms U' tags hU _ hcov _ ihscrut iharms => + intro Γ₁ Γ₂ U hΓ + subst hΓ + rw [Tm.shift_caseE] + refine .caseE hU (ihscrut Γ₁ Γ₂ U rfl) ?_ ?_ + · intro tag T hlk + rw [lookup_map_snd] + simpa using hcov tag T hlk + · intro tag T body' hlk harm + rw [lookup_map_snd] at harm + cases harms0 : arms.lookup tag with + | none => rw [harms0] at harm; simp at harm + | some body0 => + rw [harms0] at harm + simp at harm + subst harm + exact (by simpa using iharms tag T body0 hlk harms0 (T :: Γ₁) Γ₂ U rfl) + | cast _ hne hcl hbase ih => + intro Γ₁ Γ₂ U hΓ + rw [Tm.shift_cast] + exact .cast (ih Γ₁ Γ₂ U hΓ) hne hcl hbase + | refineV _ hval hch hne hcl hbase ih => + intro Γ₁ Γ₂ U hΓ + exact .refineV (ih Γ₁ Γ₂ U hΓ) (hval.shift _) + (by rw [Tm.refinementsHold_shift]; exact hch) hne hcl hbase + | sub _ hsub hfrag ih => + intro Γ₁ Γ₂ U hΓ + exact .sub (ih Γ₁ Γ₂ U hΓ) hsub hfrag + +/-! ## The substitution lemma + +No value restriction and no fragment hypothesis: the fragment premises ride +the rules untouched (types contain no terms in this fragment), and the +substituend only needs the type the cut assumed. -/ + +theorem HasTy.subst_preserves {Γ : List Ty} {e : Tm} {W : Ty} + (h : HasTy Γ e W) : + ∀ (Γ₁ Γ₂ : List Ty) (T : Ty) (v : Tm), Γ = Γ₁ ++ T :: Γ₂ → + HasTy (Γ₁ ++ Γ₂) v T → + HasTy (Γ₁ ++ Γ₂) (Tm.subst Γ₁.length v e) W := by + induction h with + | lit l => + intro Γ₁ Γ₂ T v hΓ hv + rw [Tm.subst_lit]; exact .lit l + | @var Γ n T' hn => + intro Γ₁ Γ₂ T v hΓ hv + subst hΓ + rw [Tm.subst_var] + by_cases he : n = Γ₁.length + · subst he + rw [if_pos rfl] + rw [List.getElem?_append_right (Nat.le_refl _)] at hn + simp at hn + subst hn + exact hv + · rw [if_neg he] + by_cases hlt : n < Γ₁.length + · rw [if_pos hlt] + refine .var ?_ + rw [List.getElem?_append_left hlt] at hn ⊢ + exact hn + · rw [if_neg hlt] + replace hlt := Nat.le_of_not_lt hlt + refine .var ?_ + rw [List.getElem?_append_right hlt] at hn + have h1 : n - Γ₁.length = (n - Γ₁.length - 1) + 1 := by omega + rw [h1, List.getElem?_cons_succ] at hn + rw [List.getElem?_append_right (by omega : Γ₁.length ≤ n - 1)] + have h2 : n - 1 - Γ₁.length = n - Γ₁.length - 1 := by omega + rw [h2] + exact hn + | @lam Γ dom body cod hfrag _ ih => + intro Γ₁ Γ₂ T v hΓ hv + subst hΓ + rw [Tm.subst_lam] + refine .lam hfrag ?_ + have hv' : HasTy (dom :: (Γ₁ ++ Γ₂)) (v.shift 0) T := by + simpa using hv.weaken [] (Γ₁ ++ Γ₂) dom rfl + exact (by simpa using ih (dom :: Γ₁) Γ₂ T (v.shift 0) rfl hv') + | app _ _ ihf iha => + intro Γ₁ Γ₂ T v hΓ hv + rw [Tm.subst_app] + exact .app (ihf Γ₁ Γ₂ T v hΓ hv) (iha Γ₁ Γ₂ T v hΓ hv) + | @letE Γ bound body T' U' _ _ ihb ihbody => + intro Γ₁ Γ₂ T v hΓ hv + subst hΓ + rw [Tm.subst_letE] + refine .letE (ihb Γ₁ Γ₂ T v rfl hv) ?_ + have hv' : HasTy (T' :: (Γ₁ ++ Γ₂)) (v.shift 0) T := by + simpa using hv.weaken [] (Γ₁ ++ Γ₂) T' rfl + exact (by simpa using ihbody (T' :: Γ₁) Γ₂ T (v.shift 0) rfl hv') + | @tuple Γ es Ts hlen _ ih => + intro Γ₁ Γ₂ T v hΓ hv + rw [Tm.subst_tuple] + refine .tuple (by simpa using hlen) ?_ + intro i e T' h1 h2 + rw [List.getElem?_map] at h1 + cases hes : es[i]? with + | none => rw [hes] at h1; simp at h1 + | some e0 => + rw [hes] at h1 + simp at h1 + subst h1 + exact ih i e0 T' hes h2 Γ₁ Γ₂ T v hΓ hv + | proj _ hi ih => + intro Γ₁ Γ₂ T v hΓ hv + rw [Tm.subst_proj] + exact .proj (ih Γ₁ Γ₂ T v hΓ hv) hi + | variant hfrag _ hlk ih => + intro Γ₁ Γ₂ T v hΓ hv + rw [Tm.subst_variant] + exact .variant hfrag (ih Γ₁ Γ₂ T v hΓ hv) hlk + | @caseE Γ scrut arms U' tags hU _ hcov _ ihscrut iharms => + intro Γ₁ Γ₂ T v hΓ hv + subst hΓ + rw [Tm.subst_caseE] + refine .caseE hU (ihscrut Γ₁ Γ₂ T v rfl hv) ?_ ?_ + · intro tag T' hlk + rw [lookup_map_snd] + simpa using hcov tag T' hlk + · intro tag T' body' hlk harm + rw [lookup_map_snd] at harm + cases harms0 : arms.lookup tag with + | none => rw [harms0] at harm; simp at harm + | some body0 => + rw [harms0] at harm + simp at harm + subst harm + have hv' : HasTy (T' :: (Γ₁ ++ Γ₂)) (v.shift 0) T := by + simpa using hv.weaken [] (Γ₁ ++ Γ₂) T' rfl + have harm' := iharms tag T' body0 hlk harms0 (T' :: Γ₁) Γ₂ T + (v.shift 0) rfl hv' + simpa using harm' + | cast _ hne hcl hbase ih => + intro Γ₁ Γ₂ T v hΓ hv + rw [Tm.subst_cast] + exact .cast (ih Γ₁ Γ₂ T v hΓ hv) hne hcl hbase + | refineV _ hval hch hne hcl hbase ih => + intro Γ₁ Γ₂ T v hΓ hv + exact .refineV (ih Γ₁ Γ₂ T v hΓ hv) (hval.subst _ _) + (by rw [Tm.refinementsHold_subst hval]; exact hch) hne hcl hbase + | sub _ hsub hfrag ih => + intro Γ₁ Γ₂ T v hΓ hv + exact .sub (ih Γ₁ Γ₂ T v hΓ hv) hsub hfrag + +/-- The working corollary: substituting a term of the binder's type under +one binder. -/ +theorem HasTy.subst_one {Γ : List Ty} {body v : Tm} {T U : Ty} + (hbody : HasTy (T :: Γ) body U) (hv : HasTy Γ v T) : + HasTy Γ (Tm.subst 0 v body) U := by + simpa using hbody.subst_preserves [] Γ T v rfl (by simpa using hv) + +/-! ## Canonical forms (modulo refinement peeling) + +Each is an induction over the typing derivation: the head rule supplies the +shape, `refineV` peels a layer, and `sub` crosses one relation link via +`Sub.to_peel` plus the head inversion. `IsVal` dismisses every non-value +rule. -/ + +theorem HasTy.canonical_fn {Γ : List Ty} {v : Tm} {W : Ty} + (h : HasTy Γ v W) : + v.IsVal → ∀ n k d c, W.peel.1 = .fn n k d c → + ∃ dom body, v = .lam dom body := by + induction h with + | lit l => + intro _ n k d c hW + cases l <;> simp [Lit.ty, Ty.peel] at hW + | lam _ _ _ => exact fun _ n k d c _ => ⟨_, _, rfl⟩ + | var _ => intro hv; cases hv + | app _ _ _ _ => intro hv; cases hv + | letE _ _ _ _ => intro hv; cases hv + | tuple _ _ _ => + intro _ n k d c hW + simp [Ty.peel] at hW + | proj _ _ _ => intro hv; cases hv + | variant _ _ _ _ => + intro _ n k d c hW + simp [Ty.peel] at hW + | caseE _ _ _ _ _ _ => intro hv; cases hv + | cast _ _ _ _ _ => intro hv; cases hv + | refineV _ _ _ _ _ _ ih => + intro hv n k d c hW + simp only [Ty.peel] at hW + exact ih hv n k d c hW + | @sub Γ' e S W' _ hsub hfrag ih => + intro hv n k d c hW + have hpeel := hsub.to_peel + rw [hW] at hpeel + obtain ⟨n', k', d', c', hS⟩ := hpeel.fn_src (Ty.peel_fst_not_refined _) + exact ih hv n' k' d' c' hS + +theorem HasTy.canonical_tuple {Γ : List Ty} {v : Tm} {W : Ty} + (h : HasTy Γ v W) : + v.IsVal → ∀ Ts, W.peel.1 = .tuple Ts → + ∃ es, v = .tuple es ∧ Ts.length ≤ es.length ∧ + (∀ (i : Nat) e T, es[i]? = some e → Ts[i]? = some T → HasTy Γ e T) := by + induction h with + | lit l => + intro _ Ts hW + cases l <;> simp [Lit.ty, Ty.peel] at hW + | lam _ _ _ => + intro _ Ts hW + simp [Ty.peel] at hW + | var _ => intro hv; cases hv + | app _ _ _ _ => intro hv; cases hv + | letE _ _ _ _ => intro hv; cases hv + | @tuple Γ' es Ts' hlen helem _ => + intro _ Ts hW + rw [Ty.peel_of_not_refined (by simp [Ty.isRefined])] at hW + injection hW with hTs + subst hTs + exact ⟨es, rfl, Nat.le_of_eq hlen.symm, helem⟩ + | proj _ _ _ => intro hv; cases hv + | variant _ _ _ _ => + intro _ Ts hW + simp [Ty.peel] at hW + | caseE _ _ _ _ _ _ => intro hv; cases hv + | cast _ _ _ _ _ => intro hv; cases hv + | refineV _ _ _ _ _ _ ih => + intro hv Ts hW + simp only [Ty.peel] at hW + exact ih hv Ts hW + | @sub Γ' e S W' _ hsub hfrag ih => + intro hv Ts hW + have hpeel := hsub.to_peel + rw [hW] at hpeel + obtain ⟨Ss, hS, hwidth, hsubel⟩ := + hpeel.tuple_inv (Ty.peel_fst_not_refined _) + obtain ⟨es, hes, hlen', hty⟩ := ih hv Ss hS + have hWp : (Ty.tuple Ts).TermFrag := hW ▸ hfrag.peel_fst + refine ⟨es, hes, Nat.le_trans hwidth hlen', ?_⟩ + intro i e T h1 h2 + have hiS : i < Ss.length := by + have := (List.getElem?_eq_some_iff.mp h2).1 + omega + have hSs : Ss[i]? = some Ss[i] := List.getElem?_eq_getElem hiS + have hTfrag : T.TermFrag := by + cases hWp with | tuple ha => exact ha _ (List.mem_of_getElem? h2) + exact (hty i e Ss[i] h1 hSs).sub (hsubel i Ss[i] T hSs h2) hTfrag + +theorem HasTy.canonical_variant {Γ : List Ty} {v : Tm} {W : Ty} + (h : HasTy Γ v W) : + v.IsVal → ∀ tags, W.peel.1 = .variant tags → + ∃ tag w T, v = .variant tag w ∧ lookupBy tags tag = some T ∧ + HasTy Γ w T := by + induction h with + | lit l => + intro _ tags hW + cases l <;> simp [Lit.ty, Ty.peel] at hW + | lam _ _ _ => + intro _ tags hW + simp [Ty.peel] at hW + | var _ => intro hv; cases hv + | app _ _ _ _ => intro hv; cases hv + | letE _ _ _ _ => intro hv; cases hv + | tuple _ _ _ => + intro _ tags hW + simp [Ty.peel] at hW + | proj _ _ _ => intro hv; cases hv + | @variant Γ' e tag T tags' hfrag hty hlk => + intro _ tags hW + rw [Ty.peel_of_not_refined (by simp [Ty.isRefined])] at hW + injection hW with htags + subst htags + exact ⟨tag, e, T, rfl, by rw [lookupBy_eq_lookup]; exact hlk, hty⟩ + | caseE _ _ _ _ _ _ => intro hv; cases hv + | cast _ _ _ _ _ => intro hv; cases hv + | refineV _ _ _ _ _ _ ih => + intro hv tags hW + simp only [Ty.peel] at hW + exact ih hv tags hW + | @sub Γ' e S W' _ hsub hfrag ih => + intro hv tags hW + have hpeel := hsub.to_peel + rw [hW] at hpeel + obtain ⟨tagsS, hS, hpay⟩ := + hpeel.variant_inv (Ty.peel_fst_not_refined _) + obtain ⟨tag, w, T', hw, hlkS, hty⟩ := ih hv tagsS hS + obtain ⟨T, hlkW, hsubT⟩ := hpay tag T' (lookupBy_mem hlkS) + have hWp : (Ty.variant tags).TermFrag := hW ▸ hfrag.peel_fst + have hTfrag : T.TermFrag := by + cases hWp with | variant ha => exact ha _ (lookupBy_mem hlkW) + exact ⟨tag, w, T, hw, hlkW, hty.sub hsubT hTfrag⟩ + +/-! ## Lambda inversion by typing transport -/ + +/-- Typing transport: whatever is typed at `X` (in any context) is typed at +`Y`. The inversion's slack — reflexive without `Sub.refl`'s `WF` side +condition, and composable across a subsumption chain without transitivity +of `Sub`. -/ +def TyImp (X Y : Ty) : Prop := ∀ (Δ : List Ty) (a : Tm), HasTy Δ a X → HasTy Δ a Y + +theorem HasTy.lam_inv {Γ : List Ty} {L : Tm} {W : Ty} (h : HasTy Γ L W) : + ∀ {d body}, L = .lam d body → (∀ X ∈ Γ, X.TermFrag) → + ∀ n k dom cod, W.peel.1 = .fn n k dom cod → + ∃ c₀, HasTy (d :: Γ) body c₀ ∧ TyImp dom d ∧ TyImp c₀ cod := by + induction h with + | lit l => intro d body hL; simp at hL + | var _ => intro d body hL; simp at hL + | @lam Γ' dom' body' cod' hfrag hbody => + intro d body hL hΓ n k dom cod hW + injection hL with h1 h2 + subst h1; subst h2 + rw [Ty.peel_of_not_refined (by simp [Ty.isRefined])] at hW + injection hW with hn hk hdom hcod + subst hdom; subst hcod + exact ⟨_, hbody, fun Δ a ha => ha, fun Δ a ha => ha⟩ + | app _ _ _ _ => intro d body hL; simp at hL + | letE _ _ _ _ => intro d body hL; simp at hL + | tuple _ _ _ => intro d body hL; simp at hL + | proj _ _ _ => intro d body hL; simp at hL + | variant _ _ _ _ => intro d body hL; simp at hL + | caseE _ _ _ _ _ _ => intro d body hL; simp at hL + | cast _ _ _ _ _ => intro d body hL; simp at hL + | refineV _ _ _ _ _ _ ih => + intro d body hL hΓ n k dom cod hW + simp only [Ty.peel] at hW + exact ih hL hΓ n k dom cod hW + | @sub Γ' e S W' hty hsub hfrag ih => + intro d body hL hΓ n k dom cod hW + subst hL + have hpeel := hsub.to_peel + rw [hW] at hpeel + obtain ⟨n', k', d', c', hS⟩ := hpeel.fn_src (Ty.peel_fst_not_refined _) + rw [hS] at hpeel + have hSfrag : S.TermFrag := hasTy_frag hty hΓ + have hSp : (Ty.fn n' k' d' c').TermFrag := hS ▸ hSfrag.peel_fst + have hWp : (Ty.fn n k dom cod).TermFrag := hW ▸ hfrag.peel_fst + cases hSp with | fn hd' hc' => + cases hWp with | fn hdW hcW => + obtain ⟨hdom_sub, hcod_sub⟩ := hpeel.fn_inv + have hcod_id : Sub c' cod := hcod_sub + obtain ⟨c₀, hbody, himp_dom, himp_cod⟩ := ih rfl hΓ n' k' d' c' hS + refine ⟨c₀, hbody, ?_, ?_⟩ + · exact fun Δ a ha => himp_dom Δ a (ha.sub hdom_sub hd') + · exact fun Δ a ha => (himp_cod Δ a ha).sub hcod_id hcW + +/-! ## Progress -/ + +/-- Per-element progress split: a list of progressing terms is all values, +or has a first non-value element that steps or blocks. -/ +theorem progress_split {es : List Tm} + (h : ∀ e ∈ es, e.IsVal ∨ (∃ e', Tm.Step e e') ∨ Tm.Blocked e) : + (∀ e ∈ es, e.IsVal) ∨ + ∃ pre e post, es = pre ++ e :: post ∧ (∀ x ∈ pre, x.IsVal) ∧ + ((∃ e', Tm.Step e e') ∨ Tm.Blocked e) := by + induction es with + | nil => exact .inl (by simp) + | cons a t ih => + rcases h a (by simp) with hva | hst + · rcases ih (fun e he => h e (by simp [he])) with hall | hsplit + · refine .inl fun e he => ?_ + rcases List.mem_cons.mp he with rfl | he + · exact hva + · exact hall e he + · obtain ⟨pre, e0, post, heq, hpre, hact⟩ := hsplit + refine .inr ⟨a :: pre, e0, post, by rw [heq]; rfl, ?_, hact⟩ + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · exact hva + · exact hpre x hx + · exact .inr ⟨[], a, t, rfl, by simp, hst⟩ + +theorem progress_aux {Γ : List Ty} {e : Tm} {T : Ty} (h : HasTy Γ e T) : + Γ = [] → e.IsVal ∨ (∃ e', Tm.Step e e') ∨ Tm.Blocked e := by + induction h with + | lit l => exact fun _ => .inl (.lit l) + | var hn => intro hΓ; subst hΓ; simp at hn + | lam _ _ _ => exact fun _ => .inl (.lam _ _) + | @app Γ' f a n k dom cod hf ha ihf iha => + intro hΓ; subst hΓ + rcases ihf rfl with hvf | hstf + · rcases iha rfl with hva | hsta + · obtain ⟨domL, body, rfl⟩ := + hf.canonical_fn hvf n k dom cod (by simp [Ty.peel]) + exact .inr (.inl ⟨_, .beta hva⟩) + · rcases hsta with ⟨a', hsa⟩ | hba + · exact .inr (.inl ⟨_, .appR hvf hsa⟩) + · exact .inr (.inr (.appR hvf hba)) + · rcases hstf with ⟨f', hsf⟩ | hbf + · exact .inr (.inl ⟨_, .appL hsf⟩) + · exact .inr (.inr (.appL hbf)) + | letE _ _ ihb _ => + intro hΓ; subst hΓ + rcases ihb rfl with hvb | hstb + · exact .inr (.inl ⟨_, .letV hvb⟩) + · rcases hstb with ⟨b', hsb⟩ | hbb + · exact .inr (.inl ⟨_, .letL hsb⟩) + · exact .inr (.inr (.letL hbb)) + | @tuple Γ' es Ts hlen _ ih => + intro hΓ; subst hΓ + have hprog : ∀ e ∈ es, e.IsVal ∨ (∃ e', Tm.Step e e') ∨ Tm.Blocked e := by + intro e he + obtain ⟨i, hi⟩ := List.getElem?_of_mem he + have hilt : i < es.length := (List.getElem?_eq_some_iff.mp hi).1 + have hTs : Ts[i]? = some Ts[i] := List.getElem?_eq_getElem (by omega) + exact ih i e Ts[i] hi hTs rfl + rcases progress_split hprog with hall | hsplit + · exact .inl (.tuple hall) + · obtain ⟨pre, e0, post, rfl, hpre, hact⟩ := hsplit + rcases hact with ⟨e', hs⟩ | hb + · exact .inr (.inl ⟨_, .tupleAt hpre hs⟩) + · exact .inr (.inr (.tupleAt hpre hb)) + | @proj Γ' e0 i Ts T he hi ih => + intro hΓ; subst hΓ + rcases ih rfl with hve | hste + · obtain ⟨es, rfl, hwidth, _⟩ := + he.canonical_tuple hve Ts (by simp [Ty.peel]) + have hilt : i < es.length := by + have := (List.getElem?_eq_some_iff.mp hi).1 + omega + have hes : es[i]? = some es[i] := List.getElem?_eq_getElem hilt + cases hve with + | tuple hall => exact .inr (.inl ⟨_, .projV hall hes⟩) + · rcases hste with ⟨e', hs⟩ | hb + · exact .inr (.inl ⟨_, .projE hs⟩) + · exact .inr (.inr (.projE hb)) + | variant _ _ _ ih => + intro hΓ; subst hΓ + rcases ih rfl with hve | hste + · exact .inl (.variant _ hve) + · rcases hste with ⟨e', hs⟩ | hb + · exact .inr (.inl ⟨_, .variantE hs⟩) + · exact .inr (.inr (.variantE hb)) + | @caseE Γ' scrut arms U tags hU hscrut hcov _ ihscrut _ => + intro hΓ; subst hΓ + rcases ihscrut rfl with hvs | hsts + · obtain ⟨tag, w, T', rfl, hlk, _⟩ := + hscrut.canonical_variant hvs tags (by simp [Ty.peel]) + rw [lookupBy_eq_lookup] at hlk + obtain ⟨body, hbody⟩ := Option.isSome_iff_exists.mp (hcov tag T' hlk) + have hw : w.IsVal := by cases hvs with | variant _ hw => exact hw + exact .inr (.inl ⟨_, .caseV hw hbody⟩) + · rcases hsts with ⟨s', hs⟩ | hb + · exact .inr (.inl ⟨_, .caseS hs⟩) + · exact .inr (.inr (.caseS hb)) + | @cast Γ' e0 T0 refinements _ _ _ _ ih => + intro hΓ; subst hΓ + rcases ih rfl with hve | hste + · cases hch : Tm.refinementsHold refinements e0 with + | true => exact .inr (.inl ⟨_, .castV hve hch⟩) + | false => exact .inr (.inr (.castV hve hch)) + · rcases hste with ⟨e', hs⟩ | hb + · exact .inr (.inl ⟨_, .castE hs⟩) + · exact .inr (.inr (.castE hb)) + | refineV _ hval _ _ _ _ _ => exact fun _ => .inl hval + | sub _ _ _ ih => exact ih + +/-- **Progress**, modulo filtering: a well-typed closed term is a value, +steps, or is filter-blocked at a cast (the scalar face of a `Restrict` +dropping the element). -/ +theorem progress {e : Tm} {T : Ty} (h : HasTy [] e T) : + e.IsVal ∨ (∃ e', Tm.Step e e') ∨ Tm.Blocked e := + progress_aux h rfl + +/-! ## Preservation -/ + +theorem preservation_aux {Γ : List Ty} {e : Tm} {T : Ty} (h : HasTy Γ e T) : + ∀ e', Tm.Step e e' → (∀ X ∈ Γ, X.TermFrag) → HasTy Γ e' T := by + induction h with + | lit l => intro e' hs; cases hs + | var _ => intro e' hs; cases hs + | lam _ _ _ => intro e' hs; cases hs + | @app Γ' f a n k dom cod hf ha ihf iha => + intro e' hs hΓ + cases hs with + | appL hsf => exact .app (ihf _ hsf hΓ) ha + | appR hvf hsa => exact .app hf (iha _ hsa hΓ) + | beta hva => + obtain ⟨c₀, hbody, himp_dom, himp_cod⟩ := + hf.lam_inv rfl hΓ n k dom cod (by simp [Ty.peel]) + exact himp_cod _ _ (hbody.subst_one (himp_dom _ _ ha)) + | @letE Γ' bound body T' U' hb hbody ihb _ => + intro e' hs hΓ + cases hs with + | letL hsb => exact .letE (ihb _ hsb hΓ) hbody + | letV hvb => exact hbody.subst_one hb + | @tuple Γ' es Ts hlen helem ih => + intro e' hs hΓ + cases hs with + | @tupleAt pre e0 e0' post hpre hstep => + refine .tuple (by simpa using hlen) ?_ + intro i e T h1 h2 + by_cases hip : i = pre.length + · subst hip + rw [List.getElem?_append_right (Nat.le_refl _)] at h1 + simp at h1 + subst h1 + have h0 : (pre ++ e0 :: post)[pre.length]? = some e0 := by + rw [List.getElem?_append_right (Nat.le_refl _)]; simp + exact ih _ e0 T h0 h2 _ hstep hΓ + · have hsame : (pre ++ e0' :: post)[i]? = (pre ++ e0 :: post)[i]? := by + by_cases hlt : i < pre.length + · rw [List.getElem?_append_left hlt, List.getElem?_append_left hlt] + · have hge : pre.length ≤ i := Nat.le_of_not_lt hlt + rw [List.getElem?_append_right hge, + List.getElem?_append_right hge] + have hi1 : i - pre.length = (i - pre.length - 1) + 1 := by omega + rw [hi1, List.getElem?_cons_succ, List.getElem?_cons_succ] + rw [hsame] at h1 + exact helem i e T h1 h2 + | @proj Γ' e0 i Ts T he hi ih => + intro e' hs hΓ + cases hs with + | projE hse => exact .proj (ih _ hse hΓ) hi + | projV hall hes => + obtain ⟨es', heq, _, hty⟩ := + he.canonical_tuple (.tuple hall) Ts (by simp [Ty.peel]) + injection heq with heq + subst heq + exact hty i _ T hes hi + | variant hfrag _ hlk ih => + intro e' hs hΓ + cases hs with + | variantE hse => exact .variant hfrag (ih _ hse hΓ) hlk + | @caseE Γ' scrut arms U tags hU hscrut hcov harms ihs _ => + intro e' hs hΓ + cases hs with + | caseS hss => exact .caseE hU (ihs _ hss hΓ) hcov harms + | caseV hw hbody => + obtain ⟨tag', w', T', heq, hlk, hwty⟩ := + hscrut.canonical_variant (.variant _ hw) tags (by simp [Ty.peel]) + injection heq with heq1 heq2 + subst heq1 + subst heq2 + rw [lookupBy_eq_lookup] at hlk + exact (harms _ T' _ hlk hbody).subst_one hwty + | cast hty hne hcl hbase ih => + intro e' hs hΓ + cases hs with + | castE hse => exact .cast (ih _ hse hΓ) hne hcl hbase + | castV hve hch => exact .refineV hty hve hch hne hcl hbase + | refineV _ hval _ _ _ _ _ => + intro e' hs + exact absurd hs hval.not_step + | sub _ hsub hfrag ih => + intro e' hs hΓ + exact .sub (ih _ hs hΓ) hsub hfrag + +/-- **Preservation**: one step keeps the type, under a fragment context. -/ +theorem preservation {Γ : List Ty} {e e' : Tm} {T : Ty} + (hΓ : ∀ X ∈ Γ, X.TermFrag) (h : HasTy Γ e T) (hs : Tm.Step e e') : + HasTy Γ e' T := + preservation_aux h e' hs hΓ + +/-! ## Multi-step evaluation and refinement soundness -/ + +/-- Reflexive-transitive closure of `Step`. -/ +inductive Tm.Steps : Tm → Tm → Prop + | refl (e : Tm) : Tm.Steps e e + | head {e e' e''} : Tm.Step e e' → Tm.Steps e' e'' → Tm.Steps e e'' + +theorem preservation_star {Γ : List Ty} {e e' : Tm} + (hs : Tm.Steps e e') (hΓ : ∀ X ∈ Γ, X.TermFrag) : + ∀ {T : Ty}, HasTy Γ e T → HasTy Γ e' T := by + induction hs with + | refl _ => exact fun h => h + | head hstep _ ih => exact fun h => ih (preservation hΓ h hstep) + +/-- A value's ascribed refinements all evaluate true on it: `refineV` supplies +them checked, `sub` only ever shrinks them (`Sub.refinements_mono`), and no +other rule types a value at a refined type. -/ +theorem HasTy.value_refinements {Γ : List Ty} {v : Tm} {W : Ty} + (h : HasTy Γ v W) : + v.IsVal → ∀ p ∈ W.peel.2, Pred.eval v p = some (.bool true) := by + induction h with + | lit l => intro _ p hp; cases l <;> simp [Lit.ty, Ty.peel] at hp + | lam _ _ _ => intro _ p hp; simp [Ty.peel] at hp + | var _ => intro hv; cases hv + | app _ _ _ _ => intro hv; cases hv + | letE _ _ _ _ => intro hv; cases hv + | tuple _ _ _ => intro _ p hp; simp [Ty.peel] at hp + | proj _ _ _ => intro hv; cases hv + | variant _ _ _ _ => intro _ p hp; simp [Ty.peel] at hp + | caseE _ _ _ _ _ _ => intro hv; cases hv + | cast _ _ _ _ _ => intro hv; cases hv + | refineV _ _ hch _ _ _ ih => + intro hv p hp + simp only [Ty.peel, List.mem_append] at hp + rcases hp with hp | hp + · exact eq_of_beq (List.all_eq_true.mp hch p hp) + · exact ih hv p hp + | sub _ hsub _ ih => + intro hv p hp + exact ih hv p (hsub.refinements_mono p hp) + +/-- **Refinement soundness**: a closed term of refined type that evaluates +to a value satisfies every refinement — the cast is the only door, and the +`castV` step checks exactly this set. -/ +theorem refinement_soundness {e v : Tm} {T : Ty} {refinements : List Pred} + (h : HasTy [] e (.refined T refinements)) (hs : Tm.Steps e v) + (hv : v.IsVal) : Tm.refinementsHold refinements v = true := by + have hty := preservation_star hs (by simp) h + have hcl := hty.value_refinements hv + unfold Tm.refinementsHold + rw [List.all_eq_true] + intro p hp + have := hcl p (by simp [Ty.peel]; exact .inl hp) + rw [this] + rfl + +/-! ## Case-binder soundness -/ + +/-- The naive case-binder statement, for tag arms: the payload of a +well-typed variant value really has the type the scrutinee's tag table +assigns — so `caseV`'s substitution feeds each arm's binder a value of the +bound it was typed under. The Rust's `case _:` payload-binder defect lives +in *wildcard* arms, which this model does not yet have; refuting the naive +statement there needs that extension (recorded in `Term.lean`'s module +docs as a later increment). -/ +theorem case_binder_sound {Γ : List Ty} {v : Tm} {tag : FieldKey} + {tags : List (FieldKey × Ty)} + (h : HasTy Γ (.variant tag v) (.variant tags)) + (hv : (Tm.variant tag v).IsVal) : + ∃ T, lookupBy tags tag = some T ∧ HasTy Γ v T := by + obtain ⟨tag', w, T, heq, hlk, hty⟩ := + h.canonical_variant hv tags (by simp [Ty.peel]) + injection heq with h1 h2 + subst h1 + subst h2 + exact ⟨T, hlk, hty⟩ + +end CclFormal diff --git a/formal/CclFormal/Sub.lean b/formal/CclFormal/Sub.lean new file mode 100644 index 00000000..4389c118 --- /dev/null +++ b/formal/CclFormal/Sub.lean @@ -0,0 +1,208 @@ +import CclFormal.Ty + +/-! +# The declarative ground subtype relation + +`Sub lhs rhs` is the Lean statement of the relation +`src/ccl/infer/solver/constrain.rs :: constrain_go` *implements* on ground +types (no `Infer` on either side) — stated declaratively; the Rust +operationalizes subsumption inside `constrain` and never writes the relation +down. + +Ground types are **closed** (`src/ccl/design/type-inference.md`, "A binder +reference is stored in one of two forms"): a constructed function never +carries a free name for its own binder — construction converts the reference +to a de Bruijn index (`Pred.piBound`, mirroring `Name::PiBound`), so two +α-variant function types are structurally identical and refinements compare +structurally with no transport. +The relation therefore carries **no rename environments**: the `Ren` +machinery that mirrored `Subst::extended_rename` modeled the solver's +name-spelled mid-solve form, which closure keeps out of ground types. The +`fn` binder slot survives in the grammar as the opening address (the +solver's descent and application open at it), but the relation never reads +it. + +## Deliberate departures from `constrain_go` (each is a tracked decision) + +- **No trivial-equality short-circuit.** `constrain_go` starts with + `lhs == rhs → Ok` (under identity morphisms). Here reflexivity is a + *theorem* (`Sub.refl`), not a rule — provable only for well-formed + (uniquely-keyed) types, which surfaces that the short-circuit and the + find-first record/variant arms disagree on duplicate-keyed products. See + `Ty.WF`. + +- **No binder-correspondence edge.** `constrain_go`'s Fun/Fun codomain edge + opens each closed codomain at its own binder and carries the + correspondence onward for the solver's name-spelled fragments; on + closed ground inputs the open-then-rename round trip is the identity on + the indices, so the model compares codomains directly. A verdict + divergence here is a finding about the opening sites, which is what the + differential oracle is pointed at. + +- **No partition-collapse arm.** A value-`Case` fan-out is a + `DisjointJoin` over the arms' one shared domain, so no comparison ever + meets a `Variant` of gated legs in domain position against a plain-domain + demand (`src/ccl/design/ir.md`, "`Copair` and `DisjointJoin` — two + collection-combining operations, not one"). The relation therefore relates + a `Variant` domain only to a `Variant` domain. +-/ + +namespace CclFormal + +/-- Peel all outer refinement layers: mirror of +`constrain.rs :: peel_refinements` (outermost predicate first). -/ +def Ty.peel : Ty → Ty × List Pred + | .refined b ps => (b.peel.1, ps ++ b.peel.2) + | t => (t, []) + +/-- Peeling an unrefined type is the identity. -/ +theorem Ty.peel_of_not_refined {t : Ty} (h : t.isRefined = false) : + t.peel = (t, []) := by + cases t <;> simp_all [Ty.peel, Ty.isRefined] + +/-- Peeling never grows a type. -/ +theorem Ty.peel_fst_sizeOf_le : (t : Ty) → sizeOf t.peel.1 ≤ sizeOf t + | .base _ | .uintRange _ | .dataSource _ | .txn + | .fn .. | .tuple _ | .record _ | .variant _ => by simp [Ty.peel] + | .refined b p => by + have ih := peel_fst_sizeOf_le b + simp [Ty.peel] + omega + +/-- Peeling a genuinely refined type strictly shrinks it. -/ +theorem Ty.peel_fst_sizeOf_lt : (t : Ty) → t.peel.2 ≠ [] → sizeOf t.peel.1 < sizeOf t + | .base _, h | .uintRange _, h | .dataSource _, h | .txn, h + | .fn .., h | .tuple _, h | .record _, h | .variant _, h => by + simp [Ty.peel] at h + | .refined b p, _ => by + have ih := Ty.peel_fst_sizeOf_le b + simp [Ty.peel] + omega + +/-- Combined form of the two peel lemmas: if either side is genuinely +refined, peeling both shrinks the pair — the decrease of the checker's +refinement arm. -/ +theorem Ty.peel_sum_lt (lhs rhs : Ty) + (h : ¬(lhs.peel.2 = [] ∧ rhs.peel.2 = [])) : + sizeOf lhs.peel.1 + sizeOf rhs.peel.1 < sizeOf lhs + sizeOf rhs := by + cases hl : lhs.peel.2 with + | nil => + cases hr : rhs.peel.2 with + | nil => exact absurd ⟨hl, hr⟩ h + | cons _ _ => + have h1 := Ty.peel_fst_sizeOf_le lhs + have h2 := Ty.peel_fst_sizeOf_lt rhs (by simp [hr]) + omega + | cons _ _ => + have h1 := Ty.peel_fst_sizeOf_lt lhs (by simp [hl]) + have h2 := Ty.peel_fst_sizeOf_le rhs + omega + +/-- Find-first keyed lookup, shared by the record and variant arms (the +Rust arms use `iter().find(..)`). -/ +def lookupBy [BEq α] (l : List (α × Ty)) (k : α) : Option Ty := + (l.find? (fun e => e.1 == k)).map (·.2) + +/-- A found value is smaller than the list it was found in. (The `SizeOf α` +binder matters: without it the statement elaborates with the default +trivial instance and stops matching use sites' real one.) -/ +theorem lookupBy_sizeOf [BEq α] [SizeOf α] {l : List (α × Ty)} {k : α} {t : Ty} + (h : lookupBy l k = some t) : sizeOf t < sizeOf l := by + unfold lookupBy at h + cases hf : l.find? (fun e => e.1 == k) with + | none => simp [hf] at h + | some e => + have hm := List.sizeOf_lt_of_mem (List.mem_of_find?_eq_some hf) + obtain ⟨a, u⟩ := e + simp [hf] at h + subst h + simp at hm + omega + +/-- The kind edge (`constrain.rs :: constrain_kind`): the two kinds relate by +**equality**, so either mismatch is a rejection — a capability supplied where a +collection is demanded, and a collection supplied where a capability is. The +kinds denote different things (a collection carries data, a capability carries +none), so neither direction is a safe weakening. -/ +def kindOk : FunKind → FunKind → Prop + | .compute, .compute => True + | .data, .data => True + | _, _ => False + +/-- The refinements `rrefs` demands that no layer of `lrefs` supplies — +matched by structural predicate equality (never implication), exactly the +deficit of `constrain_go`'s refinement arm. Refinements are closed, so no +transport precedes the comparison. -/ +def deficit (lrefs rrefs : List Pred) : List Pred := + rrefs.filter (fun r => !(lrefs.contains r)) + +/-- The declarative ground subtype relation. One constructor per +`constrain_go` arm (ground fragment); rule order in the Rust `match` is +irrelevant here because the conclusions are syntactically disjoint — +every constructor pins both sides' head constructors, and `refined` +requires a refinement layer on at least one side. -/ +inductive Sub : Ty → Ty → Prop where + /-- Leaves match by equality — `(Base(a), Base(b)) if a == b`. -/ + | base (b : BaseTy) : Sub (.base b) (.base b) + /-- `UIntRange` is **equality-only**: it is a data domain (a loop bound), + and range inclusion is deliberately not subsumption. -/ + | uintRange (n : Nat) : Sub (.uintRange n) (.uintRange n) + | dataSource (s : String) : Sub (.dataSource s) (.dataSource s) + | txn : Sub .txn .txn + /-- Function edge, non-`data`-`data` kinds: the two kinds are equal (so both + are `compute`), the domain is contravariant, and the codomains compare + directly — + a refinement's binding is its index, so the edge needs no binder + correspondence. -/ + | fnCompute {n0 n1 k0 k1 d0 c0 d1 c1} : + kindOk k0 k1 → + ¬(k0 = .data ∧ k1 = .data) → + Sub d1 d0 → + Sub c0 c1 → + Sub (.fn n0 k0 d0 c0) (.fn n1 k1 d1 c1) + /-- Function edge, `data`-`data`: the domain *is* the data, so it is + **invariant** — both directions, spelled the only order-independent way + (`constrain_go`: "Data domains are invariant"). -/ + | fnData {n0 n1 d0 c0 d1 c1} : + Sub d1 d0 → + Sub d0 d1 → + Sub c0 c1 → + Sub (.fn n0 .data d0 c0) (.fn n1 .data d1 c1) + /-- Positional width: every position the rhs demands exists in the lhs + and is covariantly below it. -/ + | tuple {a b} : + b.length ≤ a.length → + (∀ (i : Nat) t0 t1, a[i]? = some t0 → b[i]? = some t1 → Sub t0 t1) → + Sub (.tuple a) (.tuple b) + /-- Named width: every field the rhs demands is present (find-first) in + the lhs and covariantly below it. -/ + | record {a b} : + (∀ n t1, (n, t1) ∈ b → (lookupBy a n).isSome) → + (∀ n t0 t1, (n, t1) ∈ b → lookupBy a n = some t0 → Sub t0 t1) → + Sub (.record a) (.record b) + /-- Variant width is the dual: every tag the lhs may produce is accepted + (find-first) by the rhs, payloads covariant. -/ + | variant {a b} : + (∀ k t0, (k, t0) ∈ a → (lookupBy b k).isSome) → + (∀ k t0 t1, (k, t0) ∈ a → lookupBy b k = some t1 → Sub t0 t1) → + Sub (.variant a) (.variant b) + /-- Refinement arm: peel both sides fully; the lhs must supply every + refinement the rhs demands — set containment by structural equality, + never implication — and the bases compare directly. Covers refinement + dropping (`{T | p} <: T`), forbids refinement conjuring + (`T ⊀ {T | p}`), and makes the base **covariant** + (`{T | p} <: {U | p}` iff `T <: U`). + + The guard (a refinement layer on at least one side) keeps the rule + disjoint from the head-constructor rules, exactly as the Rust arm's + position after them does. The ground fragment has no variable-base + deficit-flow sub-case (that is an `Infer` arm). -/ + | refined {lhs rhs lb lrefs rb rrefs} : + lhs.peel = (lb, lrefs) → + rhs.peel = (rb, rrefs) → + (lrefs ≠ [] ∨ rrefs ≠ []) → + deficit lrefs rrefs = [] → + Sub lb rb → + Sub lhs rhs + +end CclFormal diff --git a/formal/CclFormal/Term.lean b/formal/CclFormal/Term.lean new file mode 100644 index 00000000..d2a81329 --- /dev/null +++ b/formal/CclFormal/Term.lean @@ -0,0 +1,370 @@ +import CclFormal.Ty +import CclFormal.Sub + +/-! +# M2 — Terms, typing, and the small-step semantics (definitional core) + +The pure-core term language, its values, capture-free substitution, the +call-by-value small-step relation, and the declarative typing judgment +`HasTy Γ e T`. Progress/preservation and the two corollaries (refinement +soundness, case-binder preservation) live in `Safety.lean`. + +## Adjudications (deviations-on-contact, in the M0 tradition) + +- **Terms are de Bruijn; types keep their named Pi binders.** The subtype + relation never moves a binder, so names-with-renames mirrored the Rust + one-to-one there. Reduction *duplicates and re-scopes* binders, where named + representations buy α-conversion obligations and nothing else — and the + Rust's term binders are uniquified (`uniquify`), so they are α-irrelevant + identifiers, not semantic content. The M3 bridge maps uniquified names to + indices mechanically. +- **The non-dependent fragment first**: every refinement predicate is over + the reserved `__elem` only (`Pred.elemOnly`) — no predicate references an + enclosing term binder. Types are therefore **closed under term + substitution**, exactly the fragment the transitivity proof covers + (`NoPi`); the dependent extension rides with the Pi-binder thread. +- **`cast` checks its refinements at runtime, and progress is stated modulo + filtering.** In CCL a cast is the refinement introduction (lowering's + filter); at runtime the corresponding `Restrict` *drops* elements. A + scalar small-step mirrors that as: `cast` steps through when every refinement + evaluates to `true` on the value and is **blocked** otherwise. "Well-typed + terms don't get stuck" becomes "a well-typed term is a value, steps, or is + filter-blocked at a cast" — and refinement soundness (`⊢ e : {T | p}` and + `e ⇓ v` implies `p(v) = true`) holds because the cast is the only door. +- **The fragment is enforced *in the judgment*** (`Ty.TermFrag` premises on + the rules that choose types freely: `lam`'s domain, `variant`'s tags, + `sub`'s target), not assumed of the theorem statements. Hypothesizing it + only at the boundary would not confine a derivation's *internal* types — + `sub` can detour through arbitrary types — and two preservation + counterexamples live on such detours; see `Ty.TermFrag`. +- **`refineV` — checked values inhabit the refinement.** `cast` is the only + refinement *door* a program can write, but preservation forces a second, + value-level introduction: `cast p v` (refinements holding) steps to `v`, and + `v`'s refined typing must come from somewhere — `Sub` deliberately forbids + refinement conjuring. `refineV` says a refinement that *evaluates true on a + value* types that value: the term-model face of literal-singleton typing + (a refinement is a fact about a value). Runtime-checked (`refinementsHold`), + value-only, so it is exactly the knowledge the `castV` step validates. + +Left for later increments, recorded not dropped: `compose` (the point-free +core — the source-shaped lambda fragment is what M3's oracle checks first), +records (keyed tuples; nothing new algebraically), the dependent fragment, +and wildcard `case` arms (needed before the case-binder calibration lemma — +the Rust's `case _:` payload-binder defect — can be *stated*). +-/ + +namespace CclFormal + +/-- Term-level literals (the ground fragment of `ccl::Lit`). -/ +inductive Lit where + | int (n : Int) + | bool (b : Bool) + | str (s : String) + | unit +deriving Repr, DecidableEq + +/-- The type of a literal. -/ +def Lit.ty : Lit → Ty + | .int _ => .base .int + | .bool _ => .base .bool + | .str _ => .base .string + | .unit => .base .unit + +/-- The pure-core term language (de Bruijn indices; see the module docs). + +`case` arms pair a variant tag with a body whose index 0 is the payload +binder — the scrutinee-derived bound the calibration lemma is about. `cast` +carries the refinement set it asserts; it is the only refinement introduction, +mirroring CCL (a filter's lowering). -/ +inductive Tm where + | lit (l : Lit) + | var (n : Nat) + | lam (dom : Ty) (body : Tm) + | app (f a : Tm) + | letE (bound body : Tm) + | tuple (es : List Tm) + | proj (e : Tm) (i : Nat) + | variant (tag : FieldKey) (e : Tm) + | caseE (scrut : Tm) (arms : List (FieldKey × Tm)) + | cast (refinements : List Pred) (e : Tm) +deriving Repr + +namespace Tm + +/-- Values: literals, lambdas, tuples of values, variants of values. -/ +inductive IsVal : Tm → Prop + | lit (l : Lit) : IsVal (.lit l) + | lam (dom : Ty) (body : Tm) : IsVal (.lam dom body) + | tuple {es : List Tm} : (∀ e ∈ es, IsVal e) → IsVal (.tuple es) + | variant {e : Tm} (tag : FieldKey) : IsVal e → IsVal (.variant tag e) + +/-- Shift free indices `≥ c` by one (the standard de Bruijn lift). -/ +def shift (c : Nat) : Tm → Tm + | .lit l => .lit l + | .var n => if n < c then .var n else .var (n + 1) + | .lam dom body => .lam dom (shift (c + 1) body) + | .app f a => .app (shift c f) (shift c a) + | .letE bound body => .letE (shift c bound) (shift (c + 1) body) + | .tuple es => .tuple (es.attach.map fun ⟨e, _⟩ => shift c e) + | .proj e i => .proj (shift c e) i + | .variant tag e => .variant tag (shift c e) + | .caseE scrut arms => + .caseE (shift c scrut) (arms.attach.map fun ⟨(tag, body), _⟩ => (tag, shift (c + 1) body)) + | .cast refinements e => .cast refinements (shift c e) +termination_by e => sizeOf e +decreasing_by all_goals + first + | (simp; omega) + | (rename_i h _; have := List.sizeOf_lt_of_mem h; simp at this ⊢; omega) + | (rename_i h; have := List.sizeOf_lt_of_mem h; simp at this ⊢; omega) + +/-- Substitute `v` for index `k` (types are closed in this fragment, so no +type substitution exists to perform). -/ +def subst (k : Nat) (v : Tm) : Tm → Tm + | .lit l => .lit l + | .var n => if n = k then v else if n < k then .var n else .var (n - 1) + | .lam dom body => .lam dom (subst (k + 1) (shift 0 v) body) + | .app f a => .app (subst k v f) (subst k v a) + | .letE bound body => .letE (subst k v bound) (subst (k + 1) (shift 0 v) body) + | .tuple es => .tuple (es.attach.map fun ⟨e, _⟩ => subst k v e) + | .proj e i => .proj (subst k v e) i + | .variant tag e => .variant tag (subst k v e) + | .caseE scrut arms => + .caseE (subst k v scrut) + (arms.attach.map fun ⟨(tag, body), _⟩ => (tag, subst (k + 1) (shift 0 v) body)) + | .cast refinements e => .cast refinements (subst k v e) +termination_by e => sizeOf e +decreasing_by all_goals + first + | (simp; omega) + | (rename_i h _; have := List.sizeOf_lt_of_mem h; simp at this ⊢; omega) + | (rename_i h; have := List.sizeOf_lt_of_mem h; simp at this ⊢; omega) + +end Tm + +/-! ## Predicate evaluation + +A refinement predicate is a `Pred` over the reserved element binder; its +truth on a value is what `cast` checks and what refinement soundness is +about. Evaluation is partial — an op outside the interpreted vocabulary, or +a shape mismatch, yields `none` — mirroring that the wire emitter maps only +a fixed `BinOpKind` vocabulary. -/ + +/-- Evaluate a predicate against the value bound to `__elem`. Returns the +literal result, or `none` where the fragment does not interpret. -/ +def Pred.eval (v : Tm) : Pred → Option Lit + | .elem => + match v with + | .lit l => some l + | _ => none + -- A reference to an enclosing binder — free name or index — denotes the + -- frame's parameter, which element-wise evaluation does not hold: the + -- discharge that supplies it happens before a predicate is evaluated. + | .var _ => none + | .piBound _ => none + | .litInt n => some (.int n) + | .litBool b => some (.bool b) + | .litStr s => some (.str s) + | .litUnit => some .unit + | .unop op a => + match op, Pred.eval v a with + | "not", some (.bool b) => some (.bool !b) + | "neg", some (.int n) => some (.int (-n)) + | _, _ => none + | .binop op a b => + match op, Pred.eval v a, Pred.eval v b with + | "eq", some x, some y => some (.bool (x = y)) + | "ne", some x, some y => some (.bool (x ≠ y)) + | "lt", some (.int x), some (.int y) => some (.bool (x < y)) + | "le", some (.int x), some (.int y) => some (.bool (x ≤ y)) + | "gt", some (.int x), some (.int y) => some (.bool (x > y)) + | "ge", some (.int x), some (.int y) => some (.bool (x ≥ y)) + | "add", some (.int x), some (.int y) => some (.int (x + y)) + | "sub", some (.int x), some (.int y) => some (.int (x - y)) + | "mul", some (.int x), some (.int y) => some (.int (x * y)) + | "and", some (.bool x), some (.bool y) => some (.bool (x && y)) + | "or", some (.bool x), some (.bool y) => some (.bool (x || y)) + | _, _, _ => none + | .proj a k => + match Pred.eval v a with + | _ => none -- literal results carry no fields; projection needs the + -- structured-value extension + | .app _ _ => none + +/-- Every refinement of a set holds on `v`. -/ +def Tm.refinementsHold (refinements : List Pred) (v : Tm) : Bool := + refinements.all fun p => Pred.eval v p == some (.bool true) + +/-! ## The call-by-value small-step relation -/ + +namespace Tm + +/-- One step. `cast` is the door refinements guard: it steps through exactly +when every refinement holds on the value (a blocked cast is a *filtered* element, +not a stuck term — see the module docs). -/ +inductive Step : Tm → Tm → Prop + | appL {f f' a} : Step f f' → Step (.app f a) (.app f' a) + | appR {f a a'} : IsVal f → Step a a' → Step (.app f a) (.app f a') + | beta {dom body a} : IsVal a → Step (.app (.lam dom body) a) (subst 0 a body) + | letL {bound bound' body} : Step bound bound' → Step (.letE bound body) (.letE bound' body) + | letV {bound body} : IsVal bound → Step (.letE bound body) (subst 0 bound body) + | tupleAt {pre : List Tm} {e e' : Tm} {post : List Tm} : + (∀ x ∈ pre, IsVal x) → Step e e' → + Step (.tuple (pre ++ e :: post)) (.tuple (pre ++ e' :: post)) + | projE {e e' i} : Step e e' → Step (.proj e i) (.proj e' i) + | projV {es : List Tm} {i : Nat} {e : Tm} : + (∀ x ∈ es, IsVal x) → es[i]? = some e → Step (.proj (.tuple es) i) e + | variantE {tag e e'} : Step e e' → Step (.variant tag e) (.variant tag e') + | caseS {scrut scrut' arms} : Step scrut scrut' → Step (.caseE scrut arms) (.caseE scrut' arms) + | caseV {tag v arms body} : + IsVal v → arms.lookup tag = some body → + Step (.caseE (.variant tag v) arms) (subst 0 v body) + | castE {refinements e e'} : Step e e' → Step (.cast refinements e) (.cast refinements e') + | castV {refinements v} : + IsVal v → refinementsHold refinements v = true → Step (.cast refinements v) v + +/-- A term is *filter-blocked* when its next redex is a cast whose refinements do +not all hold on the value — the scalar face of a `Restrict` dropping a row. +Progress is stated modulo this outcome. -/ +inductive Blocked : Tm → Prop + | castV {refinements v} : IsVal v → refinementsHold refinements v = false → Blocked (.cast refinements v) + | appL {f a} : Blocked f → Blocked (.app f a) + | appR {f a} : IsVal f → Blocked a → Blocked (.app f a) + | letL {bound body} : Blocked bound → Blocked (.letE bound body) + | tupleAt {pre : List Tm} {e : Tm} {post : List Tm} : + (∀ x ∈ pre, IsVal x) → Blocked e → Blocked (.tuple (pre ++ e :: post)) + | projE {e i} : Blocked e → Blocked (.proj e i) + | variantE {tag e} : Blocked e → Blocked (.variant tag e) + | caseS {scrut arms} : Blocked scrut → Blocked (.caseE scrut arms) + | castE {refinements e} : Blocked e → Blocked (.cast refinements e) + +end Tm + +/-! ## The declarative typing judgment -/ + +/-- Predicates of the non-dependent fragment: over `__elem` only, no +references to enclosing binders — neither a free name nor an index. -/ +def Pred.elemOnly : Pred → Bool + | .elem | .litInt _ | .litBool _ | .litStr _ | .litUnit => true + | .var _ => false + | .piBound _ => false + | .unop _ a => a.elemOnly + | .binop _ a b => a.elemOnly && b.elemOnly + | .proj a _ => a.elemOnly + | .app f a => f.elemOnly && a.elemOnly + +/-- The types the term fragment covers, hereditarily: **every refinement +predicate is `Pred.elemOnly`**, the non-dependent fragment. Off it, a refinement +references an enclosing binder the term judgment does not scope — the +element-wise checks (`refinementsHold`, `Pred.eval`) hold no frame parameter to +supply for a `piBound` index or a free name, so a dependent refinement's truth on +a value is not even stated here. The dependent fragment enters when the +judgment scopes its types' frames, not before. + +The shape follows `Ty.WF`: an inductive with one constructor per head, so +`cases` is the inversion. -/ +inductive Ty.TermFrag : Ty → Prop + | base (b) : Ty.TermFrag (.base b) + | uintRange (n) : Ty.TermFrag (.uintRange n) + | dataSource (s) : Ty.TermFrag (.dataSource s) + | txn : Ty.TermFrag .txn + | fn {n k d c} : Ty.TermFrag d → Ty.TermFrag c → + Ty.TermFrag (.fn n k d c) + | tuple {ts} : (∀ t ∈ ts, Ty.TermFrag t) → Ty.TermFrag (.tuple ts) + | record {fs} : (∀ f ∈ fs, Ty.TermFrag f.2) → Ty.TermFrag (.record fs) + | variant {tags} : (∀ t ∈ tags, Ty.TermFrag t.2) → Ty.TermFrag (.variant tags) + | refined {b ps} : (∀ p ∈ ps, p.elemOnly = true) → Ty.TermFrag b → + Ty.TermFrag (.refined b ps) + +/-- `Γ ⊢ e : T` for the pure core. Contexts are de Bruijn (index 0 is the +innermost binder). Subsumption is the ground relation directly — with refinements +closed at construction it carries no environments to instantiate. + +`cast` is the refinement introduction a *program* writes: it asserts its +refinements on top of the value's type, and the small-step checks them — the +pairing refinement soundness rests on. `refineV` is the value-level +introduction preservation forces (see the module docs): refinements that +evaluate true on a value type that value. `caseE` types every arm's body +under the payload type the scrutinee's variant assigns to its tag: the +scrutinee-derived bound of the calibration lemma. + +The rules that choose a type freely — `lam`'s domain annotation, +`variant`'s tag table, `sub`'s target, and `caseE`'s result (free only in +the degenerate empty-tags elimination, where every arm premise is vacuous +and `U` is otherwise unconstrained) — require it in the term fragment +(`Ty.TermFrag`); everything else inherits fragment membership from its +premises (`hasTy_frag` in `Safety.lean` is that invariant, stated). -/ +inductive HasTy : List Ty → Tm → Ty → Prop + | lit {Γ} (l : Lit) : HasTy Γ (.lit l) l.ty + | var {Γ n T} : Γ[n]? = some T → HasTy Γ (.var n) T + | lam {Γ dom body cod} : + dom.TermFrag → + HasTy (dom :: Γ) body cod → + HasTy Γ (.lam dom body) (.fn none .compute dom cod) + | app {Γ f a name kind dom cod} : + HasTy Γ f (.fn name kind dom cod) → HasTy Γ a dom → + HasTy Γ (.app f a) cod + | letE {Γ bound body T U} : + HasTy Γ bound T → HasTy (T :: Γ) body U → + HasTy Γ (.letE bound body) U + | tuple {Γ} {es : List Tm} {Ts : List Ty} : + es.length = Ts.length → + (∀ (i : Nat) e T, es[i]? = some e → Ts[i]? = some T → HasTy Γ e T) → + HasTy Γ (.tuple es) (.tuple Ts) + | proj {Γ e i} {Ts : List Ty} {T : Ty} : + HasTy Γ e (.tuple Ts) → Ts[i]? = some T → + HasTy Γ (.proj e i) T + | variant {Γ e tag T} {tags : List (FieldKey × Ty)} : + Ty.TermFrag (.variant tags) → + HasTy Γ e T → tags.lookup tag = some T → + HasTy Γ (.variant tag e) (.variant tags) + | caseE {Γ scrut arms U} {tags : List (FieldKey × Ty)} : + U.TermFrag → + HasTy Γ scrut (.variant tags) → + (∀ tag T, tags.lookup tag = some T → (arms.lookup tag).isSome) → + (∀ tag T body, tags.lookup tag = some T → arms.lookup tag = some body → + HasTy (T :: Γ) body U) → + HasTy Γ (.caseE scrut arms) U + | cast {Γ e T} {refinements : List Pred} : + HasTy Γ e T → + refinements ≠ [] → (∀ p ∈ refinements, p.elemOnly = true) → + T.isRefined = false → + HasTy Γ (.cast refinements e) (.refined T refinements) + | refineV {Γ v T} {refinements : List Pred} : + HasTy Γ v T → v.IsVal → + Tm.refinementsHold refinements v = true → + refinements ≠ [] → (∀ p ∈ refinements, p.elemOnly = true) → + T.isRefined = false → + HasTy Γ v (.refined T refinements) + | sub {Γ e T U} : + HasTy Γ e T → Sub T U → U.TermFrag → + HasTy Γ e U + +/-! ## First sanity facts -/ + +/-- Values do not step. -/ +theorem Tm.IsVal.not_step {v v' : Tm} (hv : v.IsVal) : ¬ Tm.Step v v' := by + intro hs + induction hs with + | tupleAt hpre _ ih => + cases hv with + | tuple hall => + exact ih (hall _ (by simp)) + | variantE _ ih => + cases hv with + | variant _ he => exact ih he + | _ => cases hv <;> simp_all + +/-- Values are not blocked. -/ +theorem Tm.IsVal.not_blocked {v : Tm} (hv : v.IsVal) : ¬ Tm.Blocked v := by + intro hb + induction hb with + | tupleAt hpre _ ih => + cases hv with + | tuple hall => exact ih (hall _ (by simp)) + | variantE _ ih => + cases hv with + | variant _ he => exact ih he + | _ => cases hv <;> simp_all + +end CclFormal diff --git a/formal/CclFormal/Transitivity.lean b/formal/CclFormal/Transitivity.lean new file mode 100644 index 00000000..7bbc4f93 --- /dev/null +++ b/formal/CclFormal/Transitivity.lean @@ -0,0 +1,502 @@ +import CclFormal.Equiv +import CclFormal.Props + +/-! +# Transitivity of the ground subtype relation + +`Sub` is transitive on well-formed types — stated directly, with no fragment +restriction and no environment side conditions. + +The history is the point (see `src/ccl/design/type-inference.md`, "Scoped +inference variables: stored fragments close against a telescope"). With +refinements referencing their binders by *name*, chaining dependent codomains +produced premises that viewed the middle type under different renames, +composing only through a reconciliation morphism — the σ-gap, the model +analogue of `constrain.rs :: bridge_holder_gap` — and transitivity was +provable only for a canonical-spelling fragment under identity-acting +environments. With refinements closed into indices at construction +(`Pred.piBound`), the relation carries no environments, two α-variant +function types are the same term, and the gap is not dissolved but never formed: +this file's statement quantifies over nothing but the three types. + +Well-formedness is the one hypothesis, and only its refinements-non-emptiness is +load-bearing here: a degenerate `refined b []` is a distinct term that peels +to its base, so the re-wrap step could not restate it — and it is not a type +(`Type::refined` never builds one; it is not even reflexive, since +`Sub.refined`'s guard demands a real layer). +-/ + +namespace CclFormal + +/-- De Morgan for a decidable conjunction (no Mathlib in this development). -/ +theorem not_and_or' {a b : Prop} [Decidable a] (h : ¬(a ∧ b)) : ¬a ∨ ¬b := by + by_cases ha : a + · exact Or.inr fun hb => h ⟨ha, hb⟩ + · exact Or.inl ha + +theorem one_le_sizeOf (t : Ty) : 1 ≤ sizeOf t := by + cases t <;> simp <;> omega + +/-- A type with no top-level refinement layer is its own peel — for +well-formed types, whose refinement sets are non-empty (`Type::refined` never +builds a `refined b []`, which would peel to its base while remaining a +distinct term). -/ +theorem peel_nil_self : {t : Ty} → t.WF → t.peel.2 = [] → t.peel.1 = t + | .base _, _, _ | .uintRange _, _, _ | .dataSource _, _, _ | .txn, _, _ + | .fn .., _, _ | .tuple _, _, _ | .record _, _, _ | .variant _, _, _ => rfl + | .refined _ _, .refined hne _ _, h => by + simp [Ty.peel] at h + exact absurd h.1 hne + +theorem deficit_eq_nil_iff {l r : List Pred} : + deficit l r = [] ↔ ∀ p ∈ r, p ∈ l := by + unfold deficit + rw [List.filter_eq_nil_iff] + constructor + · intro h p hp + have := h p hp + simp only [Bool.not_eq_true', Bool.not_eq_false] at this + exact List.mem_of_elem_eq_true this + · intro h p hp + simp only [Bool.not_eq_true', Bool.not_eq_false] + exact List.elem_eq_true_of_mem (h p hp) + +/-- Universal peel inversion: **every** rule leaves the peeled bases related +and the peeled refinement sets contained. For the head-constructor rules +both peels are `(t, [])`, so this is the derivation itself; for the +refinement rule it is exactly its premises. -/ +theorem sub_peel_inv {x y : Ty} (h : Sub x y) : + deficit x.peel.2 y.peel.2 = [] ∧ Sub x.peel.1 y.peel.1 := by + cases h with + | base b => exact ⟨rfl, .base b⟩ + | uintRange n => exact ⟨rfl, .uintRange n⟩ + | dataSource s => exact ⟨rfl, .dataSource s⟩ + | txn => exact ⟨rfl, .txn⟩ + | fnCompute h1 h2 h3 h4 => exact ⟨rfl, .fnCompute h1 h2 h3 h4⟩ + | fnData h1 h2 h3 => exact ⟨rfl, .fnData h1 h2 h3⟩ + | tuple h1 h2 => exact ⟨rfl, .tuple h1 h2⟩ + | record h1 h2 => exact ⟨rfl, .record h1 h2⟩ + | variant h1 h2 => exact ⟨rfl, .variant h1 h2⟩ + | refined hpl hpr _ hdef hbase => + rw [hpl, hpr] + exact ⟨hdef, hbase⟩ + +theorem kindOk_trans {k0 km k1 : FunKind} + (h1 : kindOk k0 km) (h2 : kindOk km k1) : kindOk k0 k1 := by + cases k0 <;> cases km <;> cases k1 <;> simp_all [kindOk] + +theorem lookupBy_mem [BEq α] [LawfulBEq α] {l : List (α × Ty)} {k : α} {t : Ty} + (h : lookupBy l k = some t) : (k, t) ∈ l := by + unfold lookupBy at h + cases hf : l.find? (fun e => e.1 == k) with + | none => rw [hf] at h; exact absurd h (by simp) + | some e => + obtain ⟨a, b⟩ := e + rw [hf] at h + simp only [Option.map_some] at h + injection h with hb + subst hb + have hmem := List.mem_of_find?_eq_some hf + have hkey : a = k := by + have := List.find?_some hf + simpa using eq_of_beq (by simpa using this) + subst hkey + exact hmem + +/-- Shape inversion: a bare type below a function type is a function type. -/ +theorem sub_fn_rhs_shape {x : Ty} {nm km dm cm} + (h : Sub x (.fn nm km dm cm)) (hx : x.peel.2 = []) : + ∃ n0 k0 d0 c0, x = .fn n0 k0 d0 c0 := by + cases h with + | fnCompute _ _ _ _ => exact ⟨_, _, _, _, rfl⟩ + | fnData _ _ _ => exact ⟨_, _, _, _, rfl⟩ + | refined hpl hpr hg _ _ => + rw [hpl] at hx + simp only [Ty.peel, Prod.mk.injEq] at hpr hx + obtain ⟨-, hr⟩ := hpr + subst hr + rcases hg with hg | hg + · exact absurd hx hg + · exact absurd rfl hg + +/-- Shape inversion: a bare type above a function type is a function type. -/ +theorem sub_fn_lhs_shape {z : Ty} {nm km dm cm} + (h : Sub (.fn nm km dm cm) z) (hz : z.peel.2 = []) : + ∃ n1 k1 d1 c1, z = .fn n1 k1 d1 c1 := by + cases h with + | fnCompute _ _ _ _ => exact ⟨_, _, _, _, rfl⟩ + | fnData _ _ _ => exact ⟨_, _, _, _, rfl⟩ + | refined hpl hpr hg _ _ => + rw [hpr] at hz + simp only [Ty.peel, Prod.mk.injEq] at hpl hz + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hz hg + +/-- Member well-formedness extractors, the recursion's plumbing. -/ +theorem Ty.WF.fn_dom {n k d c} (h : Ty.WF (.fn n k d c)) : d.WF := by + cases h with | fn hd _ => exact hd + +theorem Ty.WF.fn_cod {n k d c} (h : Ty.WF (.fn n k d c)) : c.WF := by + cases h with | fn _ hc => exact hc + +theorem Ty.WF.tuple_mem {ts t} (h : Ty.WF (.tuple ts)) (hm : t ∈ ts) : t.WF := by + cases h with | tuple hts => exact hts t hm + +theorem Ty.WF.record_mem {fs : List (String × Ty)} {n t} + (h : Ty.WF (.record fs)) (hm : (n, t) ∈ fs) : t.WF := by + cases h with | record _ hf => exact hf (n, t) hm + +theorem Ty.WF.variant_mem {tags : List (FieldKey × Ty)} {k t} + (h : Ty.WF (.variant tags)) (hm : (k, t) ∈ tags) : t.WF := by + cases h with | variant _ ht => exact ht (k, t) hm + +/-- Bundled induction hypothesis: transitivity for anything smaller. -/ +def TransIH (n : Nat) : Prop := + ∀ (a b c : Ty), sizeOf a + sizeOf b + sizeOf c ≤ n → + a.WF → b.WF → c.WF → Sub a b → Sub b c → Sub a c + +/-- The function case, factored out so the three ways of concluding a +function edge are handled once. -/ +theorem sub_trans_fn {n : Nat} {n0 k0 d0 c0 nm km dm cm : _} {z : Ty} + (IH : TransIH n) + (hbound : sizeOf (Ty.fn n0 k0 d0 c0) + sizeOf (Ty.fn nm km dm cm) + + sizeOf z ≤ n + 1) + (hx : Ty.WF (.fn n0 k0 d0 c0)) (hy : Ty.WF (.fn nm km dm cm)) + (hz : Ty.WF z) (hzb : z.peel.2 = []) + (h1 : Sub (.fn n0 k0 d0 c0) (.fn nm km dm cm)) + (h2 : Sub (.fn nm km dm cm) z) : + Sub (.fn n0 k0 d0 c0) z := by + obtain ⟨n1, k1, d1, c1, rfl⟩ := sub_fn_lhs_shape h2 hzb + have hdom_sz : sizeOf d1 + sizeOf dm + sizeOf d0 ≤ n := by + simp only [Ty.fn.sizeOf_spec] at hbound + omega + have hcod_sz : sizeOf c0 + sizeOf cm + sizeOf c1 ≤ n := by + simp only [Ty.fn.sizeOf_spec] at hbound + omega + cases h1 with + | refined hpl hpr hg _ _ => + simp only [Ty.peel, Prod.mk.injEq] at hpl hpr + obtain ⟨-, hl⟩ := hpl + obtain ⟨-, hr⟩ := hpr + subst hl; subst hr + rcases hg with hg | hg <;> exact absurd rfl hg + | fnCompute hok1 hnd1 hdom1 hcod1 => + cases h2 with + | refined hpl hpr hg _ _ => + simp only [Ty.peel, Prod.mk.injEq] at hpl hpr + obtain ⟨-, hl⟩ := hpl + obtain ⟨-, hr⟩ := hpr + subst hl; subst hr + rcases hg with hg | hg <;> exact absurd rfl hg + | fnCompute hok2 hnd2 hdom2 hcod2 => + have hdom := IH d1 dm d0 hdom_sz hz.fn_dom hy.fn_dom hx.fn_dom + hdom2 hdom1 + have hcod := IH c0 cm c1 hcod_sz hx.fn_cod hy.fn_cod hz.fn_cod + hcod1 hcod2 + refine Sub.fnCompute (kindOk_trans hok1 hok2) ?_ hdom hcod + rintro ⟨rfl, rfl⟩ + have hkm : km ≠ FunKind.data := fun h => hnd1 ⟨rfl, h⟩ + cases km with + | data => exact hkm rfl + | compute => exact hok2 + | fnData _ _ _ => + have hk0 : k0 ≠ FunKind.data := fun h => hnd1 ⟨h, rfl⟩ + cases k0 with + | data => exact absurd rfl hk0 + | compute => exact absurd hok1 (by simp [kindOk]) + | fnData hdom1a hdom1b hcod1 => + cases h2 with + | refined hpl hpr hg _ _ => + simp only [Ty.peel, Prod.mk.injEq] at hpl hpr + obtain ⟨-, hl⟩ := hpl + obtain ⟨-, hr⟩ := hpr + subst hl; subst hr + rcases hg with hg | hg <;> exact absurd rfl hg + | fnCompute hok2 hnd2 hdom2 hcod2 => + have hdom := IH d1 dm d0 hdom_sz hz.fn_dom hy.fn_dom hx.fn_dom + hdom2 hdom1a + have hcod := IH c0 cm c1 hcod_sz hx.fn_cod hy.fn_cod hz.fn_cod + hcod1 hcod2 + refine Sub.fnCompute hok2 ?_ hdom hcod + rintro ⟨-, rfl⟩ + exact hnd2 ⟨rfl, rfl⟩ + | fnData hdom2a hdom2b hcod2 => + have hdomA := IH d1 dm d0 hdom_sz hz.fn_dom hy.fn_dom hx.fn_dom + hdom2a hdom1a + have hdomB := IH d0 dm d1 (by omega) hx.fn_dom hy.fn_dom hz.fn_dom + hdom1b hdom2b + have hcod := IH c0 cm c1 hcod_sz hx.fn_cod hy.fn_cod hz.fn_cod + hcod1 hcod2 + exact Sub.fnData hdomA hdomB hcod + +/-- Fuel-bounded transitivity. -/ +theorem sub_trans_aux : (n : Nat) → TransIH n + | 0 => by + intro x y z hn _ _ _ _ _ + have := one_le_sizeOf x + have := one_le_sizeOf y + have := one_le_sizeOf z + omega + | n + 1 => by + intro x y z hn hx hy hz h1 h2 + have IH : TransIH n := sub_trans_aux n + by_cases hbare : x.peel.2 = [] ∧ y.peel.2 = [] ∧ z.peel.2 = [] + · obtain ⟨hxb, hyb, hzb⟩ := hbare + cases h1 with + | base b => + cases h2 with + | base _ => exact .base b + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | uintRange m => + cases h2 with + | uintRange _ => exact .uintRange m + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | dataSource s => + cases h2 with + | dataSource _ => exact .dataSource s + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | txn => + cases h2 with + | txn => exact .txn + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | fnCompute a b c d' => + exact sub_trans_fn IH (by omega) hx hy hz hzb + (.fnCompute a b c d') h2 + | fnData a b c => + exact sub_trans_fn IH (by omega) hx hy hz hzb + (.fnData a b c) h2 + | tuple hlen1 hpt1 => + cases h2 with + | tuple hlen2 hpt2 => + refine Sub.tuple (Nat.le_trans hlen2 hlen1) ?_ + intro i t0 t1 h0 h1' + rename_i as bs cs + have hi1 : i < cs.length := by + obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp h1' + exact hlt + have hi2 : i < bs.length := Nat.lt_of_lt_of_le hi1 hlen2 + have hb : bs[i]? = some bs[i] := List.getElem?_eq_getElem hi2 + have hm0 : t0 ∈ as := List.mem_of_getElem? h0 + have hmm : bs[i] ∈ bs := List.getElem_mem hi2 + have hm1 : t1 ∈ cs := List.mem_of_getElem? h1' + have s0 := List.sizeOf_lt_of_mem hm0 + have sm := List.sizeOf_lt_of_mem hmm + have s1 := List.sizeOf_lt_of_mem hm1 + refine IH t0 bs[i] t1 ?_ (hx.tuple_mem hm0) (hy.tuple_mem hmm) + (hz.tuple_mem hm1) (hpt1 i t0 bs[i] h0 hb) + (hpt2 i bs[i] t1 hb h1') + simp only [Ty.tuple.sizeOf_spec] at hn + omega + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | record hsome1 hsub1 => + cases h2 with + | record hsome2 hsub2 => + rename_i as bs cs + refine Sub.record (fun nkey t1 hm => ?_) (fun nkey t0 t1 hm hlk => ?_) + · have h2s := hsome2 nkey t1 hm + obtain ⟨tm, htm⟩ := Option.isSome_iff_exists.mp h2s + exact hsome1 nkey tm (lookupBy_mem htm) + · have h2s := hsome2 nkey t1 hm + obtain ⟨tm, htm⟩ := Option.isSome_iff_exists.mp h2s + have hmm : (nkey, tm) ∈ bs := lookupBy_mem htm + have hm0 : (nkey, t0) ∈ as := lookupBy_mem hlk + have s0 := List.sizeOf_lt_of_mem hm0 + have sm := List.sizeOf_lt_of_mem hmm + have s1 := List.sizeOf_lt_of_mem hm + refine IH t0 tm t1 ?_ (hx.record_mem hm0) (hy.record_mem hmm) + (hz.record_mem hm) (hsub1 nkey t0 tm hmm hlk) + (hsub2 nkey tm t1 hm htm) + simp only [Ty.record.sizeOf_spec] at hn + simp only [Prod.mk.sizeOf_spec] at s0 sm s1 + omega + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | variant hsome1 hsub1 => + cases h2 with + | variant hsome2 hsub2 => + rename_i as bs cs + refine Sub.variant (fun key t0 hm => ?_) (fun key t0 t1 hm hlk => ?_) + · have h1s := hsome1 key t0 hm + obtain ⟨tm, htm⟩ := Option.isSome_iff_exists.mp h1s + exact hsome2 key tm (lookupBy_mem htm) + · have h1s := hsome1 key t0 hm + obtain ⟨tm, htm⟩ := Option.isSome_iff_exists.mp h1s + have hmm : (key, tm) ∈ bs := lookupBy_mem htm + have hm1 : (key, t1) ∈ cs := lookupBy_mem hlk + have s0 := List.sizeOf_lt_of_mem hm + have sm := List.sizeOf_lt_of_mem hmm + have s1 := List.sizeOf_lt_of_mem hm1 + refine IH t0 tm t1 ?_ (hx.variant_mem hm) (hy.variant_mem hmm) + (hz.variant_mem hm1) (hsub1 key t0 tm hm htm) + (hsub2 key tm t1 hmm hlk) + simp only [Ty.variant.sizeOf_spec] at hn + simp only [Prod.mk.sizeOf_spec] at s0 sm s1 + omega + | refined hpl hpr hg _ _ => + rw [hpr] at hzb + simp only [Ty.peel, Prod.mk.injEq] at hpl hzb + obtain ⟨-, hl⟩ := hpl + subst hl + rcases hg with hg | hg + · exact absurd rfl hg + · exact absurd hzb hg + | refined hpl hpr hg _ _ => + rw [hpl] at hxb + rw [hpr] at hyb + simp at hxb hyb + rcases hg with hg | hg + · exact absurd hxb hg + · exact absurd hyb hg + · -- Some side carries a refinement layer: peel all three, compose the + -- set containments, recurse on the bases, re-wrap. + obtain ⟨hd1, hs1⟩ := sub_peel_inv h1 + obtain ⟨hd2, hs2⟩ := sub_peel_inv h2 + have hc1 := deficit_eq_nil_iff.mp hd1 + have hc2 := deficit_eq_nil_iff.mp hd2 + have hlt : sizeOf x.peel.1 + sizeOf y.peel.1 + sizeOf z.peel.1 + < sizeOf x + sizeOf y + sizeOf z := by + have hax := Ty.peel_fst_sizeOf_le x + have hay := Ty.peel_fst_sizeOf_le y + have haz := Ty.peel_fst_sizeOf_le z + rcases not_and_or' hbare with h' | h' + · have := Ty.peel_fst_sizeOf_lt x h'; omega + · rcases not_and_or' h' with h'' | h'' + · have := Ty.peel_fst_sizeOf_lt y h''; omega + · have := Ty.peel_fst_sizeOf_lt z h''; omega + have hbase := IH x.peel.1 y.peel.1 z.peel.1 (by omega) + hx.peel_fst hy.peel_fst hz.peel_fst hs1 hs2 + have hdef : deficit x.peel.2 z.peel.2 = [] := + deficit_eq_nil_iff.mpr fun p hp => hc1 p (hc2 p hp) + by_cases hxz : x.peel.2 = [] ∧ z.peel.2 = [] + · rw [peel_nil_self hx hxz.1, peel_nil_self hz hxz.2] at hbase + exact hbase + · exact Sub.refined rfl rfl (not_and_or' hxz) hdef hbase + +/-- **Transitivity**, with no fragment restriction: any chain of well-formed +types composes. The former canonical-fragment statement and its six +identity-acting environments are subsumed — closing into indices leaves the +relation nothing to reconcile. -/ +theorem sub_trans {x y z : Ty} (hx : x.WF) (hy : y.WF) (hz : z.WF) + (h1 : Sub x y) (h2 : Sub y z) : Sub x z := + sub_trans_aux (sizeOf x + sizeOf y + sizeOf z) x y z (Nat.le_refl _) + hx hy hz h1 h2 + +/-! ## Claim order is not observable + +`Type::Refinement` layers carry refinements whose order is an artifact of +arrival, while the model *represents* the refinements as a `List Pred` so that +`Ty.beq` stays propositional equality. The two agree only if the relation +genuinely cannot see the list structure, which is what this section proves +rather than asserts. + +The statements are in terms of **containment**, not permutation, because that +is what `deficit` actually uses: it asks whether each demanded refinement has *some* +supplier, so a supplier list may be reordered, duplicated, or widened freely. +Permutation and dedup-invariance are corollaries (`sub_refinements_perm`), which is +exactly the latitude the Rust representation takes. +-/ + +/-- Widening (hence reordering or duplicating) the **supplied** refinements +preserves the relation. -/ +theorem sub_refinements_left {b z : Ty} {ps qs : List Pred} + (hne : qs ≠ []) (hsupp : ∀ p ∈ ps, p ∈ qs) + (h : Sub (.refined b ps) z) : Sub (.refined b qs) z := by + obtain ⟨hdef, hbase⟩ := sub_peel_inv h + refine Sub.refined rfl rfl (.inl ?_) ?_ hbase + · simp + exact fun hc => absurd hc hne + · rw [deficit_eq_nil_iff] at hdef ⊢ + intro p hp + have hq := hdef p hp + simp [Ty.peel] at hq ⊢ + rcases hq with hq | hq + · exact Or.inl (hsupp p hq) + · exact Or.inr hq + +/-- Narrowing (hence reordering or deduplicating) the **demanded** refinements +preserves the relation. -/ +theorem sub_refinements_right {x b : Ty} {ps qs : List Pred} + (hne : qs ≠ []) (hdem : ∀ p ∈ qs, p ∈ ps) + (h : Sub x (.refined b ps)) : Sub x (.refined b qs) := by + obtain ⟨hdef, hbase⟩ := sub_peel_inv h + refine Sub.refined rfl rfl (.inr ?_) ?_ hbase + · simp + exact fun hc => absurd hc hne + · rw [deficit_eq_nil_iff] at hdef ⊢ + intro p hp + simp at hp + refine hdef p ?_ + simp [Ty.peel] + rcases hp with hp | hp + · exact Or.inl (hdem p hp) + · exact Or.inr hp + +/-- **Claim order is not observable**: two refinement lists with the same members +are interchangeable on either side of the relation — the arrival order two +bounds happened to meet in cannot reach typing. -/ +theorem sub_refinements_perm {b z : Ty} {ps qs : List Pred} + (hne : qs ≠ []) (hmem : ∀ p, p ∈ ps ↔ p ∈ qs) : + Sub (.refined b ps) z ↔ Sub (.refined b qs) z := by + have hqne : ps ≠ [] := by + intro hc + obtain ⟨q, hq⟩ := List.exists_mem_of_ne_nil qs hne + exact absurd ((hmem q).mpr hq) (by simp [hc]) + exact ⟨sub_refinements_left hne (fun p hp => (hmem p).mp hp), + sub_refinements_left hqne (fun p hp => (hmem p).mpr hp)⟩ + +/-- The same, in demand position. -/ +theorem sub_refinements_perm_right {x b : Ty} {ps qs : List Pred} + (hne : qs ≠ []) (hmem : ∀ p, p ∈ ps ↔ p ∈ qs) : + Sub x (.refined b ps) ↔ Sub x (.refined b qs) := by + have hqne : ps ≠ [] := by + intro hc + obtain ⟨q, hq⟩ := List.exists_mem_of_ne_nil qs hne + exact absurd ((hmem q).mpr hq) (by simp [hc]) + exact ⟨sub_refinements_right hne (fun p hp => (hmem p).mpr hp), + sub_refinements_right hqne (fun p hp => (hmem p).mp hp)⟩ + +end CclFormal diff --git a/formal/CclFormal/Ty.lean b/formal/CclFormal/Ty.lean new file mode 100644 index 00000000..f579d481 --- /dev/null +++ b/formal/CclFormal/Ty.lean @@ -0,0 +1,248 @@ +/-! +# The ground `Type` grammar + +The Lean mirror of the **ground fragment** of `src/ccl/ty.rs :: Type` — every +variant a fully-inferred type can contain. Excluded, deliberately: + +- `Infer` and `SharedHole` — inference unknowns; the ground relation has no + variable arms (they enter at the solver-model milestone). +- `History` and `ChanDom` — transients erased before the strict wall; they are + pipeline artifacts, not types a checked program exhibits. +- `App` and `Below` — type-function applications reduce during inference and + `Below` lives only in annotation position; both are transient in the same + sense as `Infer`. +- `FunKind::Var` — kind unknowns resolve at coalesce; a ground kind is one of + the two points, related only to itself. +-/ + +namespace CclFormal + +/-- Mirror of `ccl::ops::BaseType`. -/ +inductive BaseTy where + | int | uint | string | bool | unit +deriving Repr, DecidableEq + +/-- Mirror of `ccl::ty::FieldKey`: a record/tuple field or variant tag. -/ +inductive FieldKey where + | idx (n : Nat) + | name (s : String) +deriving Repr, DecidableEq + +/-- Mirror of the ground part of `ccl::ty::FunKind` (`Var` excluded): two +points, related by equality — a collection and a capability denote different +things, so neither stands in for the other. -/ +inductive FunKind where + | compute | data +deriving Repr, DecidableEq + +/-- A refinement predicate term. + +Mirrors the fragment of `TypedExpr` that refinement predicates use, and only +up to what subtyping observes: `Refinement`'s `PartialEq` is **type-blind +structural equality** of the predicate term (`src/ccl/ty.rs`), so the model +carries no type slots and `op` names are opaque strings. `elem` is the single +reserved refinement binder (`REFINEMENT_BINDER`, `__elem`); `piBound` +references an enclosing `Fun` Pi binder as a de Bruijn index — the number of +`fn` codomains crossed between the reference and the function that binds it, +mirroring `Name::PiBound` (`src/ccl/design/type-inference.md`, "A binder +reference is stored in one of two forms"). A ground type is closed: +construction converts a binder reference to its index (`close_pi_binder`), so +two α-variant function types are structurally identical and the relation needs no rename +environments. `var` remains for the *free* references a refinement may keep — a +`let`-bound name a user-written refinement mentions, or a source — which are +globally unique and compare structurally. The Rust→JSON emitter must map +`TypedExpr` predicates into exactly this fragment and refuse anything outside +it, so a vocabulary gap fails loudly instead of comparing wrongly. -/ +inductive Pred where + | elem + | var (x : String) + | piBound (k : Nat) + | litInt (n : Int) + | litBool (b : Bool) + | litStr (s : String) + | litUnit + | unop (op : String) (a : Pred) + | binop (op : String) (a b : Pred) + | proj (a : Pred) (k : FieldKey) + | app (f a : Pred) +deriving Repr, DecidableEq + +/-- Mirror of the ground fragment of `ccl::ty::Type`. + +`refined` carries a **refinement set**, exactly like +`Type::Refinement(base, RefinementSet)`: a base narrowed by the conjunction of +its refinements, with `Ty.WF` requiring the same two invariants `Type::refined` +establishes — the refinements are non-empty, and the base is not itself refined, so +layers never nest. + +The refinements are *represented* as a `List Pred` and `Ty.beq` compares them +positionally, which keeps `beq` propositional equality (`Ty.beq_iff`) and so +keeps `DecidableEq`. The **relation** is what treats them as a set: `deficit` +is containment, never list equality, so `Sub` cannot observe refinement order — +stated and proved as `sub_refinements_perm` rather than left as a reading of the +rules. + +Equality is hand-written (`Ty.beq` — the `BEq`/`DecidableEq` deriving +handlers do not support this nested inductive) and bridged to propositional +equality by `Ty.beq_iff`, yielding lawful `BEq` and `DecidableEq` +instances. -/ +inductive Ty where + | base (b : BaseTy) + | uintRange (n : Nat) + | dataSource (name : String) + | txn + | fn (binder : Option String) (kind : FunKind) (dom cod : Ty) + | tuple (ts : List Ty) + | record (fields : List (String × Ty)) + | variant (tags : List (FieldKey × Ty)) + | refined (base : Ty) (refinements : List Pred) +deriving Repr + +mutual + +/-- Structural equality. -/ +def Ty.beq : Ty → Ty → Bool + | .base a, .base b => a == b + | .uintRange a, .uintRange b => a == b + | .dataSource a, .dataSource b => a == b + | .txn, .txn => true + | .fn n0 k0 d0 c0, .fn n1 k1 d1 c1 => + n0 == n1 && k0 == k1 && Ty.beq d0 d1 && Ty.beq c0 c1 + | .tuple a, .tuple b => Ty.beqSeq a b + | .record a, .record b => Ty.beqFields a b + | .variant a, .variant b => Ty.beqTags a b + | .refined b0 p0, .refined b1 p1 => Ty.beq b0 b1 && p0 == p1 + | _, _ => false +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +def Ty.beqSeq : List Ty → List Ty → Bool + | [], [] => true + | t0 :: a, t1 :: b => Ty.beq t0 t1 && Ty.beqSeq a b + | _, _ => false +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +def Ty.beqFields : List (String × Ty) → List (String × Ty) → Bool + | [], [] => true + | (n0, t0) :: a, (n1, t1) :: b => n0 == n1 && Ty.beq t0 t1 && Ty.beqFields a b + | _, _ => false +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +def Ty.beqTags : List (FieldKey × Ty) → List (FieldKey × Ty) → Bool + | [], [] => true + | (k0, t0) :: a, (k1, t1) :: b => k0 == k1 && Ty.beq t0 t1 && Ty.beqTags a b + | _, _ => false +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +end + +instance : BEq Ty := ⟨Ty.beq⟩ + +mutual + +theorem Ty.beq_iff : (a b : Ty) → (Ty.beq a b = true ↔ a = b) + | .base _, b => by cases b <;> simp [Ty.beq] + | .uintRange _, b => by cases b <;> simp [Ty.beq] + | .dataSource _, b => by cases b <;> simp [Ty.beq] + | .txn, b => by cases b <;> simp [Ty.beq] + | .fn n0 k0 d0 c0, b => by + cases b <;> simp [Ty.beq] + case fn n1 k1 d1 c1 => + simp [Ty.beq_iff d0 d1, Ty.beq_iff c0 c1, and_assoc] + | .tuple ts, b => by + cases b <;> simp [Ty.beq] + case tuple bs => exact Ty.beqSeq_iff ts bs + | .record fs, b => by + cases b <;> simp [Ty.beq] + case record bs => exact Ty.beqFields_iff fs bs + | .variant tags, b => by + cases b <;> simp [Ty.beq] + case variant bs => exact Ty.beqTags_iff tags bs + | .refined b0 p0, b => by + cases b <;> simp [Ty.beq] + case refined b1 p1 => simp [Ty.beq_iff b0 b1] +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +theorem Ty.beqSeq_iff : (a b : List Ty) → (Ty.beqSeq a b = true ↔ a = b) + | [], [] => by simp [Ty.beqSeq] + | [], _ :: _ => by simp [Ty.beqSeq] + | _ :: _, [] => by simp [Ty.beqSeq] + | t0 :: a, t1 :: b => by + simp [Ty.beqSeq, Ty.beq_iff t0 t1, Ty.beqSeq_iff a b] +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +theorem Ty.beqFields_iff : + (a b : List (String × Ty)) → (Ty.beqFields a b = true ↔ a = b) + | [], [] => by simp [Ty.beqFields] + | [], _ :: _ => by simp [Ty.beqFields] + | _ :: _, [] => by simp [Ty.beqFields] + | (n0, t0) :: a, (n1, t1) :: b => by + simp [Ty.beqFields, Ty.beq_iff t0 t1, Ty.beqFields_iff a b] +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +theorem Ty.beqTags_iff : + (a b : List (FieldKey × Ty)) → (Ty.beqTags a b = true ↔ a = b) + | [], [] => by simp [Ty.beqTags] + | [], _ :: _ => by simp [Ty.beqTags] + | _ :: _, [] => by simp [Ty.beqTags] + | (k0, t0) :: a, (k1, t1) :: b => by + simp [Ty.beqTags, Ty.beq_iff t0 t1, Ty.beqTags_iff a b] +termination_by a b => sizeOf a + sizeOf b +decreasing_by all_goals (simp_wf; omega) + +end + +instance : LawfulBEq Ty where + eq_of_beq h := (Ty.beq_iff _ _).mp h + rfl := (Ty.beq_iff _ _).mpr rfl + +/-- Propositional equality of ground types is decidable. -/ +instance : DecidableEq Ty := fun a b => decidable_of_iff _ (Ty.beq_iff a b) + +/-- Whether `t` is a refinement node. The flattening invariant forbids one +directly under another, so this is what `Ty.WF` checks of a base. -/ +def Ty.isRefined : Ty → Bool + | .refined _ _ => true + | _ => false + +/-- Mirror of `Type::refined`: `base` narrowed by `refinements`, establishing both +invariants. No refinements is no refinement, and a base that is already refined has +`refinements` merged into its set rather than stacked on top. -/ +def Ty.mkRefined (base : Ty) (refinements : List Pred) : Ty := + match refinements with + | [] => base + | _ => + match base with + | .refined b ps => .refined b (ps ++ refinements.filter (· ∉ ps)) + | bare => .refined bare refinements + +/-- Well-formedness the Rust builders maintain but the `Type` representation +does not enforce: record fields and variant tags are keyed **uniquely**. + +The solver's find-first lookup makes this load-bearing: on a duplicate-keyed +record, `constrain`'s trivial-equality short-circuit would accept `t <: t` +while the record arm's find-first lookup would demand cross-subtyping between +the duplicates — reflexivity-as-a-theorem (`Sub.refl`) is provable exactly +under this invariant, which is the model naming an invariant the Rust leaves +implicit. -/ +inductive Ty.WF : Ty → Prop where + | base (b) : Ty.WF (.base b) + | uintRange (n) : Ty.WF (.uintRange n) + | dataSource (s) : Ty.WF (.dataSource s) + | txn : Ty.WF .txn + | fn {n k d c} : Ty.WF d → Ty.WF c → Ty.WF (.fn n k d c) + | tuple {ts} : (∀ t ∈ ts, Ty.WF t) → Ty.WF (.tuple ts) + | record {fs} : (fs.map (·.1)).Nodup → (∀ f ∈ fs, Ty.WF f.2) → + Ty.WF (.record fs) + | variant {tags} : (tags.map (·.1)).Nodup → (∀ t ∈ tags, Ty.WF t.2) → + Ty.WF (.variant tags) + | refined {b ps} : ps ≠ [] → b.isRefined = false → Ty.WF b → + Ty.WF (.refined b ps) + +end CclFormal diff --git a/formal/Main.lean b/formal/Main.lean new file mode 100644 index 00000000..6a1de6b0 --- /dev/null +++ b/formal/Main.lean @@ -0,0 +1,85 @@ +import CclFormal + +/-! +# The differential oracle + +Reads JSONL from stdin — one case object per line, tagged by `"op"` — and answers +one verdict line per case, or `error: …` when a line does not decode. An empty +line (or EOF) terminates. + +- `"sub"`: `true` / `false`, the model's `subCheck` on a ground type pair. +- `"merge"`: `ok`, or `mismatch: ` carrying the model's own merged bound. +- `"coalesce"`: `ok`, or `mismatch: ` carrying the model's own. + +The Rust half lives in `tests/differential_oracle.rs`, which generates +the cases, computes the solver's answer, and diffs it against this oracle. +-/ + +open CclFormal + +/-- `{"op":"sub","lhs":,"rhs":}` — the ground subtype verdict. -/ +def subVerdict (j : Lean.Json) : Except String String := do + let lhs ← Ty.fromJson? (← j.getObjVal? "lhs") + let rhs ← Ty.fromJson? (← j.getObjVal? "rhs") + pure (toString (subCheck lhs rhs)) + +/-- `{"op":"merge","pol":,"lhs":,"rhs":,"got":}` — whether the +Rust's merged bound is the model's, judged by `eqv`, the equality every theorem in +`CclFormal/Merge.lean` is stated up to. A mismatch answers with the model's own +result so the diff is in the failure message rather than in a second run. -/ +def mergeVerdict (j : Lean.Json) : Except String String := do + let pol ← Lean.fromJson? (← j.getObjVal? "pol") + let lhs ← CTy.fromJson? (← j.getObjVal? "lhs") + let rhs ← CTy.fromJson? (← j.getObjVal? "rhs") + let got ← CTy.fromJson? (← j.getObjVal? "got") + let want := CTy.merge pol lhs rhs + pure (if CTy.eqv want got then "ok" else s!"mismatch: {(CTy.toJson want).compress}") + +/-- `{"op":"coalesce","pol":,"ct":,"got":}` — whether the +solver's materialization of a bound is the model's. The outcome is +`{"k":"ok","ty":}`, `{"k":"unresolved"}` for a position that materialized to a +fresh inference variable, or `{"k":"err","kind":}`. A mismatch +answers with the model's own outcome. -/ +def coalesceVerdict (j : Lean.Json) : Except String String := do + let pol ← Lean.fromJson? (← j.getObjVal? "pol") + let ct ← CTy.fromJson? (← j.getObjVal? "ct") + let g ← j.getObjVal? "got" + let got : CTy.CoGot ← match ← (← g.getObjVal? "k").getStr? with + | "ok" => .ok <$> Ty.fromJson? (← g.getObjVal? "ty") + | "unresolved" => pure .unresolved + | "err" => .err <$> (← g.getObjVal? "kind").getStr? + | k => throw s!"unknown coalesce outcome: {k}" + let want := CTy.coalesce pol ct + if CTy.coalesceAgrees want got then + pure "ok" + else + pure <| "mismatch: " ++ + (match want with + | .ok none => "unresolved" + | .ok (some t) => (Ty.toJson t).compress + | .error e => s!"error {repr e}") + +def verdict (line : String) : String := + match Lean.Json.parse line with + | .error e => s!"error: parse: {e}" + | .ok j => + let checked : Except String String := do + match ← (← j.getObjVal? "op").getStr? with + | "sub" => subVerdict j + | "merge" => mergeVerdict j + | "coalesce" => coalesceVerdict j + | op => throw s!"unknown op: {op}" + match checked with + | .error e => s!"error: decode: {e}" + | .ok answer => answer + +def main : IO Unit := do + let stdin ← IO.getStdin + let stdout ← IO.getStdout + while true do + let raw ← stdin.getLine + let line := raw.trimAscii.toString + if line.isEmpty then + break + stdout.putStrLn (verdict line) + stdout.flush diff --git a/formal/README.md b/formal/README.md new file mode 100644 index 00000000..93ab5e03 --- /dev/null +++ b/formal/README.md @@ -0,0 +1,20 @@ +# formal/ + +The Lean 4 model of the CCL type system. Plan, milestones, and adjudicated +decisions: [design.md](design.md). + +```bash +cd formal +lake build # library (theorems + #guard spec examples) + the oracle +``` + +The toolchain is pinned by `lean-toolchain`; `elan` fetches it on first build. + +`lake build` also produces `.lake/build/bin/subverdict`, the M1 differential +oracle. The Rust half is an ordinary unit test that skips (loudly) when the +binary is absent: + +```bash +cargo test differential_ground_subtype +CAMBRA_DIFF_N=20000 CAMBRA_DIFF_SEED=7 cargo test differential_ground_subtype -- --nocapture +``` diff --git a/formal/design.md b/formal/design.md new file mode 100644 index 00000000..d4af6e22 --- /dev/null +++ b/formal/design.md @@ -0,0 +1,377 @@ +# Formalizing the CCL type system in Lean + +This document is the plan of record for `formal/`: a Lean 4 model of the CCL type system, grown milestone by milestone, whose purpose is **catching real bugs** in the Rust implementation. Confidence in the metatheory and bug-catching are treated as the same goal: every layer of the model gets an executable form and a differential oracle against the Rust from day one. Proofs pin down the model; the oracle pins the model to reality. + +The implementation being modeled is the algebraic-subtyping engine described in [type-inference.md](../src/ccl/design/type-inference.md#1-algorithm-overview); the semantic model targeted by the final milestone is described in [mutability.md](../src/ccl/design/mutability.md#the-model-histories-and-causal-recursion). + +## The oracle stance: the model checks, it does not reproduce + +The central architectural decision. Monomorphization, simplification, and coalesce ordering make the Rust's inferred types non-canonical — demanding that a Lean model reproduce inference output bit-for-bit would drown the project in incidental divergence. Instead: + +- **Lean infers nothing; Lean checks.** The differential property is *admissibility*: whatever type the Rust inferred for a term, the Lean declarative system accepts that term at that type. This is exactly the soundness direction, it is robust to the solver choosing any of several valid types, and a failure is almost always a real finding — either a solver bug or a spec gap, both of which are the point. +- Exact agreement is demanded of the two operations that *are* functions of their inputs. The **ground subtype relation** (no `Infer` variables on either side): `constrain(𝑇, 𝑈)` on ground types succeeds iff the Lean checker decides `𝑇 <: 𝑈` — a crisp boolean oracle, exercising the nastiest comparison code (`without_pi_names` α-handling, `Variant` width subtyping, refinement equality, `UIntRange`). And the **bound merge**: every step of a fold through `CompactType::merge` equals the model's `merge` up to `eqv`. Neither is order- or route-sensitive, so neither needs the admissibility stance. + +### What is pinned today, and what is not + +Two operations are pinned. Everything else in the solver is unmodeled — the +milestones below are the plan for closing that, and until a row says otherwise its +only coverage is ordinary Rust tests. Read a refinement about "the model" against this +table rather than against the milestone list, which describes intent. + +| Solver component | Model | Differential | Proofs | +|---|---|---|---| +| `constrain_subtype`, ground pairs | `Sub` / `subCheck` | yes | reflexivity, transitivity, decidability | +| `CompactType::merge` | `merge` | yes, every fold step | commutativity, idempotence, associativity, congruence, lub, uniqueness | +| bound recording, sweeping, `extrude` | — | — | — | +| `traits` (operator obligations) | — | — | — | +| `compact_go` (bounds → `CompactType`) | its *output shape* is `CTy` | supplies operands; never itself checked | — | +| `simplify_type` | — | — | — | +| `coalesce_compact` (`CompactType` → `Type`) | `coalesce` (`Coalesce.lean`) | yes, per materialized bound | totality; the lub/glb bridge measured over a bounded sample (`Bridge.lean`), not yet proved | +| `scheme` (freshening, generalization) | — | — | — | +| term typing as the solver infers it | `Term` / `Safety`, a small calculus | — (the admissibility oracle above is planned) | progress, preservation, refinement soundness | + +Two consequences worth stating plainly. `compact_go` is unmodeled, and the merge +and coalesce differentials both *use* it to build their operands — so a +`compact_go` defect would be reproduced identically on both sides of those +comparisons rather than caught by them. And `coalesce` is modeled and total but carries no +theorems yet; the lub theorem is M4c. + +Mechanically: + +- a `test-helpers`-gated Rust binary speaking a JSON encoding of `Type` / `TypedExpr` over stdin, answering subtype and typing queries; +- a Lean executable (`lake` builds real binaries) as the checker; +- case generation on the Rust side with `proptest`, so the generators can be biased toward the corners we already know are nasty (refinement predicates closing over Pi binders, shared sources, `case` payload binders); +- the whole harness wired as an ordinary `cargo test`, so it rides `./ci.sh` like everything else. + +## Milestones + +> **Which code this copy sits beside.** The model lands at the top of the +> telescope stack — +> [type-inference.md](../src/ccl/design/type-inference.md#scoped-inference-variables-a-stored-bound-closes-against-a-telescope) +> is the design of record — so every repair the findings below record (the +> `RefinementSet` representation, term-determined cast refinements, the +> content-determined refinement-application order, the type-merge fuzz) is in +> the code beneath it. + + +Each milestone produces (a) Lean definitions and theorems, and (b) where marked, a differential oracle. Later milestones depend on earlier ones except where noted. + +### M0 — Types and the declarative subtype relation + +Grammar: `Base`, `UIntRange`, `Fun` (carrying the optional Pi binder), `Tuple`, `Record`, `Variant`, `Refinement` with syntactic-equality predicates. `FunKind` is included **in the grammar from the start** as a static two-point flag (`⇒` vs `⤇`) — kind *inference* waits for M5, but `⇒`/`⤇` distinctness affects type equality and subtyping now, and retrofitting a grammar field into a Lean development touches every proof while an unused constructor argument costs nothing. + +Deliverables: + +- the declarative relation `𝑇 <: 𝑈` — which does not exist in any standalone form today; the Rust operationalizes subsumption inside `constrain` without ever stating the relation it implements; +- reflexivity and transitivity; +- an executable checker with soundness and completeness against the relation (i.e. decidability); +- the JSON codec matching the Rust `Type`. + +Merely stating the rules will force decisions the implementation currently makes implicitly. The questions raised at planning time are adjudicated below. + +Binder representation: **de Bruijn indices for a refinement's references to its own functions** (`Pred.piBound`), free references as names — mirroring `Name::PiBound` and the locally-nameless representation of `src/ccl/design/type-inference.md`, "A binder reference is stored in one of two forms". Ground types are closed (construction converts a binder reference to its index), so the relation carries no rename environments and two α-variant function types are the same term. The model's first edition made the opposite choice — named binders with explicit rename environments, mirroring `extended_rename` one-to-one — and that was right *then*: it modeled the solver that existed, and its transitivity development is what isolated the σ-gap and pushed the solver to closing into indices. When the solver moved, the environments retired from both sides at once. + +#### M0 status and adjudicated decisions + +Landed: the lake project (toolchain pinned to v4.32.2), the ground grammar `Ty` + the `WF` (uniquely-keyed) invariant, the declarative relation `Sub`, the executable checker `subCheck` (termination proved), the hand-written JSON codec with round-trip guards, executable spec examples (one `#guard` per decision below), and `Sub.refl`. + +**Decidability is proved** (`CclFormal/Equiv.lean`): hand-written structural equality bridged to propositional equality (`Ty.beq_iff`, giving lawful `BEq`/`DecidableEq`), then checker soundness (`sub_of_subCheck`) and completeness (`subCheck_of_sub`), so `subCheck` decides exactly `Sub` and `Decidable (Sub ρl ρr lhs rhs)` is an instance. Every `#guard` in `Decide.lean` is thereby a fact about the relation, not merely about the checker. + +**Transitivity** is proved in full — `CclFormal/Transitivity.lean :: sub_trans`, for well-formed types, with no fragment restriction and no environment side conditions (the statement quantifies over nothing but the three types; well-formedness contributes only claims-non-emptiness, without which the degenerate `refined 𝑏 []` refutes the re-wrap step). Proof shape: fuel-bounded strong induction on the summed size, split into a *peel route* (some side carries a refinement layer → peel all three, recurse, re-wrap, with refinement-set containment composing by a membership chase) and a *head-constructor route*. The two ways to conclude a function edge are factored into one helper (`sub_trans_fn`) that takes the induction hypothesis explicitly, so `fnCompute` and `fnData` are handled once. `sub_peel_inv` carries the load: universal peel inversion — every rule leaves the peeled bases related and the peeled sets contained. `Decide.lean` pins one composed chain executably, whose two hops are contravariant record widenings (the kind is fixed across a chain, so it cannot be one of the hops). + +The statement's history is the model earning its keep, so it stays recorded. The first edition proved transitivity for the `NoPi` fragment, then for a canonical-spelling fragment under six independent identity-acting rename environments; the obstruction past that was the **σ-gap** — chaining dependent codomains produced premises viewing the middle type under different renames, composing only through a reconciliation morphism, the model analogue of `constrain.rs :: bridge_holder_gap`. Closing into indices does not dissolve the gap; it never forms it. That asymmetry — one edition needs a reconciliation theory, the other needs nothing — is the model's verdict on the two solver designs. + +**Finding: α-variant dependent types split identity sites — the Pi binder is the last non-canonical identity.** Probed after the transitivity proof isolated Pi binders as the sole remaining obstruction. Two independently-derived, semantically-identical dependent types — `(𝑥: 𝐷) ⤇ {Int | __elem == 𝑥}` at one call site, the same under `𝑦` at another — are reconciled by the *relation* (both subtype directions hold, α-aware) but not by the *identities*: + +- **`SpecKey` splits** (`spec_key_splits_on_alpha_variant_dependent_types`). The key deliberately excludes the binder name, but the name survives through predicates that reference it, which the key compares structurally — so uses that should share a specialization get one clone each (over-splitting: wasted clones, not a miscompile, per `spec_key.rs`'s own taxonomy). Notably the key's stated rationale for excluding the name — per-site fresh solver binders "would split every use into its own key" — is re-imported through exactly this leak whenever such a binder is referenced by a keyed predicate. +- **Bound merge is order-dependent and dangles** (`alpha_variant_bound_merge_is_order_dependent`). Two α-variant upper bounds meeting at a variable merge into a fun shape keeping the *first arrival's* binder (`compact.rs`: `a.name.or_else(|| b.name)`) while the refinement sets union — coalescing to `(𝑥: 𝐷) ⤇ {{Int | __elem == 𝑥} | __elem == 𝑦}`: arrival-order-dependent *and* carrying a predicate that references a binder the type no longer binds. The two predicates are α-copies of one constraint that structural dedup cannot collapse. + +This was the third member of the non-canonical-identity family (with the trivial-equality/find-first duplicate-key disagreement and refinement-layer order), and it is **repaired by the locally-nameless representation**: a refinement's reference to an enclosing function closes into a de Bruijn index at construction (`Name::PiBound`; `src/ccl/design/type-inference.md`, "Where the conversions run"), so two α-variant closed function types are structurally identical wherever the merge, the caches, and `SpecKey` compare them. The pinned tests assert the repaired behavior (`spec_key_shares_alpha_variant_dependent_types`, `alpha_variant_bound_merge_is_canonical` — one refinement layer, index-spelled, nothing dangling, arrival-order-independent modulo the display-only binder slot). An earlier repair canonicalized binders to reserved depth-indexed *names* as types flattened; it worked, and retired unmerged because the conversion ran in three walks that had to agree and the birth-to-flatten window stayed unchecked — construction assigns the index once, at abstraction. + +**The grammar carries a refinement set, and claim order is proved unobservable.** `refined` holds a `List Pred`, mirroring a refinement position's refinements, with `Ty.WF` naming the same two invariants `Type::refined` establishes: the refinements are non-empty, and the base is not itself refined, so layers never nest. The non-emptiness is what `sub_trans`'s re-wrap step consumes — an empty refinement set is not a refinement but its base, and without the invariant a degenerate `refined 𝑏 []` would peel to nothing while remaining a distinct term, making `peel_nil_self` simply false. + +The refinements are *represented* as a list and `Ty.beq` compares them positionally, which is what keeps `beq` propositional equality and so keeps `DecidableEq` — the bridge every proof here rests on. What makes that faithful to an unordered `RefinementSet` is that the **relation** cannot see the list structure, and that is now a theorem rather than a reading of the rules: `sub_refinements_left` / `sub_refinements_right` (widening the supplied refinements, narrowing the demanded ones) and their corollaries `sub_refinements_perm` / `sub_refinements_perm_right`. They are stated as *containment* rather than permutation because containment is what `deficit` actually uses — a supplier list may be reordered, duplicated, or widened freely — so reorder- and dedup-invariance both fall out, which is exactly the latitude the Rust representation takes. + +All prior results are re-established sorry-free over the new grammar: `Sub.refl`, `subCheck` soundness/completeness and `Decidable (Sub …)`, and `sub_trans` / `sub_trans_id` for the canonical fragment. + +**Base of record.** The model mirrors `constrain_go` as of the stack this branch sits on: `main` plus canonical Pi binders at the flattening layer, the refinement-set refinement representation, and canonical cast discharge. The differential harness is what holds that correspondence, so a divergence is a test failure rather than a doc claim. + +**Grammar exclusions.** `Infer`, `SharedHole`, `History`, `ChanDom`, `App`, `Below`, and `FunKind::Var` are all inference-time transients or unknowns — outside the ground fragment by the same criterion that keeps them out of a fully-inferred program's types. + +**Adjudications** (each is a `Sub` rule with a matching `#guard` in `CclFormal/Decide.lean`): + +- **`UIntRange` is equality-only.** No range inclusion, no `UIntRange <: Int` — a range is a data domain (a loop bound), and the solver treats it nominally. `[0,3) ⊀ [0,4)`. +- **Refinements** (`𝑆ᵢ` a refinement *set*, per `RefinementSet`): `{𝑏₁ | 𝑆₁} <: {𝑏₂ | 𝑆₂}` iff `𝑆₂ ⊆ 𝑆₁` (structural, type-blind predicate equality, after transport through each side's rename — never implication) and `𝑏₁ <: 𝑏₂`. So dropping refinements is subsumption, conjuring one is not (that is an explicit `Restrict`), and the **base is covariant**. +- **Refinements do not distribute over `Variant`** (or anything else): they are compared layer-wise where they sit; the peel is only of *outer* layers on both sides. +- **Function kinds relate by equality**: a collection where a capability is demanded is a rejection, and so is a capability where a collection is demanded. The kinds denote different things — a data function's domain *is* its data — so neither direction is a safe weakening, the ordering `data ⊑ compute` included. +- **Domains**: contravariant, except **data-data pairs are invariant** (both directions — the domain *is* the data). Codomains covariant, compared directly — a refinement's binding is its index, so the edge carries no binder correspondence. +- **Products/sums**: tuple positional width; record named width with **find-first** lookup; variant is the dual (lhs tags looked up find-first in rhs). Payload depth covariant throughout. +- **Reflexivity is a theorem, not a rule** (`Sub.refl`) — the model omits `constrain_go`'s trivial-equality short-circuit and proves it derivable. The proof requires `Ty.WF` (unique record/variant keys): on a duplicate-keyed product the short-circuit and the find-first arms genuinely disagree, so the model names a builder invariant the Rust leaves implicit. + +- **A `Variant` domain relates only to a `Variant` domain.** No rule collapses a `Variant` of refined legs to the domain they share, because no comparison presents that pair: a value-`Case` fan-out is a `DisjointJoin` over the one domain its arms share ([ir.md](../src/ccl/design/ir.md#copair-and-disjointjoin--two-collection-combining-operations-not-one)). The rule that used to exist, and the two defects it carried, are the closed finding below. + +**Footnote — where the index representation lives, Rust-side.** The design of record and the alternatives measured against it are in [type-inference.md](../src/ccl/design/type-inference.md#a-binder-reference-is-stored-in-one-of-two-forms), "A binder reference is stored in one of two forms": free references (telescope entries) stay uniquified names, a fragment's own functions' references are de Bruijn indices assigned at abstraction, and the conversions run at construction, refinement landing, descent, and application. Mid-solve, name-spelled forms still exist (an emitted function's codomain variable accumulates name-based claims); the *ground* fragment this model states `Sub` over is the closed one — what construction produces and what a checked program exhibits. + +An earlier footnote here recorded two refuted placements: minting canonical binders at emission (refuted — a dependent refinement rides a bound edge, and the variable holding it need not sit under the binder its predicate references, so there is no position to index against *in transit*), and the flatten-time canonical *names* that repaired the α-findings first (worked, retired unmerged — three walks had to agree and the birth-to-flatten window stayed unchecked). Assigning the index at construction keeps what both were after — position-relative identity — by doing it once, where the position is created. + +**Finding (closed): ground subtyping was not transitive while a rule related a partitioned domain to a plain one.** The chain `⧺{𝐷|π} ⤇ 𝑊 <: 𝐷 ⤇ 𝑊 <: 𝐷′ ⇒ 𝑊`, with `𝐷′ <: 𝐷` strictly by record width, held hop-by-hop while the direct edge failed: the rule demanded the stripped legs equal the stripped *target* structurally, so widening the target turned it off and no general arm relates a `Record` domain to a `Variant` one. Whether a partition satisfied a demand therefore depended on whether an intermediate plain binding sat in between — typing that can depend on constraint order. Evidence in three forms: a machine-checked counterexample, a pinned Rust test, and the chain fuzz (~100k accepted chains, ~285 violations, every one that shape). The same rule recursed its codomain edge under the unchanged lhs morphism, so α-equivalent dependent codomains reconciled through the general function arm and failed through this one — the verdict turned on domain shape alone. + +Splitting `CollectionUnion` into `Copair` and `DisjointJoin` closed both defects by deleting the rule. The fan-out was its sole producer, and a `DisjointJoin` carries the arms' shared domain directly, so the pair the rule existed to relate no longer reaches a comparison. The model states the absence as a departure (`Sub`'s module doc), pins the verdict in `Decide.lean`, and the differential harness holds it: 90k pairs across three seeds agree with `constrain` after the removal, and the chain fuzz reports zero violations over 90k chains. + +**Tracked divergences and observations:** + +- **`Subst::extended_rename` shadowing** is modeled as prepend-with-first-match-wins; confirming that against the Rust's composition semantics is an M1 fuzz target. +- `formal/` is not yet wired into `./ci.sh` — that adds a Lean toolchain dependency to everyone's gate, so it is a deliberate pending decision, not an oversight. + +### M1 — Ground-subtype differential fuzz *(oracle)* + +The M0 checker vs `constrain` on ground type pairs. The cheapest real-bug detector in the whole plan. + +#### M1 status + +Landed and running. The pieces: + +- **Oracle**: `lake build` produces `subverdict` (`formal/Main.lean`), which answers `true`/`false` per JSONL `{"lhs", "rhs"}` line using the model's `subCheck` under identity morphisms. +- **Harness**: `tests/differential_oracle.rs`, an integration test sharing the seeded generator (`tests/type_gen/mod.rs`) with `tests/type_merge_fuzz.rs`. It reaches `CompactType::merge` through the `test-helpers` feature, which is the only slot the solver's crate-internal API opens for it. It skips loudly when the oracle binary is absent, so machines and CI without a Lean toolchain stay green. Knobs: `CAMBRA_DIFF_SEED` / `CAMBRA_DIFF_N`. +- **Generation**: a hand-rolled seeded xorshift generator — deterministic and dependency-free (`proptest` was planned; a new dev-dependency wasn't warranted for this). Three pair modes: identical pairs (exercises the refinement that reflexivity is derivable), top-level directed edits (width/refinement near-misses), and **correlated pairs** — both sides built together, usually identical, occasionally diverging in exactly one nested aspect (a leaf, a kind flag, a binder name, a predicate target, a width). Deep near-misses are where subtle rule divergence hides. The generator writes dependent shapes name-based (the natural spelling) and a closure pass (`close_all`) converts each case into the ground closed fragment — every function's own-binder references as indices — before both sides receive it, so the index representation is exercised at every nesting depth alongside genuinely free references. +- **Emitter**: `Type` → the wire schema of `formal/CclFormal/Json.lean`, total on the ground fragment, refusing (not mis-serializing) anything outside it or outside the `Pred` vocabulary. + +Results at the time of writing: **~800k cases across nine seeds, zero verdict mismatches**, plus **140k across five seeds after the refinement-set grammar landed** (the wire schema's `refined` node now carries a `refinements` array, and the generator's nested refinements flatten into multi-refinement positions, so the new shape is exercised throughout), plus **90k across three seeds after the partition-collapse rule was retired from both sides**, plus **150k across five seeds against the index-based model** — a run that first *failed*, catching a real capture in the solver's Fun/Fun opening: reopening a ground closed codomain at its display name let an unrelated free reference sharing that spelling match the reopened index. The live solve now opens only toward a side that carries inference variables (where a dangling index could land on a recorded fragment); ground closed pairs compare index-to-index. The finding is the oracle working as designed — the mismatch was between what the solver did and what the relation says, on a shape no test program produces. Verdict mix is roughly 42–44% accept, so both classes are exercised. Harness sensitivity is tested rather than assumed: the duplicate-keyed-record reflexivity case — the one known deliberate divergence, outside `Ty.WF` — flags as a mismatch when fed through the pipe by hand, and `constrain_go` now **asserts** the uniquely-keyed invariant in debug builds, before its trivial-equality short-circuit — the only placement that covers `𝑡 <: 𝑡`, the case the short-circuit and the find-first arms answer differently — so the type they disagree on can no longer reach the comparison unnoticed (`dup_key_record_trips_the_uniquely_keyed_invariant` pins that the assert fires). The `extended_rename` prepend-shadow assumption listed above is now empirically backed by the fuzz (within the generated vocabulary: two binder names, arbitrary nesting, deliberate misaims). + +The generator's one exclusion is duplicate record/variant keys (outside `WF`) — a documented gap, not a silent one. + +### M2 — Terms, typing, and safety + +Declarative typing `Γ ⊢ 𝑒 : 𝑇` for the pure core — λ, apply, compose, let, literals, tuples/records, variants, `case`, refinements — plus a small-step semantics, and **progress + preservation**. Two corollaries earn their keep against known bug classes: + +- **Refinement soundness**: `⊢ 𝑒 : {𝑇 | 𝑝}` and `𝑒 ⇓ 𝑣` implies `𝑝(𝑣) ⇓ true`. The theorem form of "a refinement is a fact about a value", and the property the literal-singleton-types work leans on. +- **Case-binder preservation**: the `case` payload binder retains its scrutinee-derived bound through reduction. A previously-observed defect — the wildcard `case _:` arm's payload binder losing its scrutinee bound — is precisely a counterexample to a lemma of this shape; retroactively rediscovering that known bug is the calibration test for the whole model. + +#### M2 status and adjudicated decisions + +Landed: the definitional core (`CclFormal/Term.lean`) — the pure-core term grammar `Tm` (lit, var, λ, apply, let, tuples, projection, variants, `case`, `cast`), values, capture-free substitution, partial predicate evaluation (`Pred.eval`, the interpreted `BinOpKind` vocabulary), the call-by-value small-step `Step`, the *filter-blocked* judgment `Blocked`, and the declarative typing `HasTy Γ e T` with subsumption via the M0 `Sub` relation. Sanity theorems: values neither step nor block. Adjudications, on contact: + +- **Terms are de Bruijn; types keep named Pi binders.** Subtyping never moves a binder (names-with-renames mirrored the Rust exactly); reduction duplicates and re-scopes binders, where names buy only α-obligations — and the Rust's term binders are uniquified, hence α-irrelevant. The M3 bridge maps uniquified names to indices mechanically. +- **Non-dependent fragment first** (`Pred.elemOnly`): predicates over `__elem` only, so types are closed under term substitution — the same fragment the transitivity proof covers (`NoPi`); the dependent extension rides with the Pi-binder thread. +- **`cast` checks its refinements; progress is modulo filtering.** A cast is CCL's refinement introduction (a filter's lowering), and its runtime face (`Restrict`) *drops* elements. The small-step mirrors this: `cast` passes a value through exactly when every refinement evaluates true, else the term is `Blocked` — the scalar face of a dropped row. Progress will read "value, steps, or filter-blocked"; refinement soundness holds because the cast is the only door into a refined type. + +Landed second (`CclFormal/Safety.lean`, sorry-free): the full safety battery — weakening and the substitution lemma (the de Bruijn payoff: no value restriction, no fragment hypothesis, types untouched by term substitution), canonical forms modulo refinement peeling (`canonical_fn`/`canonical_tuple`/`canonical_variant`), **progress** (`HasTy [] e T` → value ∨ steps ∨ filter-blocked), **preservation**, multi-step preservation, **refinement soundness** (`⊢ e : {T | claims}` ∧ `e ⇓ v` → every refinement evaluates true on `v`), and `case_binder_sound` (the tag-arm case-binder statement). Structural choices and further adjudications, on contact: + +- **`Sub` inversions are case analyses, not inductions.** Every `Sub` constructor pins both sides' head constructors and the `refined` arm recurses on fully-peeled bases, so `Sub.to_peel` plus one non-recursive `cases` per head (`fn_src`/`fn_inv`/`tuple_inv`/`variant_inv`) is the whole inversion story — none of transitivity's machinery. +- **Typing inversions absorb subsumption chains by *typing transport*, not `Sub` composition.** `HasTy.lam_inv` returns implications "whatever is typed at `X` is typed at `Y`" (`TyImp`) — reflexive without `Sub.refl`'s `WF` side condition, composable link-by-link, each link re-entering typing via `HasTy.sub` directly. (The first edition needed `Sub.rename_invariant` here to bring each link's morphisms back to identity; the environment-free relation has nothing to bring back, and the lemma is gone with the machinery it compensated for.) +- **The fragment is enforced in the judgment** (`Ty.TermFrag` premises on the rules that choose types freely: `lam`'s domain, `variant`'s tags, `sub`'s target, `caseE`'s result — the last free only in the degenerate empty-tags elimination). Hypothesizing the fragment only at the theorem boundary cannot confine a derivation's *internal* types, since `sub` detours through arbitrary types. The fragment itself is claims-over-`__elem`-only: a dependent refinement references an enclosing frame the term judgment does not scope, so its truth on a value is not even stated here; the dependent extension enters when the judgment scopes its types' frames. `hasTy_frag` is the invariant, stated: under a fragment context every derivable type is in the fragment. +- **`refineV` — checked values inhabit the refinement.** Preservation forces a value-level refinement introduction: `cast p v` (refinements holding) steps to `v`, and `Sub` deliberately forbids refinement conjuring, so without a new rule `v` loses its refined typing and preservation is false at `castV` for every cast. `refineV` types a value at `{T | claims}` when `refinementsHold refinements v = true` — the term-model face of "a refinement is a fact about a value" (the literal-singleton-types thread), and exactly the knowledge the `castV` step validates at runtime. +- **Case-binder calibration deferred with the wildcard extension.** `case_binder_sound` is the *naive tag-arm* statement, and it is a theorem — as it should be: the Rust's `case _:` payload-binder defect lives in wildcard arms, which `Tm.caseE` does not yet have. The calibration (the defect refuting the naive wildcard statement) needs that modeling extension, recorded in `Term.lean`'s module docs as a later increment. + +**Finding (closed): partition collapse fired at compute kind, where it broke preservation under the tagged-value reading of `Variant`.** The collapse applied at any kind, which is sound when the variant `⧺ᵢ({𝐷 | π̂ᵢ})` in domain position describes untagged pieces of a collection. A `variant` type in the term calculus means tagged values, and under that reading the collapse licensed a preservation violation at beta: `λ 𝑥 : 𝑃 → …` typed at `𝑃 ⇒ 𝑐` (`𝑃` a single-leg partition of `Int`) retyped via the collapse to `Int ⇒ 𝑐`, so `5` flowed in and substituted a bare literal where the body expects a variant, and `lit 5` has no typing at `𝑃`. Rust-side soundness rested on an invariant nothing stated: index-contiguous same-base variants are fan-out descriptors, never value-variant types a `case` or variant construct produces — `Variant` was two concepts told apart by a tag convention. Deleting the collapse resolves both halves: the fan-out builds a `DisjointJoin` over its arms' shared domain and never puts a partition-shaped variant in domain position, so `Variant` carries only the tagged-value reading and `Ty.TermFrag` needs no condition excluding partitioned `fn` domains. + +Remaining under M2, recorded: `compose`, records, wildcard `case` arms (the calibration), and the dependent-fragment safety extension (waits for the discharge machinery; see M3b's note). + +### M3 — Typing oracle *(oracle)* + +The Rust dumps the typed AST for generated small programs; Lean checks admissibility of the root typing. This is where the model starts catching *inference* bugs rather than comparison bugs. + +### M3b — Dependent-fragment transitivity *(closed by closing into indices)* + +Closed, and not by proving what it asked for. The milestone planned two pushes — canonical-fragment transitivity, then α-aware transitivity with rename-environment composition through the middle type, framed as a bug hunt. The first landed (its σ-gap analysis is summarized under M0); the second never ran, because the hunt's biggest finding preempted it: the environments themselves were modeling a solver form worth retiringnate worth retiring. With refinements closed into indices at construction (`Pred.piBound`, mirroring `Name::PiBound`), `sub_trans` is the full statement over well-formed types, the rename machinery is deleted from relation and model alike, and there is no α-aware statement left to attempt — the fragment restriction and the environment side conditions were the *cost of names*, not of transitivity. + +What the milestone leaves behind: the M2 *safety* extension to dependent types (the discharge/β modeled at the term judgment, so `TermFrag` can admit index-bearing claims) remains open, tracked under M2. + +### M4 — The solver model + +`constrain` / coalesce modeled as a state monad over a store of variables with bound lists, fuel-based at first. Two theorems: + +- **Soundness**: every bound the solver records is derivable in the declarative `<:` — and the coalesced output type is admissible for the term (connecting M4 back to M2). +- **Termination**: replace fuel with a well-founded measure. Prioritized because it is the property with live field bugs (a hanging build in this repo is, as a working rule, solver non-termination). The measure has to account for the seen-cache *and* for `extrude` minting fresh variables; being forced to articulate it will either yield a proof or expose that termination is currently contingent on something unstated. + +Levels and extrusion enter the model here (scope-escape soundness is a natural third theorem, but is subordinate to the two above). + +#### M4 preview: the type-merge fuzz + +Landed early, Rust-side only (`tests/type_merge_fuzz.rs`), because it targets order-independence claims the code makes without tests: `KindMerge`'s "forces propagate transitively along links as they arrive, so ordering does not matter", and the one-sided var-var bound propagation recorded as an open question in [type-inference.md](../src/ccl/design/type-inference.md#1-algorithm-overview). The harness applies the same constraint *set* (ground bounds, var-var edges, kind-variable functions) in permuted orders against fresh variables, coalesces every variable, and asserts outcomes agree — where an outcome is acceptance (through coalesce) plus the canonicalized per-variable types. *Which* constraint trips the rejection of an unsatisfiable set is intrinsically order-relative under record-then-sweep and deliberately not part of the outcome. + +**Finding (repaired): refinement layers stacked in constraint arrival order — the representation served three incompatible views.** Two refined upper bounds meeting at one variable coalesced to `{{𝑇 | 𝑞} | 𝑝}` or `{{𝑇 | 𝑝} | 𝑞}` depending on which arrived first (≈1 in 10k generated sets). Subtyping was indifferent — the deficit machinery compares layers as a set — but `Type`'s derived `PartialEq` was order-sensitive, and structural equality is load-bearing where types are *identities*: the trivial-equality short-circuit, cache keys, and recorded-vs-recomputed walls. One `Vec` served a *set* to subtyping, a *stack* to planning (the outermost layer drove which restrict it materialized), and an *identity* to `SpecKey`/caches. + +**The repair is the representation, not a canonical order.** `Type::Refinement` now carries a `RefinementSet` — an unordered, deduplicated set with set-semantic `Eq`/`Hash` — and `Type::refined` flattens, so nested `{{𝑇 | 𝑝} | 𝑞}` is *unrepresentable* and "which layer is outermost" cannot be asked. Canonically sorting the `Vec` was tried twice and rejected: it pins the ambiguity instead of deleting it, it costs a total order over predicate terms whose only job is layout, and it denies planning the freedom to apply filters in whatever order a cost model prefers. + +One thing the change forced into the open, previously implicit: + +- **Materializing refinements is a pipeline, and a pipeline is ordered.** Planning emits one `restrict` per refinement, and stage 𝑘 reads elements already narrowed by stages 1..𝑘-1 — so a refinement's predicate is typed against the base *narrowed so far*, not the bare base. The set is unordered as a fact; planning *chooses* an application order. Which order is free; choosing differently in two places is not, so `ccl::application_order` is the single place the choice is made and both `wrap_with_iterate` and `compile_predicates_in_type` walk it. +**Finding (closed): refinement dedup was order-sensitive because passes made a cast's refinements route-dependent.** The mechanism, found by structural diff of the surviving twins: `coalesce_node` **overwrote a `Cast`'s `target` wholesale with the occurrence's coalesced view** (`expr.ty`) — and *which* refinements an occurrence's variable accumulates depends on the route bounds took through the graph, so two copies of one embedded cast (a comprehension source cloned into a filter predicate) could end up carrying different refinement sets: one bare, one decorated with a sibling layer's filter. Refinement equality — deliberately cast-target-aware — then refused to dedup them. The repair is **canonical discharge as a term-determined rule** (`canonical_cast_ty`): a cast's *target* keeps exactly its **born refinements** (the assertion, fixed when the cast was written — inference resolves its bases, never rewrites its refinements), and the node's *type* is the value's own domain refinements joined with them (what the assertion yields on this value; the walk is bottom-up, so the value's type is already canonical by induction). The two must stay distinct: the post-inference check recomputes a cast's type as value-refinements ∪ target-refinements, so a target that also carried the value's refinements would double-book them. Planning's refinement-application order was made content-determined in the same stroke (`application_order` sorts by rendered predicate), so the built pipeline no longer leaks the set's physical order. + +The residue that outlived the coalesce fix had the **same overwrite surviving in the rebuild passes**: `sync_cast_targets` (at the tails of `lambda_elim::run`, `planning::run`, and inlining) stamped each cast's rebuilt `expr.ty` over its `target`. The rebuilt type is derived from surrounding term structure — and where inference leaves route-dependent types in *eq-blind* slots (a lambda param annotation inside a still-pointful predicate, say), that re-derivation is route-dependent too, so the sync promoted a benign divergence into the one slot refinement equality compares. Chain of custody for the last reversed failure: `simplify`'s collapse-a-chain-to-its-single-element rule stamped the chain's (route-dependent) interface type onto a surviving cast → `sync_cast_targets` copied it into the target → planning's per-claim compile embedded the now-divergent cast into two copies of one refinement → the post-planning wall's value ∪ target union met twins that would not dedup. Repairs, all instances of the same rule (a rebuild pass resolves bases, never decides claims): the collapse rule restores the canonical cast type at construction; `sync_cast_targets` is retired in favour of `canonicalize_cast_types` (target = born refinements on the rebuilt view's bases; type = value-refinements ∪ born; a chain headed by a cast follows its head's domain when they differ only in claims); a cast target's refinements compile against the **value's domain** (the assertion base — matching the checker, which types target predicates with `__elem` bound at the value's domain), not the target's bare base. With these, the full suite is green under `CAMBRA_REFINEMENT_ORDER=reverse` — the first fully order-independent state — and the sweep diagnostic (collect every refinement tree-wide, group by render, compare eq-classes) reports zero divergent render groups at every stage. + +**Finding (superseded by the above): refinement dedup is order-sensitive, because refinement equality distinguishes vintages that rendering does not.** The representation change removes order from the *type*; it does not reach predicate *identity*. `eq_refinement_predicate` deliberately compares a cast's target predicate, so the vintages a dependent-application discharge mints — `𝑝(xs)`, `𝑝(cast(xs))`, … — are unequal and do not dedup, while rendering identically. Running the suite under `CAMBRA_REFINEMENT_ORDER=reverse` exhibited it on the edition of the stack this was written against: a refinement set grew a second copy of one restriction and a recorded type disagreed with its recomputation while printing the same. That surface is no longer reached — a refinement's binding is its *index* rather than its spelling once the telescope coordinate is beneath the stack, and instrumenting `RefinementSet::insert` for a member that renders alike without being `eq` counts zero over the corpus in either order. `cast_target_vintages_render_alike_but_do_not_dedup` therefore pins the equality as intended behaviour rather than as an exhibit. + +The *manufacture* is still reachable, which is what canonical discharge below repairs: the wholesale target overwrite differs from the term-determined refinement set at 14 cast sites over the corpus, in either order, and a nested filter is enough to reach one. The double-booking it leaves is currently absorbed because the two copies are `eq` and the set deduplicates them; it stops being absorbed exactly when they are two vintages. So the two halves are one finding read at two distances — `a_cast_target_does_not_carry_its_value_s_refinements` pins the reachable half. + +So the blocker was a **predicate-identity question**, not an ordering mechanism: are two vintages of one refinement the same refinement? Vintage-blind equality (peel embedded casts before comparing) is non-transitive as stated (`xs ≡ cast{𝑎}(xs)` and `xs ≡ cast{𝑏}(xs)` but `cast{𝑎}(xs) ≢ cast{𝑏}(xs)`) and was implicitly rejected by the pinned test `refinement_eq_distinguishes_cast_target_predicates`; full transparency (ignore casts *and* their targets) is transitive but conflates semantically distinct embedded collections. The **ruling that landed is canonical discharge by term-determination** (the closed finding above): equality keeps distinguishing genuinely different cast targets — that behaviour is correct and stays pinned (`cast_target_vintages_render_alike_but_do_not_dedup` remains as the exhibit of *why* the slot is semantic) — and the pipeline no longer *manufactures* divergent vintages of one refinement, because no pass may decide a cast's refinements from route-dependent context. + +With the representation change the quarantine is gone — the fuzz compares coalesced outcomes directly, no layer-order normalization in front of it: **100k constraint sets × 8 permutations across seeds, zero violations** — acceptance, coalesced structure, and kind-var resolution are confluent within the generated vocabulary. + +#### M4b — the merge algebra *(landed early, proofs)* + +`CclFormal/Merge.lean` models the ground fragment of `compact.rs`'s bound-merging — `CTy` mirrors `CompactType` (atoms, the optional keyed maps and the refinement slot, each with the load-bearing `None` vs `Some(empty)` distinction, and the function slot), `merge` mirrors the polar `CompactType::merge`/`CompactFun::merge`, and `eqv` mirrors `CompactType`'s `PartialEq` (set-semantic at every layer). The dedup gate on a positive join's domain alternatives is `eqv` itself, exactly as `union_domains` dedups with `PartialEq` — which is what makes the whole algebra quotient-compatible. + +Dropping the Pi binder is what the telescope buys, and it now rests on an assertion rather than an assumption. `CompactFun::merge` keeps `a.name.or(b.name)`, which is order-dependent as written; it is unobservable because a refinement's binding is its *index* (`Name::PiBound`), so no refinement's meaning depends on which spelling survives. `compact_go`'s function arm asserts exactly that — `refinements_name_binder` checks that a function's own refinement set never references its own binder by name — and it holds at all 15,281 function compactions the suite performs, both fuzzes included. A refinement referencing some other free name is unaffected: it was free before the merge and stays free after, which is the only case where two differently-spelled binders meet at one position (355 times in the suite, all from generated types, and the type-merge fuzz reports no order-dependent outcome across them). Adjudications (recorded in the module docs): inference variables, history slots, and the Pi binder are dropped; domain alternatives beyond one are `none` ("many"), sound because a slot carrying several is read only under the resolved kind at coalesce — **if Σ ever materializes multi-domain joins this adjudication must be revisited**. + +Proved, sorry-free: + +- **`eqv` is an equivalence relation** (`eqv_refl`/`eqv_symm`/`eqv_trans`), with maps read pointwise through `lookup` so shadowed duplicate bindings are unobservable (mirroring `BTreeMap`). +- **Commutativity** (`merge_comm`) — unconditional, both polarities. +- **Idempotence** (`merge_idem`) — under `wf`, the input-bound invariant (no `conflict` kinds, one domain per function slot), which is what `compact_go` builds from any `Type`. It genuinely fails off the invariant: a multi-alternative `data` slot meeting itself at a negative position conflicts. +- **Congruence** (`merge_congr_left`/`_right`/`merge_congr`) — merging respects `eqv`; holds *because* the gate is the same equality. +- **Associativity** (`merge_assoc`) — unconditional, both polarities. The kinds join in the flat semilattice `unknown < {data, compute} < conflict` (`joinKind`, with `joinKind_comm`/`_assoc`/`_idem`), and the domains are combined by *polarity* alone, so no step of the fold reads a value a later step can change. +- **Fold invariance** (`foldMerge_perm`, `foldMerge_dup`): the fold is invariant under permutation of the bound list, and under duplication given `wf` on the repeated bound — the algebraic statement behind the type-merge fuzz's "outcomes agree under permuted constraint orders", proved rather than sampled. +- **Uniqueness in the induced order** (`merge_isLub`, `join_unique`): `merge pol` is the least upper bound of `le pol a b := eqv (merge pol a b) b` — a partial order up to `eqv` via `le_refl`/`le_trans`/`le_antisymm` — and any least upper bound is `eqv`-equal to it. Read the scope precisely: the proofs use only commutativity, associativity, idempotence and congruence, so this is the semilattice-to-poset correspondence and carries exactly the content of those three laws. It licenses calling `merge` a join *of the order it defines*; it says nothing about subtyping. "`merge` computes the subtyping join" is M4c's bridge theorem and is not stated yet. + +**Absorption and distributivity hold of the types; `CTy` is the wrong carrier to state them over.** There is one type lattice, and `merge true` computes its join while `merge false` computes its meet. What is polarity-indexed is the *denotation*: one `CTy` value denotes two different types, since a contribution set means the union of its contributions read positively and their intersection read negatively. So `CTy` is not a lattice carrier but one syntax carrying two representations. + +Writing `a ⊓ (a ⊔ b) = a` over `CTy` needs a single syntactic `a` in both a join argument (read positively) and a meet argument (read negatively) — that is, it needs `⟦a⟧⁺ = ⟦a⟧⁻`. That holds for a single contribution (`{Int}` is `Int` either way) and fails as soon as a set holds two, which is the case the law is about. Equivalently: meeting a positive result with something needs the *negative* representation of the type that result denotes, and converting between the two representations is not a syntactic operation on compact types. It is where distributivity does its work, and the polar normal form exists precisely so the conversion is never needed. + +**Open: the lattice is a *semantic* statement, and the model does not make it.** It needs a domain of types ordered by subtyping in which ⊔ and ⊓ both exist — the lattice algebraic subtyping is built on, of which the polarized compact form is a normal form. + +The gap is not that a join is missing or ambiguous. `merge pol` is total and is the unique lub of the order it induces, so a join always exists and is one thing; `CTy`'s union *node* is the contribution set itself, and `atoms = {Int, Bool}` at a positive position **is** `Int ⊔ Bool`. What is missing is a `Type` that denotes it. `Type` carries the joins and meets the compiler can lower — `Refinement` is a meet with a predicate, and `Variant` is a *tagged* join whose values carry a tag and whose eliminator is `variant_project` — and no constructor for an untagged "`Int` or `String`", whose values carry nothing to distinguish the sides. So `coalesce` is a partial function out of `CTy`, and `IncompatibleBounds`/`DomainJoinConflict` fire exactly where a unique join exists with no `Type` to name it ("we would need a Union/Intersection — we error instead"). A lattice semantics is what turns that from an implementation behaviour into a theorem, and what would let the Σ work say precisely which join Σ represents — Σ being a union node restricted to domains, added because that one join is worth representing. + +So the merge algebra proves the laws that hold of one polarity's operation — commutativity, associativity, idempotence, and its lub characterization — and the cross-polarity laws wait on a carrier where both operations act on the same object. That carrier is what M4c below adds. + +And `simplify_type`'s atomic absorption and co-occurrence merging are rewrites whose justification *is* a lattice identity. That pass is observationally inert today — disabling it entirely leaves 2168 tests passing and fails only its own three unit tests — and its own docs say it becomes load-bearing once let-polymorphism introduces genuine polar asymmetry. So it is not a live hazard; it is the consumer that would make a lattice model pay, and the reason to state the lattice before the pass starts mattering rather than after. + +**The correspondence is enforced, not assumed.** `differential_bound_merge_vs_lean_model` generates bound lists the way `compact_go` sees them — each operand a compacted ground `Type`, sometimes carrying a kind *variable* (the only route to `KindMerge::Unknown`) and sometimes the empty contribution a `Hole` compacts to — folds them through `CompactType::merge`, and checks every step against the model, judged by `eqv` itself. Each step's left operand is the previous step's result, so the conflicted and multi-alternative states that only merging produces are operands too. Checked: the atom sets, both keyed maps with their polarity duality, the function slot's kind join and domain rule and codomain, the refinement slot including its `none` sentinel, and the conflicted, multi-alternative and `Unknown`-kind intermediates that only merging produces. + +Not checked, and each for a stated reason rather than by omission — the model's abstractions are applied by the *encoder*, so no comparison is made against a slot the model does not model: + +- **Inference variables** (`vars`) and **history slots** have no field. A generated ground `Type` produces neither, so the history slots' same-polarity componentwise merge is uncovered outright. +- **The Pi binder**'s first-wins selection (`a.name.or(b.name)`) is dropped. +- **A conflicted slot's domain payload.** `widest` picks between equal-length lists by arrival order, and coalesce prints those alternatives without reading them, so the model drops the payload rather than mirror the choice. Every other slot's alternatives are compared in full. +- **`Openness`** is dropped, and every generated arm set is closed, so `meet_openness` is only ever exercised at `Closed`/`Closed`. +- **`ChanDom` atoms** are outside the model's `Atom`, matching `Ty`'s exclusion of the pipeline transients. +- **Predicate identity outside the modeled `Pred` vocabulary.** The refinement slot's *operations* are checked, but the Rust dedups refinements with `Refinement`'s `PartialEq` — structural on the term, type-blind, and **cast-target-aware** (`eq_refinement_predicate`) — while the model's `Pred` has no cast node and compares structurally. `gen_pred` emits `__elem`, literals and `__elem == 𝑥`, so the vintage question (`cast_target_vintages_render_alike_but_do_not_dedup`) is exactly what these cases cannot reach. Closing it means giving `Pred` a cast node with the Rust's comparison, and it is the largest of these gaps. + +It earned its place on the first run, with 23 mismatches in 4000 steps, all one shape: the model had no sentinel for "no refinement contribution", so a hole's empty claim list intersected away the refinements a sibling bound established. `CTy`'s refinement slot is now `Option (List Pred)` — the same distinction `compact.rs` draws between `None` and `Some(empty)` — with the slot's laws proved separately (`mergeRefinements_comm`/`_idem`/`_assoc`/`_congr_left`) and lifted into each `merge` theorem. A consequence worth stating: with every slot carrying a `none`, the empty position *is* the merge identity (`merge_cempty_left`, by `rfl`), so the algebra is a commutative monoid and the induced order has a least element. + +**Finding (closed by the solver change it prompted): associativity failed because the domain rule read a kind that was not settled.** The counterexample the model first exhibited used the `Data ⊔ Compute` upcast, which the equality-of-kinds change retired. Re-mirroring the Rust then relocated it to `KindMerge::Unknown`: two bounds whose kind variable nothing had pinned took the contravariant domain meet, while the same bound meeting a `Data` bound unioned the alternatives — so at one position a `data` collection over `{a, b}` and two undetermined-kind bounds over `{a}` and `{b}` merged to a conflict in one association and, in the other, to an accepted collection over `{a, b}`, the meet of two of the three domains. The accepting association was the wrong answer, not merely a different one: the kinds join to `Data`, all three domains *are* the data, and narrowing a data domain drops rows. + +Measured before choosing a repair — 12 counterexamples for the rule as written, 36 for the obvious alternative (union unless the other side is compute), 0 for choosing the combination from polarity alone. `compact.rs` now accumulates the alternatives at every positive join and applies the resolved kind's rule once, at `coalesce_compact_go`; the exhibit is pinned in Rust as `undetermined_kinds_join_without_deciding_the_domain_rule`, and the model's associativity has no side condition left. The generalization worth keeping: **a rule whose answer depends on a value the fold is still accumulating cannot be applied pairwise**, and the domain rule is such a rule because it reads the kind. + +#### Why the model carries `CTy` at all + +Two reasons, and neither is "so the algebra has a carrier". + +The differential needs a mirror of `CompactType`; that much is definitional. The +substantive reason is that **order-independence is a statement about the +representation, and no semantic statement implies it.** The solver compares +compact and materialized types *structurally* — the trivial-equality +short-circuit, cache keys, `SpecKey`, the recorded-versus-recomputed walls — so +two structurally distinct results denoting mutually-subtyping types are two +different identities to it. A lattice-level "joins are unique up to ≈" would not +have caught the refinement-layer finding recorded under the M4 preview above: +subtyping was indifferent there (refinements compare as a set) while `Type`'s derived +`PartialEq` was not, and the fuzz hit it at roughly one generated set in ten +thousand. That bug is the argument for proving the algebra over `CTy`. + +What `CTy` cannot carry is any statement about what a merge *means* — hence the +scope note on uniqueness above, and M4c. + +#### M4c — the lattice, and what a merge means *(planned)* + +The merge algebra proves that `merge pol` is a well-behaved operation and the differential proves the solver agrees with it. Neither says the operation is a **join**. That the contribution sets mean unions and intersections at all is currently prose, so the statements the whole design rests on — `merge true` computes a least upper bound *of types*, `coalesce`'s failures are exactly the joins with no `Type` normal form — cannot be made. + +**A lattice grammar is the wrong shape for it.** The statement wanted is +`merge true` computes the subtyping join, and `Sub` can already make it — it is +reflexive and transitive here, so no new carrier, no completion, and no +distributivity is on the path: + +> Where a positive merge and both its operands materialize, the merged type is the +> `Sub`-least upper bound of the operands' materializations; dually, a negative +> merge materializes to their greatest lower bound. + +Conditional on materializing, which is the honest form: `coalesce` is partial and +its failures are exactly the joins no `Ty` names. + +Adding `LTy` with `⊔`/`⊓`/`⊤`/`⊥` instead runs into a completion problem for no +gain. The cheap completion — embedding `Ty` in its lattice of downsets — makes +every join *free* and so fails to preserve the joins `Ty` already has: a positive +merge of `{Int | __elem == 7}` and `{Int | __elem == 8}` intersects the refinement sets +to `Int`, while the downset join is strictly smaller, omitting +`{Int | __elem == 9}`. The bridge theorem would be false against it. Preserving +existing joins needs the Dedekind–MacNeille completion, a large detour to reach a +statement `Sub` already expresses. Distributivity is a property of *that* +completion, not something the bridge needs — so it drops off the critical path +entirely. + +So the milestone is: + +1. **A prerequisite, forced by the deferral of the domain rule — done.** `CTy`'s domain slot abstracted "two or more alternatives" to `none`, which was sound while nothing read the tail of the list; `coalesce_compact_go` folds the contravariant meet over it, so two slots differing only in the tail materialize differently. The slot is now a `List CTy` mirroring `DomainSet`, compared as a set (`subDoms`, `domsEqv`), with `unionDoms` mirroring the deduplicating union and `meetDoms` the negative arm. The differential carries the full alternative list. Every law survived the change unconditionally: commutativity, idempotence, congruence and associativity, because the negative arm tests for **one distinct alternative** rather than one list element — the condition `domsEqv` can see. + + **Finding (closed by the solver change it prompted): `CompactFun.domains` was a `Vec` serving a set, so the merge was not commutative under `CompactType`'s own equality.** `CompactFun` derives `PartialEq`, which compares a `Vec` positionally, while the union appended — so two data-function bounds over distinct domains merged to `[d₁, d₂]` or `[d₂, d₁]` by arrival order and the results compared unequal. Found while writing this milestone's first step, confirmed by running it, and the refinement-layer finding's defect class exactly: representation identity depending on arrival order in a slot whose contents are a set. Nothing observed it — a `Data` slot with two alternatives is a `DomainJoinConflict` either way and a `Compute` slot's meet-fold normalizes — which is why the type-merge fuzz reported clean. + + The alternatives are now a `DomainSet` with set-semantic equality and a deduplicating union, so the model's set-semantic domain comparison is faithful rather than a coarsening, and duplicate-freeness is a representation invariant. Two consequences for the model: the merge's commutativity survives the change to a real list, and the negative arm reads "exactly one *distinct* alternative" rather than "length one" — the same condition on a deduplicated list, and the one that makes congruence unconditional, since `domsEqv` cannot distinguish `[x]` from `[x, x]` while a length test can. +2. **Model `coalesce_compact_go`** on the ground fragment, with a differential of the same shape as the merge's — **done**, and clean at 40,000 materialized bounds. It closes the largest hole in the coverage table above: that pass is where the resolved-kind domain rule lives and it had Rust tests only. Four things sit outside the comparison, each because `CTy` already drops the slot it would need: the Pi binder (the harness erases binders, since the model cannot predict `kept_name`), `Openness`, which of `KindConflict`/`DomainJoinConflict` a conflicted slot reports (that reads the alternatives the model drops), and the refinements on a position that materializes to an inference variable — `Ty` has no `Infer` node, so such a position is compared only as "unresolved". It caught one divergence on its first run: the model materialized a record's payloads before checking its key kinds, while `materialize_record` returns on mixed keys without touching them. +3. **The lub/glb theorem — stated and measured in `CclFormal/Bridge.lean`; the proof is what remains.** Its prerequisite is **done**: `coalesce` is total, measured by `depth`. That took the argument `compact.rs` never wrote down — **`merge` does not deepen a position** (`merge_depth_le`), which is what bounds the one recursive call no subterm ordering reaches, where a `Compute` slot's alternatives are folded with `merge` and the *result* is materialized. + + The statement is `LubSoundAt`: where all three positions materialize, a positive merge lands above both operands under `subCheck` and a negative one below both. Conditional on materializing, which is the honest form — `coalesce` is partial, and its failures are exactly the joins no `Ty` names. Two hypotheses were forced by the sample, each pinned in the module by the counterexample that forces it. + + **Finding (closed by the solver change it prompted): a product with no fields answered `Unit`.** `docs/chl-spec.md`, "6.6 The empty product is unit" makes unit a *base* type precisely so a product cannot reach it by width, and `materialize_record` returned it for the empty field map, so a positive merge that intersected two records to nothing materialized as `Unit` and was a supertype of neither operand. The empty product is now `CoalesceError::IncompatibleBounds`, not an error of its own: bounds with no common shape is what that error already says, and the empty product is that read one level down. `CoErr.incompatible` carries it on the model side. + + **A kind variable is not a ground position** (`kindResolved`). `KindM.unknown` materializes by the capability default, and a merge that pins the slot to `data` overrides that default, so an `unknown` operand's own materialization is not what the merge combined: `(Int ⤇ Int)` joined with an unpinned `(Int ⇒ Int)` is `(Int ⤇ Int)`, above neither operand as materialized separately. That artifact is 24 of the 26 failures over the whole sample, and excluding it is not a restriction on the merge — `wf` already excludes the other non-ground kind, `.conflict`. + + **Finding (closed, and it was `Ty`'s gap rather than the merge's): a negative merge of two `data` slots over distinct domains has no bound to be least among.** `subCheck` reads a data function's domain invariantly (`subCheck d1 d0 && subCheck d0 d1`), so no `Ty` is below both `({a: Int} ⤇ Int)` and `({a: Int, b: Bool} ⤇ Int)` — a type below both would need one domain mutually-sub with two that are not mutually-sub. Demanding that the merge be a lower bound there demands the impossible, and the lossless answer is the Σ over both domains that M5 adds. So the general statement is guarded by the existence of a bound (`LubSoundGuarded`), with leastness (`LubLeastAt`) unconditional because its quantifier already ranges over bounds. + + **Finding (closed in the model): `wf` did not carry the refinement slot's invariant.** `compact.rs` gives the refinement slot's `none` only to the two contributions that are not values — a hole and a bare variable — because `none` is the merge identity and `Some(empty)` is a value guaranteeing nothing, which is what makes `Int` joined with `{Int | p}` be `Int`. The model's `wf` did not say so, and a position with atoms and no refinement slot breaks the bridge at a positive position: the merge keeps `p`, so the join is above neither operand. Nothing in the sample reached it until the atoms case of the proof was written out. `wf` now states it, and the malformed position is pinned as a `#guard`. + + **Finding (closed in the model): `coalesce` read a dense index map's payloads by list position.** `Ty.tuple` is positional and a `CTy` map's list order carries no information — `eqv` compares maps as sets, mirroring the `BTreeMap` the Rust holds, whose iteration order is the key order. A negative merge unions keys by appending the leftovers, so `[0, 2]` merged with `[1]` gives `[0, 2, 1]`, dense and out of order, and the model materialized a tuple the Rust never builds. Neither differential can see it: the harness sends maps in `BTreeMap` order, and the merge differential compares by `eqv`. `byIndex` now reads the payloads by index. + + **Finding (closed in the model): `wf` allowed duplicate keys.** A `CTy` map stands for a `BTreeMap`, which cannot hold two bindings for one key. `eqv` is blind to a shadowed duplicate because it compares by `lookup`, and its doc comment says so; `coalesce` materializes every entry and `subTags` checks every one, so the duplicate is observable in the type and breaks the bridge. `nodupKeys` is now part of `wf`. The merge preserves it: a positive record merge filters `m₁`'s keys and a negative one appends only `m₂`'s leftovers. + + Over the sample: 2888 `wf` pairs, of which 2048 are kind-resolved. Guarded soundness and leastness are **0** on all of them. Unguarded, 4 failures survive — the shape above on two surfaces, each in both orders: the record domains `{a: Int}` against `{a: Int, b: Bool}`, and the refinement slots `Int` against `{Int | __elem}`. + + **A disagreement is caught loudly exactly when the domains' join is undefined, and silently whenever it exists.** Two distinct atoms join to a two-atom position that `coalesce` rejects, so nothing materializes and the statement is vacuous; record keys intersect, variant tags unite, and refinement sets intersect, and each of those materializes to a domain that is neither operand's. An earlier revision of this section restricted a data slot's domain to atoms and reported the fragment clean, describing that as the shape `compact_go` produces. Both halves were wrong: the restriction selects for the shapes whose disagreement fails loudly rather than for anything about collection domains, it misses the refinement slot because a refinement intersection is always defined, and it excludes variant domains, which the corpus census counts 52 of. The boundary is the domains' agreement, which is what `mono_fun` assumes, so the restriction is gone. + + Measured, no disagreement is reachable. Across every CHL program the integration corpus compiles there are 473 negative-position `Data`-slot domain merges, and in every one the two domains are identical except for their variable sets — atoms, record, variant, function, and refinement slots all agree, and 4 pairs are ground and equal. Four programs written to force a disagreement each typecheck and reach 48 such merges, all agreeing: a parameter read raw and filtered, one parameter under two different filters, a source read raw and filtered, and a filtered binding filtered again. The likely mechanism is that a filter does not demand a refined domain of its source — it produces a collection whose own domain is refined, which is why refined data domains appear in the census while disagreeing pairs do not. + + The sample carries out-of-order keys for all three keyed shapes, which is what the `byIndex` finding needed, and a refined data domain, which is what this one needed. + + The bridge's soundness half is **proved**: `lubSound`. It factors through one lemma, `MonoAt` — `coalesce pol` carries `le pol` to `Sub` at a positive position and to its converse at a negative one — after which soundness is `le_merge_left`/`le_merge_right` transported, and leastness is `merge_le` transported back through an embedding `Ty → CTy`. `MonoAt` is measured over the same sample and fails on exactly the shape the existence guard covers, in both orders. Its proof splits four ways rather than inducting through `coalesce` whole: materializing at all means exactly one of the atom, record, variant, and function shapes is populated, and `le pol a b` forces the same one on both sides, so each case reasons about a single slot. **All four cases are proved**. `mono_atoms`: the atom lists union, so `le` forces one side's atoms into the other's and a singleton dedup pins one atom on both, after which the refinement slots compare by containment in the polarity's direction. `mono_variant`: a variant's tags are contravariant in `subCheck`, and the merge unions them at a positive position and intersects them at a negative one, so the same direction is read twice; it takes the payloads' monotonicity as a hypothesis, which is where the assembled induction will pass itself. `mono_record`: a record's fields are covariant and its field set contravariant, and the merge intersects the set at a positive position and unites it at a negative one, so in both the contained map's materialization is the right-hand side — which is why the comparison is stated once, over the map operation, and applied twice. `mono_fun`: the domains merge at the flipped polarity, so the domain edge is contravariant, and a `data` slot needs it in both directions because `subCheck` reads a data domain invariantly. A positive merge accumulates the alternatives and `le` collapses them to one, which supplies that agreement; a negative merge takes their meet and supplies one direction only, so the case assumes it, and the shape the assumption excludes is the one `Ty` gives no bound for. Writing these out is what found the `wf` gaps, the `byIndex` gap, and the refined-data-domain correction above. + + **`lubSound` is the soundness half, and it is two instances of monotonicity.** `le_merge_left` and `le_merge_right` put both operands below the merge in the order the merge induces, and `mono` carries that order to `Sub` (`lubSound_of_mono`, `monoAt_of_mono`), so soundness is not a separate argument. Its hypotheses beyond `ground` are that the merge stays ground and that neither pair moved a data domain; 1814 of the sample's 2048 kind-resolved pairs satisfy them, and the 234 that do not are a merge that left the input shape — a `compute` slot carrying two domain alternatives, which materializes by meeting them — or a data domain the merge moved. + + **`lubLeast` is leastness, over positions**: a position above both operands materializes to a type above the merge's materialization, by `merge_le` transported the same way. That is where it stops. Going from "above both, as a position" to "above both, as a type" needs an embedding `Ty → CTy` and the reflection of `Sub` into `le` — the converse of monotonicity — and neither is proved. + + **`mono` assembles the four cases**, by fuel on the summed size — symmetric, because the function case applies the hypothesis to its domains in both directions, which is why `DataAgree` carries both orders. `coalesce_shape` pins each position to one of four shapes and `le` refutes every pairing of different ones, so twelve of the sixteen cases close on a presence clause and the remaining four are the case lemmas. Its one hypothesis beyond `ground` is `DataAgree pol a b`: at a negative position a `data` slot's two domains agree. That is a condition on the *pair*, not on which types a data domain may be — a data domain is refined whenever a filter narrows a collection — and it holds exactly when a bound exists, since `subCheck` reads a data domain invariantly as `constrain_go` does. + + **Finding (closed by the model change it prompted): `coalesce` computed its four contributions inline, so no lemma could name one.** The assembly the four cases need is a recursion on the summed size — symmetric, because the function case applies the hypothesis to its domains in both directions — and its first step is shape determination: materializing at all means exactly one of the atom, record, variant, and function slots is populated, because the four contributions concatenate and the last arm takes a singleton. Proving that needed "a populated slot contributes exactly one entry", one statement per slot, and there was nothing to state it about: the contributions were sub-expressions of one `do` block, so every proof had to re-derive each one's shape inside itself, under whatever branches the other three slots opened. Three routes were measured against it — a 16-way `simp_all` (heartbeat timeout), per-pair refutations (each needs the other two slots' branches enumerated), and `repeat' split` (splits the constructor match and leaves the arms open). + + `coalesce` now calls `recShapes`, `varShapes`, `funShapes` and `combine`, as `coalesce_compact_go` does with its `shapes` vector. Two decisions make the shape argument free rather than proved. Each helper yields *at most one* shape, which is its return type rather than a lemma about its branches. And whether a contribution is read is the *slot's* question, asked in `coalesce` (`if recF.isSome then [recShape] else []`), so the list's length is manifest where it is built instead of something a lemma has to recover — an absent slot's helper answers `none` and is not read. The helpers take the whole position, which is what the `depth` lemmas were already stated against, and the measure is the lexicographic `(depth t, phase)` that `wf`/`wfKeys` use: `coalesce` sits above the three helpers at equal depth, and a helper descends to a payload strictly. + + The four single-slot equations (`coalesce_atoms_only` and its three siblings) read `coalesce` off one populated slot, and every reader is now stated through them. The coalesce differential is unchanged at 4,000 materialized bounds with 0 mismatches, which is what says the refactor is faithful. + + **Shape determination follows** (`coalesce_shape`): the four contributions' lengths sum to one, so casing on the three slots leaves eight arithmetic facts, and the atom contribution is non-empty exactly when the atom list is. What was a 16-way branch walk through one `do` block is now `combine_ok`, a length congruence, and `omega`. + +### M5 — Σ types and `FunKind` inference + +The recent machinery, added to the M0–M4 model: kind variables resolved at coalesce ([type-inference.md, "4.6 Data vs compute functions"](../src/ccl/design/type-inference.md#46-data-vs-compute-functions)), Σ formation over candidate domains, and the witness discipline — **one value = one witness**, arms α-converted onto the value's witness (adopt if unanimous, mint on disagreement, sticky), with the join deferred to compaction. That invariant was established only after a constraint-time-join defect was root-caused at some expense; it is exactly the kind of subtle, recently-hand-verified argument worth freezing as a theorem before the next refactor disturbs it. + +### M6 — Histories: the mutability semantic model + +Independent of M4/M5; can start any time after M2 if the mutability workstream heats up first. This is a *semantics* model, not a typing model — the transient variants (`History`, `ChanDom`, `Hole`, `Infer`) are pipeline artifacts and deliberately stay **out** of the typing calculus. + +Model histories as functions `𝐷 ⇒ 𝑉` per [mutability.md, "The model: histories and causal recursion"](../src/ccl/design/mutability.md#the-model-histories-and-causal-recursion): + +- `Overwrite` = last-write-wins merge with carry-forward at off-path positions; +- `Append` = the append law, no carry-forward; +- `Txn` reads are arbitrary as-of reads — there is deliberately no terminal/"final value" read in the model, matching [mutability.md, "Semantics"](../src/ccl/design/mutability.md#semantics). + +Headline theorem: the `letrec`/`transact` realization emitted by `mut_elim` / `plan_loops` denotes the same function as a direct imperative semantics of the surface program. + +## Non-goals + +- **Principality.** Dolan-style principality proofs are thesis-scale, and monomorphization means principal types are not shipped anyway. +- **Verifying the Rust directly.** Rust→Lean translation (Aeneas) handles interior mutability and shared graphs worst of all fragments, and the solver core is `Rc>`. Not planned around. +- **Reproducing inference output.** Per the oracle stance above: admissibility, not identity (ground subtyping excepted). + +## Keeping the model honest + +- `formal/` lives in-repo as a `lake` project with a pinned `lean-toolchain`; CI runs `lake build` plus the differential suite. +- The contract: **a semantic change to `constrain` / coalesce either updates `formal/` in the same change or documents the divergence in the PR.** Solver code implementing a modeled rule cites the Lean declaration by name; the doc-refs discipline extends to these citations. +- The differential harness is the enforcement mechanism of last resort: even when proofs lag behind, the executable model diverging from the Rust fails CI. diff --git a/formal/lake-manifest.json b/formal/lake-manifest.json new file mode 100644 index 00000000..82c84d22 --- /dev/null +++ b/formal/lake-manifest.json @@ -0,0 +1,6 @@ +{"version": "1.2.0", + "packagesDir": ".lake/packages", + "packages": [], + "name": "CclFormal", + "lakeDir": ".lake", + "fixedToolchain": false} diff --git a/formal/lakefile.toml b/formal/lakefile.toml new file mode 100644 index 00000000..fbcc8fd7 --- /dev/null +++ b/formal/lakefile.toml @@ -0,0 +1,12 @@ +name = "CclFormal" +defaultTargets = ["CclFormal", "subverdict"] + +[[lean_lib]] +name = "CclFormal" + +# The M1 differential oracle (see Main.lean). `lake build` produces +# .lake/build/bin/subverdict, which the Rust harness +# (src/ccl/infer/solver/differential.rs) spawns. +[[lean_exe]] +name = "subverdict" +root = "Main" diff --git a/formal/lean-toolchain b/formal/lean-toolchain new file mode 100644 index 00000000..0ec5999c --- /dev/null +++ b/formal/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.32.2 diff --git a/src/ccl/infer/solver/compact.rs b/src/ccl/infer/solver/compact.rs index a91e371f..531c832b 100644 --- a/src/ccl/infer/solver/compact.rs +++ b/src/ccl/infer/solver/compact.rs @@ -473,7 +473,21 @@ impl CompactType { /// - `refinements`: `None` is the identity; two present sets intersect at /// positive polarity and union at negative /// ([`merge_refinements`](Self::merge_refinements)). + #[cfg(not(any(test, feature = "test-helpers")))] pub(super) fn merge(pol: bool, lhs: CompactType, rhs: CompactType) -> CompactType { + Self::merge_impl(pol, lhs, rhs) + } + + /// `pub` to the integration tests only: `tests/differential_oracle.rs` folds a + /// bound list through this and diffs each step against the model's `merge`. + /// The merge is `pub(super)` to the crate, because it is the bound fold's + /// step and nothing outside the solver has a bound list to fold. + #[cfg(any(test, feature = "test-helpers"))] + pub fn merge(pol: bool, lhs: CompactType, rhs: CompactType) -> CompactType { + Self::merge_impl(pol, lhs, rhs) + } + + fn merge_impl(pol: bool, lhs: CompactType, rhs: CompactType) -> CompactType { let mut vars = lhs.vars; vars.extend(rhs.vars); let mut atoms = lhs.atoms; @@ -773,6 +787,34 @@ impl ParentPath<'_> { } } +/// Whether any refinement in this position's own set references `binder` by *name*. +/// +/// The negation is the compaction boundary's form of **landing closes**: a refinement +/// referencing its function's binder has that reference converted to an index +/// (`Name::PiBound`) when it lands, so the function's spelling carries no refinement +/// identity afterwards. Two consequences rest on it — `CompactFun::merge` may keep +/// either side's binder name (`a.name.or(b.name)`) without changing what the merged +/// refinements mean, and `coalesce_compact_go` can decide whether to keep the binder from +/// the codomain alone. A refinement referencing some *other* free name is unaffected and +/// stays free; only the function's own binder is at stake. +/// +/// Not recursive: a nested function rebinding the same spelling is a different +/// binder, and its refinements land against it instead. +fn refinements_name_binder(ct: &CompactType, binder: &Name) -> bool { + fn mentions(e: &crate::ccl::TypedExpr, target: &Name) -> bool { + use crate::ccl::TypedExprNode as N; + match &e.node { + N::Var(n) => n == target, + N::BinOp { left, right, .. } => mentions(left, target) || mentions(right, target), + N::UnaryOp(_, inner) => mentions(inner, target), + _ => false, + } + } + ct.refinements + .as_ref() + .is_some_and(|set| set.iter().any(|r| mentions(&r.predicate, binder))) +} + /// Whether the opposite-polarity fallback may fire at the variable currently /// being walked, given the chain that reached it. /// @@ -915,6 +957,12 @@ fn compact_go( st.scope.enter(name.clone()); let cod = compact_go(c, pol, &cod_acc, None, st); st.scope.exit(); + debug_assert!( + name.as_ref() + .is_none_or(|binder| !refinements_name_binder(&cod, binder)), + "landing closes: a function's own refinement must reference its binder by index, \ + not by name" + ); CompactType { fun: Some(CompactFun { name: name.clone(), diff --git a/tests/differential_oracle.rs b/tests/differential_oracle.rs new file mode 100644 index 00000000..0387e2ea --- /dev/null +++ b/tests/differential_oracle.rs @@ -0,0 +1,915 @@ +//! Differential oracles: two solver operations diffed against the Lean model +//! (plan and adjudications in `formal/design.md`). +//! +//! - **Ground subtyping.** `constrain_subtype`'s verdict on ground type pairs +//! (no `Infer` on either side) against `subCheck` +//! (`formal/CclFormal/Decide.lean`). +//! - **The bound merge.** Every step of a fold through `CompactType::merge` +//! against `CTy.merge` (`formal/CclFormal/Merge.lean`), judged by the model's +//! `eqv` — the equality every theorem there is stated up to. Nothing else +//! checks that correspondence, and the merge algebra is proved rather than +//! fuzzed, so without this the model can drift from the solver while both +//! stay internally consistent. +//! +//! Both generate cases with a seeded PRNG, serialize them to the wire schema the +//! Lean codec defines (`formal/CclFormal/Json.lean`), and stream them through +//! the oracle binary. They **skip loudly** when it is not built (`cd formal && +//! lake build`) so the suite stays green on machines without a Lean toolchain. +//! +//! Deliberately not generated for the subtype oracle: duplicate record/variant +//! keys — outside `Ty.WF`, where the Rust's trivial-equality short-circuit and +//! its find-first arms genuinely disagree (pinned below as +//! `dup_key_record_trips_the_uniquely_keyed_invariant`) — and open variant arm +//! sets, which the model's `Ty` has no node for. Everything else in the ground +//! fragment is fair game. + +use std::io::{BufRead, BufReader, Write}; +use std::process::{Command, Stdio}; +use std::rc::Rc; + +use smol_str::SmolStr; + +mod type_gen; + +use cambra::ccl::infer::solver::compact::{AtomKey, CompactType, KindMerge, compact_type}; +use cambra::ccl::infer::solver::{ + CoalesceError, CompactGraph, ConstrainCache, coalesce_compact, constrain_subtype, +}; +use cambra::ccl::{ + BaseType, BinOpKind, CompareKind, FieldKey, FunKind, Lit, Name, Openness, Refinement, Type, + TypedExpr, TypedExprNode, +}; +use type_gen::{Rng, gen_leaf, gen_pred, gen_ty, maybe_kind_var}; + +/// A small directed edit of `t` — targets the width/refinement rules, where +/// near-miss pairs have the interesting verdicts. +fn edit(rng: &mut Rng, t: &Type) -> Type { + match rng.below(4) { + // Add a refinement layer (rhs gains a demand / lhs gains a supply). + 0 => Type::refined_one(t.clone(), Refinement::born(gen_pred(rng))), + // Peel a refinement layer if there is one. + 1 => match t { + Type::Refinement(base, _) => (**base).clone(), + _ => Type::Base(BaseType::Int), + }, + // Narrow a product / widen a sum by one entry. + 2 => match t { + Type::Record(fields) if !fields.is_empty() => { + Type::Record(fields[..fields.len() - 1].to_vec()) + } + Type::Variant(tags, openness) => { + let mut tags = tags.clone(); + tags.push((FieldKey::Name(SmolStr::from("extra")), Type::Txn)); + Type::Variant(tags, *openness) + } + Type::Tuple(ts) => { + let mut ts = ts.clone(); + ts.push(Type::Base(BaseType::Bool)); + Type::Tuple(ts) + } + _ => gen_ty(rng, 2), + }, + _ => gen_ty(rng, 3), + } +} + +/// `__elem == ` — the dependent-refinement predicate shape, aimed at +/// a specific Pi binder. +fn dep_pred(name: &str) -> Rc { + Rc::new(TypedExpr::binop( + TypedExpr::var(Name::elem()), + BinOpKind::Compare(CompareKind::Equals), + TypedExpr::var(Name::raw(name)), + )) +} + +/// Generate a **correlated** pair: both sides are built together, usually +/// emitting identical nodes and occasionally diverging in exactly one aspect +/// (a leaf, a kind, a binder name, a predicate, a width). Deep near-misses +/// are where subtle rule divergence hides — top-level edits never reach a +/// nested Pi correspondence or a refinement two constructors down. +fn gen_pair(rng: &mut Rng, depth: u32) -> (Type, Type) { + if rng.chance(1, 8) { + return (gen_ty(rng, depth), gen_ty(rng, depth)); + } + if depth == 0 || rng.chance(1, 3) { + let l = gen_leaf(rng); + let r = if rng.chance(1, 4) { + gen_leaf(rng) + } else { + l.clone() + }; + return (l, r); + } + match rng.below(5) { + 0 => { + let kl = if rng.chance(1, 2) { + FunKind::Data + } else { + FunKind::Compute + }; + let kr = if rng.chance(1, 6) { + match kl { + FunKind::Data => FunKind::Compute, + _ => FunKind::Data, + } + } else { + kl.clone() + }; + let (dl, dr) = gen_pair(rng, depth - 1); + let binder = |rng: &mut Rng| match rng.below(3) { + 0 => None, + 1 => Some("x"), + _ => Some("y"), + }; + let nl = binder(rng); + let nr = if rng.chance(1, 4) { binder(rng) } else { nl }; + let (mut cl, mut cr) = gen_pair(rng, depth - 1); + // Dependent refinements referencing each side's *own* binder: + // structurally α-equivalent, so they must match through the + // rename correspondence — unless we deliberately misaim one. + if rng.chance(1, 2) { + if let Some(bl) = nl { + cl = Type::refined_one(cl, Refinement::born(dep_pred(bl))); + } + if let Some(br) = nr { + let target = if rng.chance(1, 5) { "z" } else { br }; + cr = Type::refined_one(cr, Refinement::born(dep_pred(target))); + } + } + let fun = |n: Option<&str>, k: FunKind, d: Type, c: Type| Type::Fun { + name: n.map(Name::raw), + kind: k, + domain: Box::new(d), + codomain: Box::new(c), + }; + (fun(nl, kl, dl, cl), fun(nr, kr, dr, cr)) + } + 1 => { + let len_l = rng.below(3) as usize; + let len_r = if rng.chance(1, 4) { + rng.below(3) as usize + } else { + len_l + }; + let mut ls = Vec::new(); + let mut rs = Vec::new(); + for i in 0..len_l.max(len_r) { + let (l, r) = gen_pair(rng, depth - 1); + if i < len_l { + ls.push(l); + } + if i < len_r { + rs.push(r); + } + } + (Type::Tuple(ls), Type::Tuple(rs)) + } + 2 => { + let mut ls = Vec::new(); + let mut rs = Vec::new(); + for key in ["a", "b", "c"] { + let in_l = rng.chance(1, 2); + let in_r = if rng.chance(1, 6) { !in_l } else { in_l }; + let (l, r) = gen_pair(rng, depth - 1); + if in_l { + ls.push((key.to_string(), l)); + } + if in_r { + rs.push((key.to_string(), r)); + } + } + (Type::Record(ls), Type::Record(rs)) + } + 3 => { + let mut ls = Vec::new(); + let mut rs = Vec::new(); + for key in ["t0", "t1"] { + let in_l = rng.chance(1, 2); + let in_r = if rng.chance(1, 6) { !in_l } else { in_l }; + let (l, r) = gen_pair(rng, depth - 1); + if in_l { + ls.push((FieldKey::Name(SmolStr::from(key)), l)); + } + if in_r { + rs.push((FieldKey::Name(SmolStr::from(key)), r)); + } + } + ( + Type::Variant(ls, Openness::Closed), + Type::Variant(rs, Openness::Closed), + ) + } + _ => { + let (bl, br) = gen_pair(rng, depth - 1); + let pl = gen_pred(rng); + let pr = if rng.chance(1, 4) { + gen_pred(rng) + } else { + Rc::clone(&pl) + }; + let mut l = Type::refined_one(bl, Refinement::born(pl)); + let mut r = Type::refined_one(br, Refinement::born(pr)); + // Occasionally give one side an extra layer — width on the + // refinement *set*. + if rng.chance(1, 4) { + l = Type::refined_one(l, Refinement::born(gen_pred(rng))); + } + if rng.chance(1, 6) { + r = Type::refined_one(r, Refinement::born(gen_pred(rng))); + } + (l, r) + } + } +} + +/// A plausible subtype-partner for `t`, biased toward *accepted* edges so +/// transitivity chains form at a workable rate: clones, directed edits, and +/// domain/codomain-level edits that exercise contravariance. +fn partner(rng: &mut Rng, t: &Type) -> Type { + match rng.below(8) { + 0 | 1 => t.clone(), + 2 | 3 => edit(rng, t), + 4..=6 => match t { + // Edit *inside* a function: domain/codomain near-misses probe the + // contravariant edge and the codomain correspondence. + Type::Fun { + name, + kind, + domain, + codomain, + } => { + let flip_kind = rng.chance(1, 4); + Type::Fun { + name: name.clone(), + kind: if flip_kind { + match kind { + FunKind::Data => FunKind::Compute, + _ => FunKind::Data, + } + } else { + kind.clone() + }, + domain: Box::new(if rng.chance(1, 2) { + edit(rng, domain) + } else { + (**domain).clone() + }), + codomain: Box::new(if rng.chance(1, 2) { + edit(rng, codomain) + } else { + (**codomain).clone() + }), + } + } + _ => edit(rng, t), + }, + _ => gen_ty(rng, 3), + } +} + +/// Serialize a predicate into the model's `Pred` wire schema. `None` means +/// "outside the modeled vocabulary" — the case is refused rather than +/// serialized wrongly (the generator never produces such a predicate, so a +/// `None` here is a harness bug). +fn pred_json(e: &TypedExpr) -> Option { + match &e.node { + TypedExprNode::Var(n) if *n == Name::elem() => Some(r#"{"k":"elem"}"#.to_string()), + // The index alone: the reference's spelling hint is display metadata the + // oracle must not see, since identity ignores it (`PiRef`). + TypedExprNode::Var(Name::PiBound(r)) => { + Some(format!(r#"{{"k":"piBound","i":{}}}"#, r.index)) + } + TypedExprNode::Var(Name::Raw(s)) => Some(format!(r#"{{"k":"var","x":"{s}"}}"#)), + TypedExprNode::Lit(Lit::Int(n)) => Some(format!(r#"{{"k":"litInt","n":{n}}}"#)), + TypedExprNode::Lit(Lit::Bool(b)) => Some(format!(r#"{{"k":"litBool","b":{b}}}"#)), + TypedExprNode::BinOp { left, op, right } => Some(format!( + r#"{{"k":"binop","op":"{op:?}","a":{},"b":{}}}"#, + pred_json(left)?, + pred_json(right)? + )), + _ => None, + } +} + +fn base_json(b: &BaseType) -> &'static str { + b.keyword() +} + +fn key_json(k: &FieldKey) -> String { + match k { + FieldKey::Index(n) => format!(r#"{{"k":"idx","n":{n}}}"#), + FieldKey::Name(s) => format!(r#"{{"k":"name","s":"{s}"}}"#), + } +} + +/// Close every function of a generated type bottom-up: each named binder's +/// free references in its codomain become indices, which is the ground +/// (closed) fragment the model states `Sub` over — a constructed `Type::Fun` +/// never carries a free name for its own binder. The generators build +/// name-based dependent shapes (the solver's mid-solve form) because that is +/// the natural way to write them; this normalizes each case into the form +/// both the solver's construction sites and the model's grammar mean. +fn close_all(ty: &Type) -> Type { + use cambra::ccl::subst::close_pi_binder; + match ty { + Type::Fun { + name, + kind, + domain, + codomain, + } => { + let domain = close_all(domain); + let codomain = close_all(codomain); + let codomain = match name { + Some(b) => close_pi_binder(b, &codomain), + None => codomain, + }; + Type::Fun { + name: name.clone(), + kind: kind.clone(), + domain: Box::new(domain), + codomain: Box::new(codomain), + } + } + Type::Refinement(base, r) => Type::Refinement(Box::new(close_all(base)), r.clone()), + Type::Tuple(ts) => Type::Tuple(ts.iter().map(close_all).collect()), + Type::Record(fs) => { + Type::Record(fs.iter().map(|(n, t)| (n.clone(), close_all(t))).collect()) + } + Type::Variant(tags, openness) => Type::Variant( + tags.iter() + .map(|(k, t)| (k.clone(), close_all(t))) + .collect(), + *openness, + ), + other => other.clone(), + } +} + +/// Serialize a ground `Type` into the model's `Ty` wire schema; `None` for +/// anything outside the ground fragment. +fn ty_json(t: &Type) -> Option { + Some(match t { + Type::Base(b) => format!(r#"{{"k":"base","base":"{}"}}"#, base_json(b)), + Type::UIntRange(n) => format!(r#"{{"k":"uintRange","n":{n}}}"#), + Type::DataSource(s) => format!(r#"{{"k":"dataSource","name":"{s}"}}"#), + Type::Txn => r#"{"k":"txn"}"#.to_string(), + Type::Fun { + name, + kind, + domain, + codomain, + } => { + let binder = match name { + None => "null".to_string(), + Some(Name::Raw(s)) => format!(r#""{s}""#), + Some(_) => return None, + }; + let kind = match kind { + FunKind::Compute => "compute", + FunKind::Data => "data", + FunKind::Var(_) => return None, + }; + format!( + r#"{{"k":"fn","binder":{binder},"kind":"{kind}","dom":{},"cod":{}}}"#, + ty_json(domain)?, + ty_json(codomain)? + ) + } + Type::Tuple(ts) => { + let ts: Option> = ts.iter().map(ty_json).collect(); + format!(r#"{{"k":"tuple","ts":[{}]}}"#, ts?.join(",")) + } + Type::Record(fields) => { + let fs: Option> = fields + .iter() + .map(|(n, t)| Some(format!(r#"["{n}",{}]"#, ty_json(t)?))) + .collect(); + format!(r#"{{"k":"record","fields":[{}]}}"#, fs?.join(",")) + } + // Closed only: the model's `variant` node is an arm set with no + // openness, so an open arm set is outside the fragment and falls + // through to `None`. + Type::Variant(tags, Openness::Closed) => { + let ts: Option> = tags + .iter() + .map(|(k, t)| Some(format!(r#"[{},{}]"#, key_json(k), ty_json(t)?))) + .collect(); + format!(r#"{{"k":"variant","tags":[{}]}}"#, ts?.join(",")) + } + // The model's `refined` node carries a whole refinement set, exactly like + // `RefinementSet`. + Type::Refinement(base, refinements) => { + let preds: Option> = refinements + .iter() + .map(|r| pred_json(&r.predicate)) + .collect(); + format!( + r#"{{"k":"refined","base":{},"refinements":[{}]}}"#, + ty_json(base)?, + preds?.join(",") + ) + } + _ => return None, + }) +} + +/// The oracle binary, or `None` when it is not built (`cd formal && lake build`) — +/// the harnesses skip themselves loudly rather than fail on a machine with no Lean +/// toolchain. +fn oracle_path() -> Option<&'static str> { + let path = concat!( + env!("CARGO_MANIFEST_DIR"), + "/formal/.lake/build/bin/subverdict" + ); + std::path::Path::new(path).exists().then_some(path) +} + +/// Stream one case per line through the oracle and collect its verdict lines. +fn ask_oracle(oracle: &str, cases: &[String]) -> Vec { + let mut child = Command::new(oracle) + .stdin(Stdio::piped()) + .stdout(Stdio::piped()) + .spawn() + .expect("spawn the oracle"); + let mut stdin = child.stdin.take().unwrap(); + let input: String = cases.iter().map(|line| format!("{line}\n")).collect(); + let writer = std::thread::spawn(move || stdin.write_all(input.as_bytes())); + let verdicts: Vec = BufReader::new(child.stdout.take().unwrap()) + .lines() + .take(cases.len()) + .map(|l| l.expect("read an oracle verdict")) + .collect(); + writer.join().unwrap().expect("write cases to the oracle"); + let _ = child.wait(); + verdicts +} + +/// Serialize an atom into the merge model's `Atom` schema. `None` for +/// `ChanDom`, which the model excludes for the same reason `Ty` excludes the +/// pipeline transients. +fn atom_json(a: &AtomKey) -> Option { + Some(match a { + AtomKey::Prim(b) => format!(r#"{{"k":"prim","base":"{}"}}"#, base_json(b)), + AtomKey::UIntRange(n) => format!(r#"{{"k":"uintRange","n":{n}}}"#), + AtomKey::Source(s) => format!(r#"{{"k":"source","s":"{s}"}}"#), + AtomKey::Txn => r#"{"k":"txn"}"#.to_string(), + AtomKey::ChanDom(..) => return None, + }) +} + +/// Serialize a `CompactType` into the merge model's `CTy` schema +/// (`formal/CclFormal/Json.lean`). The model's abstractions are applied here, so +/// the wire carries what it can express and no comparison is made against a slot +/// the model does not model: +/// +/// - `vars` has no field: the ground algebra does not read variable identity. +/// - A conflicted slot's alternatives are dropped: coalesce prints them without +/// reading them, and `widest` breaks an equal-length tie by arrival order, which +/// the model does not mirror. +/// - `Openness` has no field. Nothing is hidden inside the generated fragment: +/// every generated arm set is closed and `meet_openness` keeps it closed. +/// +/// `None` for a contribution outside the fragment — a history slot, a `ChanDom` +/// atom, or a predicate outside the modeled `Pred` vocabulary. +fn cty_json(ct: &CompactType) -> Option { + if ct.history_slot.is_some() { + return None; + } + let atoms: Option> = ct.atoms.iter().map(atom_json).collect(); + let map = |m: &std::collections::BTreeMap| -> Option { + let entries: Option> = m + .iter() + .map(|(k, v)| Some(format!("[{},{}]", key_json(k), cty_json(v)?))) + .collect(); + Some(format!("[{}]", entries?.join(","))) + }; + let rec = match &ct.rec { + None => "null".to_string(), + Some(m) => map(m)?, + }; + let var = match &ct.var { + None => "null".to_string(), + Some(v) => map(&v.tags)?, + }; + let fun = match &ct.fun { + None => "null".to_string(), + Some(cf) => { + let kind = match cf.kind { + KindMerge::Data => "data", + KindMerge::Compute => "compute", + KindMerge::Conflict => "conflict", + KindMerge::Unknown => "unknown", + }; + // A conflicted slot's alternatives are diagnostic — coalesce prints + // them and reads nothing — and `widest` picks between equal-length + // lists by arrival order, so the model drops the payload rather than + // mirror an order-dependent choice. + let doms: Option> = match cf.kind { + KindMerge::Conflict => Some(Vec::new()), + _ => cf.domains.iter().map(cty_json).collect(), + }; + format!( + r#"{{"kind":"{kind}","doms":[{}],"cod":{}}}"#, + doms?.join(","), + cty_json(&cf.codomain)? + ) + } + }; + // `null` for no refinement contribution and `[]` for a value that carries none: + // the sentinel the model mirrors, and the merge identity the two differ by. + let refinements = match &ct.refinements { + None => "null".to_string(), + Some(set) => { + let preds: Option> = set.iter().map(|r| pred_json(&r.predicate)).collect(); + format!("[{}]", preds?.join(",")) + } + }; + Some(format!( + r#"{{"atoms":[{}],"rec":{rec},"var":{var},"fn":{fun},"refinements":{refinements}}}"#, + atoms?.join(",") + )) +} + +/// One merge operand: a ground bound as `compact_go` builds it, or the empty +/// contribution a `Hole` compacts to (the merge identity). A generated function +/// sometimes carries a kind *variable*, which is the only way to reach +/// `KindMerge::Unknown`. +fn gen_bound(rng: &mut Rng) -> CompactType { + if rng.chance(1, 10) { + return compact_type(&Type::Hole).term; + } + let ty = gen_ty(rng, 3); + compact_type(&maybe_kind_var(rng, ty)).term +} + +/// Erase every function binder. `CTy` has no binder slot, so the model always +/// materializes `name: None` and cannot predict `coalesce_compact_go`'s +/// `kept_name`; the comparison drops the binder on this side rather than pretend +/// the model decides it. +fn strip_binders(t: &Type) -> Type { + match t { + Type::Fun { + name: _, + kind, + domain, + codomain, + } => Type::Fun { + name: None, + kind: kind.clone(), + domain: Box::new(strip_binders(domain)), + codomain: Box::new(strip_binders(codomain)), + }, + Type::Tuple(ts) => Type::Tuple(ts.iter().map(strip_binders).collect()), + Type::Record(fs) => Type::Record( + fs.iter() + .map(|(n, t)| (n.clone(), strip_binders(t))) + .collect(), + ), + Type::Variant(tags, o) => Type::Variant( + tags.iter() + .map(|(k, t)| (k.clone(), strip_binders(t))) + .collect(), + *o, + ), + Type::Refinement(b, cs) => Type::Refinement(Box::new(strip_binders(b)), cs.clone()), + other => other.clone(), + } +} + +/// The wire form of one materialization outcome. `None` when the type falls +/// outside the model's grammar (a nested `Infer`, say). +fn coalesce_outcome(r: &Result) -> Option { + match r { + // A position with nothing concrete materializes to a fresh variable, which + // the model reports as a fact rather than a type: `Ty` has no `Infer` node, + // so the refinements the Rust hangs on it are outside the comparison too. + Ok(t) if matches!(peel(t), Type::Infer(_)) => Some(r#"{"k":"unresolved"}"#.to_string()), + Ok(t) => Some(format!( + r#"{{"k":"ok","ty":{}}}"#, + ty_json(&strip_binders(t))? + )), + Err(e) => { + let kind = match e { + CoalesceError::IncompatibleBounds { .. } => "IncompatibleBounds", + CoalesceError::UnresolvedPartial { .. } => "UnresolvedPartial", + CoalesceError::RecursiveType { .. } => "RecursiveType", + CoalesceError::DomainJoinConflict { .. } => "DomainJoinConflict", + CoalesceError::KindConflict { .. } => "KindConflict", + }; + Some(format!(r#"{{"k":"err","kind":"{kind}"}}"#)) + } + } +} + +/// A type with its refinement layers peeled. +fn peel(t: &Type) -> &Type { + match t { + Type::Refinement(b, _) => peel(b), + other => other, + } +} + +/// Differential on **materialization**: coalesce each bound the fold produces and +/// check the outcome against the model. This is the pass on the other side of the +/// merge, and the one where the resolved kind's domain rule lives. +#[test] +fn differential_coalesce_vs_lean_model() { + let Some(oracle) = oracle_path() else { + eprintln!( + "SKIPPED differential_coalesce_vs_lean_model: Lean oracle not built \ + (cd formal && lake build)" + ); + return; + }; + let seed: u64 = std::env::var("CAMBRA_DIFF_SEED") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(0xC0A1); + let n: usize = std::env::var("CAMBRA_DIFF_N") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(4000); + + let mut rng = Rng::new(seed); + let mut cases: Vec = Vec::new(); + let mut skipped = 0usize; + while cases.len() < n { + let pol = rng.chance(1, 2); + let bounds: Vec = (0..1 + rng.below(3)).map(|_| gen_bound(&mut rng)).collect(); + let mut acc = bounds[0].clone(); + for b in &bounds[1..] { + acc = CompactType::merge(pol, acc, b.clone()); + } + let graph = CompactGraph { + term: acc.clone(), + rec_vars: std::collections::BTreeMap::new(), + }; + match (cty_json(&acc), coalesce_outcome(&coalesce_compact(&graph))) { + (Some(ct), Some(got)) => cases.push(format!( + r#"{{"op":"coalesce","pol":{pol},"ct":{ct},"got":{got}}}"# + )), + _ => skipped += 1, + } + } + + let verdicts = ask_oracle(oracle, &cases); + let mismatches: Vec = verdicts + .iter() + .zip(&cases) + .filter(|(v, _)| v.as_str() != "ok") + .map(|(v, case)| format!("{v}\n case: {case}")) + .collect(); + eprintln!( + "coalesce differential: {} bounds (seed {seed}), {skipped} outside the fragment, {} mismatches", + cases.len(), + mismatches.len() + ); + assert_eq!( + verdicts.len(), + cases.len(), + "oracle answered {}/{}", + verdicts.len(), + cases.len() + ); + assert!( + mismatches.is_empty(), + "{} coalesce mismatches (seed {seed}, n {n}); first 5:\n{}", + mismatches.len(), + mismatches[..mismatches.len().min(5)].join("\n") + ); +} + +/// Differential on the *bound merge*: fold generated bound lists exactly as +/// `compact_go` folds a variable's bounds, and check every step against the +/// model's `merge`. Each step's `lhs` is the previous step's result, so the +/// conflicted and multi-alternative states only merging produces are operands +/// too — which is where a pairwise rule and an associative one diverge. +#[test] +fn differential_bound_merge_vs_lean_model() { + let Some(oracle) = oracle_path() else { + eprintln!( + "SKIPPED differential_bound_merge_vs_lean_model: Lean oracle not built \ + (cd formal && lake build)" + ); + return; + }; + let seed: u64 = std::env::var("CAMBRA_DIFF_SEED") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(0x5EED); + let n: usize = std::env::var("CAMBRA_DIFF_N") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(4000); + + let mut rng = Rng::new(seed); + let mut cases: Vec = Vec::new(); + let mut skipped = 0usize; + while cases.len() < n { + let pol = rng.chance(1, 2); + let bounds: Vec = (0..2 + rng.below(3)).map(|_| gen_bound(&mut rng)).collect(); + let mut acc = bounds[0].clone(); + for b in &bounds[1..] { + let merged = CompactType::merge(pol, acc.clone(), b.clone()); + match (cty_json(&acc), cty_json(b), cty_json(&merged)) { + (Some(l), Some(r), Some(g)) => cases.push(format!( + r#"{{"op":"merge","pol":{pol},"lhs":{l},"rhs":{r},"got":{g}}}"# + )), + _ => skipped += 1, + } + acc = merged; + } + } + + let verdicts = ask_oracle(oracle, &cases); + let mismatches: Vec = verdicts + .iter() + .zip(&cases) + .filter(|(v, _)| v.as_str() != "ok") + .map(|(v, case)| format!("{v}\n case: {case}")) + .collect(); + eprintln!( + "merge differential: {} steps (seed {seed}), {skipped} outside the fragment, {} mismatches", + cases.len(), + mismatches.len() + ); + assert_eq!( + verdicts.len(), + cases.len(), + "oracle answered {}/{} cases", + verdicts.len(), + cases.len() + ); + assert!( + mismatches.is_empty(), + "{} merge mismatches (seed {seed}, n {n}); first 5:\n{}", + mismatches.len(), + mismatches[..mismatches.len().min(5)].join("\n") + ); +} + +/// Transitivity chain fuzz: build chains `a <: b <: c` that `constrain` +/// accepts and check the direct edge. No violations are tolerated — a hit is +/// a finding, and fails the test with the triple printed. +#[test] +fn transitivity_chain_fuzz() { + let seed: u64 = std::env::var("CAMBRA_DIFF_SEED") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(0xBEEF); + let n: usize = std::env::var("CAMBRA_DIFF_N") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(4000); + + let ok = |x: &Type, y: &Type| { + let mut cache = ConstrainCache::new(); + constrain_subtype(x, y, &mut cache).is_ok() + }; + let mut rng = Rng::new(seed); + let mut chains = 0usize; + let mut attempts = 0usize; + let mut violations: Vec<(Type, Type, Type)> = Vec::new(); + while chains < n && attempts < n * 100 { + attempts += 1; + let b = gen_ty(&mut rng, 3); + let a = partner(&mut rng, &b); + let c = partner(&mut rng, &b); + if !(ok(&a, &b) && ok(&b, &c)) { + continue; + } + chains += 1; + if !ok(&a, &c) { + violations.push((a, b, c)); + } + } + + eprintln!( + "transitivity: {chains} chains (seed {seed}, {attempts} attempts), {} violations", + violations.len() + ); + let render = |t: &Type| ty_json(t).unwrap_or_else(|| format!("{t:?}")); + assert!( + violations.is_empty(), + "transitivity violations (first 5):\n{}", + violations + .iter() + .take(5) + .map(|(a, b, c)| format!("a={}\nb={}\nc={}\n", render(a), render(b), render(c))) + .collect::>() + .join("\n") + ); +} + +#[test] +fn differential_ground_subtype_vs_lean_model() { + let oracle = concat!( + env!("CARGO_MANIFEST_DIR"), + "/formal/.lake/build/bin/subverdict" + ); + if !std::path::Path::new(oracle).exists() { + eprintln!( + "SKIPPED differential_ground_subtype_vs_lean_model: Lean oracle not built \ + (cd formal && lake build)" + ); + return; + } + let seed: u64 = std::env::var("CAMBRA_DIFF_SEED") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(0xC0FFEE); + let n: usize = std::env::var("CAMBRA_DIFF_N") + .ok() + .and_then(|s| s.parse().ok()) + .unwrap_or(4000); + + let mut rng = Rng::new(seed); + let mut cases = Vec::with_capacity(n); + while cases.len() < n { + let (lhs, rhs) = match rng.below(8) { + 0 => { + let t = gen_ty(&mut rng, 3); + (t.clone(), t) + } + 1 | 2 => { + let t = gen_ty(&mut rng, 3); + let e = edit(&mut rng, &t); + (t, e) + } + _ => gen_pair(&mut rng, 3), + }; + // Enter the ground (closed) fragment: what construction produces and + // what the model's grammar means. + let (lhs, rhs) = (close_all(&lhs), close_all(&rhs)); + let (Some(lj), Some(rj)) = (ty_json(&lhs), ty_json(&rhs)) else { + panic!("generator produced a type outside the ground wire schema: {lhs:?} / {rhs:?}"); + }; + if let Some(path) = std::env::var_os("CAMBRA_DIFF_DUMP") { + use std::io::Write; + if let Ok(mut f) = std::fs::OpenOptions::new() + .create(true) + .append(true) + .open(path) + { + let _ = writeln!(f, "{{\"op\":\"sub\",\"lhs\":{lj},\"rhs\":{rj}}}"); + } + } + let mut cache = ConstrainCache::new(); + let rust = constrain_subtype(&lhs, &rhs, &mut cache).is_ok(); + cases.push((format!(r#"{{"op":"sub","lhs":{lj},"rhs":{rj}}}"#), rust)); + } + + let mut child = Command::new(oracle) + .stdin(Stdio::piped()) + .stdout(Stdio::piped()) + .spawn() + .expect("spawn the subverdict oracle"); + let mut stdin = child.stdin.take().unwrap(); + let input: String = cases.iter().map(|(line, _)| format!("{line}\n")).collect(); + let writer = std::thread::spawn(move || stdin.write_all(input.as_bytes())); + + let mut verdicts = 0usize; + let mut mismatches = Vec::new(); + for (i, line) in BufReader::new(child.stdout.take().unwrap()) + .lines() + .enumerate() + { + let line = line.expect("read oracle verdict"); + if i >= cases.len() { + break; + } + verdicts += 1; + let (case, rust) = &cases[i]; + match line.as_str() { + "true" if *rust => {} + "false" if !*rust => {} + "true" | "false" => { + mismatches.push(format!("case {i}: rust={rust} lean={line}\n {case}")) + } + other => mismatches.push(format!("case {i}: oracle said {other:?}\n {case}")), + } + } + writer.join().unwrap().expect("write cases to oracle"); + let _ = child.wait(); + + let accepted = cases.iter().filter(|(_, rust)| *rust).count(); + eprintln!( + "differential: {} cases (seed {seed}), rust accepted {accepted}, rejected {}", + cases.len(), + cases.len() - accepted + ); + assert_eq!( + verdicts, + cases.len(), + "oracle answered {verdicts}/{} cases", + cases.len() + ); + assert!( + mismatches.is_empty(), + "{} verdict mismatches (seed {seed}, n {n}); first 10:\n{}", + mismatches.len(), + mismatches[..mismatches.len().min(10)].join("\n") + ); +}