diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc index 1f72fd0..c8cba4f 100644 --- a/CHANGELOG.adoc +++ b/CHANGELOG.adoc @@ -21,7 +21,7 @@ open proof obligation. and the AFFIRMATION honesty snapshot with the systemet identity and an honest status (theory specified; proofs OPEN; no compiler here). * Added the wager experiment for coercions and roles in Cubical Agda -(`+verification/proofs/agda/Wager/+`, stages 0 and 1), with an `+agda+` job +(`+verification/proofs/agda/Wager/+`, stages 0 to 4), with an `+agda+` job in the proofs workflow. The experiment claims no ET obligation. ==== Changed diff --git a/docs/status/PROOF-STATUS.adoc b/docs/status/PROOF-STATUS.adoc index 2c73755..058aed8 100644 --- a/docs/status/PROOF-STATUS.adoc +++ b/docs/status/PROOF-STATUS.adoc @@ -13,7 +13,7 @@ summary from the per-prover MANIFESTs and fails if this file disagrees. // Machine-readable ground-truth markers — checked by scripts/check-proof-status.sh. // Do not edit by hand without changing the MANIFEST accordingly. // gate:lean4 gated=20 quarantined=0 -// gate:agda gated=29 quarantined=0 +// gate:agda gated=64 quarantined=0 == Summary @@ -110,8 +110,56 @@ no file uses coinduction. One warning class is silenced | `Wager.Proofs.affine-is-grade-algebra`, `level-is-grade-algebra` | *Proven* (law checks computed over the finite carriers) -| 2 to 7 -| T1 to T7 of the experiment +| 2 +| `Wager.Proofs.t1-lawful`, `t1-ghc-other-laws`, `t1-ghc-mul-zero-fails` : roles as a + grade structure. The lawful table has all 15 law fields. The GHC table + fails `a · 0 = 0`, at nominal only +| *Proven* + +| 2 +| `Wager.Proofs.noninterference`, `t2-representational`, `t2-phantom` : role + soundness as noninterference, for a signature that respects its + declared grades +| *Proven* with that hypothesis. Without it the statement is false + (`Wager.Proofs.t2-phantom-fails-without-valid`) + +| 2 +| `Wager.Proofs.t4-kinding-rejects`, `t4-not-equivalent` : the classic + unsound type-level function is rejected at the grade representational +| *Proven* + +| 3 +| `Wager.Proofs.source-role-soundness`, `erasure-preserves-typing`, + `classic-rejected`, `classic-unsound-if-accepted`, + `classic-nominal-no-coercion` : the source calculus (a fragment of System + FC with roles). The role check makes a representational coercion keep + the erased type. The check rejects the classic unsound program +| *Proven* for the source fragment of the experiment + +| 4 +| `Wager.Proofs.t3`, `coercion-is-a-term` : the translation of a + representational coercion is an ordinary typed term of the target (trope + transitions and functorial maps, no cast). Its erasure is observationally + the identity function +| *Proven* + +| 4 +| `Wager.Proofs.t5-typing`, `t5-behaviour` : the translation of the source + fragment preserves typing, and the erased source program and the erased + translation evaluate to observationally equal values +| *Proven* with a change: a newtype with a parameter needs more than one + wrapped trope state. With two-state tropes one program of the fragment + has no translation of types that keeps the properties that the + experiment asks for (`Wager.Proofs.no-two-state-translation`). Typing of a + whole program is proved for a grade algebra with an unrestricted grade `1` + +| 4 +| `Wager.Proofs.role-correspondence` : the inferred source role of a + newtype parameter is the least grade that target kinding accepts +| *Proven* + +| 5 to 7 +| T6, T7 of the experiment | not attempted |=== diff --git a/verification/proofs/agda/MANIFEST b/verification/proofs/agda/MANIFEST index 076dc9d..079ef4c 100644 --- a/verification/proofs/agda/MANIFEST +++ b/verification/proofs/agda/MANIFEST @@ -30,3 +30,38 @@ verification/proofs/agda|Wager/L2/Preservation.agda|gated|Stage 1 (T0): preserva verification/proofs/agda|Wager/L2/Progress.agda|gated|Stage 1 (T0): canonical forms and progress verification/proofs/agda|Wager/Proofs.agda|gated|one inhabitant for each statement of Statements.agda verification/proofs/agda|Wager/Examples/Stage1.agda|gated|Stage 1: accepted and rejected closed examples +verification/proofs/agda|Wager/Role/Role.agda|gated|Stage 2 (T1): roles, the lawful table and the GHC table, law by law +verification/proofs/agda|Wager/Role/Role4.agda|gated|Stage 2 finding: a 4-point role structure with all laws and the GHC rule +verification/proofs/agda|Wager/Role/Table.agda|gated|Stage 2: composition tables with the properties that noninterference uses +verification/proofs/agda|Wager/Role/Signature.agda|gated|Stage 2: signatures with roles as kind grades +verification/proofs/agda|Wager/Role/RepEq.agda|gated|Stage 2: representational equivalence (specification only) +verification/proofs/agda|Wager/Role/Validity.agda|gated|Stage 2: observers and the validity of a signature (definitions) +verification/proofs/agda|Wager/Role/Classic.agda|gated|Stage 2: the concrete signature (Int, Age, Proxy, isAge, deep) +verification/proofs/agda|Wager/L1/KindingInversion.agda|gated|Stage 2: inversion of graded kinding (for rejected examples) +verification/proofs/agda|Wager/Role/Noninterference.agda|gated|Stage 2 (T2): noninterference for a composition table and a valid signature +verification/proofs/agda|Wager/Role/Lawful.agda|gated|Stage 2 (T2): the two parts of T2 with the lawful table; a sufficient condition for validity +verification/proofs/agda|Wager/Role/ClassicProofs.agda|gated|Stage 2 (T4): the classic unsound program; the Proxy test +verification/proofs/agda|Wager/Examples/Stage2.agda|gated|Stage 2: accepted and rejected closed examples +verification/proofs/agda|Wager/Erased/Untyped.agda|gated|Stage 3: the untyped calculus after erasure (terms, big-step evaluation, erased typing) +verification/proofs/agda|Wager/FC/Signature.agda|gated|Stage 3: source signature (newtypes, declared roles, type-level functions), role inference, the role check +verification/proofs/agda|Wager/FC/Types.agda|gated|Stage 3: source types, nominal values (ev), erased types (er) +verification/proofs/agda|Wager/FC/Coercion.agda|gated|Stage 3: source coercions with roles (the relation Co) +verification/proofs/agda|Wager/FC/Term.agda|gated|Stage 3: source terms with cast and coerce; erasure, in which a cast vanishes +verification/proofs/agda|Wager/FC/Classic.agda|gated|Stage 3: the classic unsound program as a source signature (definitions only) +verification/proofs/agda|Wager/FC/RoleSoundness.agda|gated|Stage 3: soundness of the source roles (a representational coercion keeps the erased type) +verification/proofs/agda|Wager/FC/Erasure.agda|gated|Stage 3: erasure preserves typing, for a signature that passes the role check +verification/proofs/agda|Wager/FC/ClassicProofs.agda|gated|Stage 3: the classic unsound program; the role check rejects it; the exploit if it is accepted +verification/proofs/agda|Wager/Examples/Stage3.agda|gated|Stage 3: accepted and rejected closed examples +verification/proofs/agda|Wager/FC/Tagged.agda|gated|Stage 3 and 4: a source signature with a phantom newtype and a function that looks at its argument (definitions only) +verification/proofs/agda|Wager/Erased/LogRel.agda|gated|Stage 4: observational equality of untyped values at an erased type (logical relation) +verification/proofs/agda|Wager/Trans/Scheme.agda|gated|Stage 4: state schemes for newtypes (row scheme, two-state scheme) +verification/proofs/agda|Wager/Trans/Target.agda|gated|Stage 4: the target signature of the translation and the translation of types +verification/proofs/agda|Wager/Trans/Nominal.agda|gated|Stage 4: a nominal coercion of the source becomes conversion in the target +verification/proofs/agda|Wager/Trans/Coercion.agda|gated|Stage 4: translation of coercions (trope transitions and functorial maps) and of terms; erasure of the target +verification/proofs/agda|Wager/Trans/TwoState.agda|gated|Stage 4: what a translation of types must keep; two-state tropes (definitions only) +verification/proofs/agda|Wager/Grade/Trivial.agda|gated|Stage 4: the one-point grade algebra (no usage discipline) +verification/proofs/agda|Wager/Trans/Typing.agda|gated|Stage 4 (T5): the translation preserves typing; a coercion is a typed term in each grade algebra +verification/proofs/agda|Wager/Trans/Simulation.agda|gated|Stage 4 (T3, T5): an erased coercion is observationally the identity; erased source and erased target agree +verification/proofs/agda|Wager/Trans/RoleCorrespondence.agda|gated|Stage 4: the inferred source role is the least grade that target kinding accepts; the target signature is valid +verification/proofs/agda|Wager/Trans/TwoStateProofs.agda|gated|Stage 4: the tagged signature has no translation with two-state tropes (checked counterexample) +verification/proofs/agda|Wager/Examples/Stage4.agda|gated|Stage 4: accepted and rejected closed examples diff --git a/verification/proofs/agda/Wager/DESIGN-CHOICES.adoc b/verification/proofs/agda/Wager/DESIGN-CHOICES.adoc index 1f59ee2..faa71cc 100644 --- a/verification/proofs/agda/Wager/DESIGN-CHOICES.adoc +++ b/verification/proofs/agda/Wager/DESIGN-CHOICES.adoc @@ -1,7 +1,7 @@ // SPDX-License-Identifier: CC-BY-SA-4.0 // SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) = Wager: design choices -Status: entries of Stage 0 and Stage 1. +Status: entries of Stage 0, Stage 1, Stage 2, Stage 3 and Stage 4. :toc: left :sectnums!: @@ -36,7 +36,7 @@ Agda 2.8.0 then rejects an import from a module without the flag (`InfectiveImpo The stock library makes that rule impossible to obey. *Decision.* The owner accepted alternative 1 on 2026-11-10. -At the end of each stage a search for `coinductive` in `Wager/` checks the intent of the rule. The search found nothing at the end of Stage 1. +At the end of each stage a search for `coinductive` in `Wager/` checks the intent of the rule. The search found nothing at the end of Stage 1, of Stage 2, of Stage 3 and of Stage 4. *Alternatives.* @@ -69,6 +69,12 @@ Thus the Lean proofs that use `castNf_diag` (an equality on `Δ = Δ` closed by *Alternative.* Leave the warning on. This is honest but makes the output hard to read. +*Audit at the end of Stage 4.* 35 of the 64 files have the line. A test of the 13 new files without the line found the warning in 6 of them. It found no other warning, and it found 2 new files that had the line and did not need it. The line was removed from them. The other 5 new files compile without a warning. + +*Audit at the end of Stage 3.* 29 of the 51 files have the line. A test of the 10 new files without the line found the warning in each of the 6 new files that have the line. It found no other warning. The other 4 new files compile without a warning. + +*Audit at the end of Stage 2.* 23 of the 41 files have the line. A test without the line found the warning in each of the 23 files, found no other warning, and found 2 new files that did not need the line. + *Audit at the end of Stage 1.* 18 of the 29 files have the line. A test without the line found the warning in each of the 18 files and found no other warning. The test also found 2 files that had the line and did not need it. The line was removed from them. @@ -190,3 +196,249 @@ On 2026-11-10 the owner asked for the push and for the updates that put the repo *Not changed.* `docs/theory/OBLIGATIONS.adoc`, `AFFIRMATION.adoc` and each `.a2ml` file. A new obligation needs an ADR from the owner. *Reason.* The drift gate compares `PROOF-STATUS.adoc` with the manifests, and the repository rule says that a gated proof must run in CI. + +== Stage 2 + +[[DC-2.1]] +=== DC-2.1: representational equivalence is on closed normal types + +*Choice.* `≈` (`Wager.Role.RepEq`) relates closed normal types of kind `★`. +It is the least congruence that contains newtype unfolding: `A@s ≈ A` when `s` is a newtype state. +A role signature (`RoleSig`) says which unary constants are newtype states (`isNewtype`). +For two types `A` and `B`, "A ≈ B" means `nf A ≈ nf B`. + +*Reason.* The task states T2 on normal forms. On normal forms no rule for conversion is needed. + +*Consequence.* The congruence rule holds for each constant, also for one that is not a newtype state. +`Proxy A ≈ Proxy B` thus holds exactly when `A ≈ B`. + +[[DC-2.2]] +=== DC-2.2: observers, and the hypothesis `Valid` of T2 + +*Choice.* T2 is proved by a relation with an observer role. A nominal observer sees the identity of a type, a representational observer sees a type up to `≈`, a phantom observer sees nothing. +T2 has the hypothesis `Valid`: each constant and each primitive of the signature respects its declared grade. + +*Reason.* The task says that the graded kind of a primitive is declared in the signature, not in a rule. +A declaration can be wrong. A theorem about kinding must then assume that the declarations are right. +`Wager.Role.Lawful.valid-lawful` gives a simple sufficient condition: no constant has the grade phantom, and each primitive has the grade nominal. + +*Consequence.* `VERDICT.adoc` gives T2 the status "PROVED WITH CHANGE", class "signature primitive". + +[[DC-2.3]] +=== DC-2.3: the composition table is a parameter of noninterference + +*Choice.* `Wager.Role.Noninterference` takes a `RoleTable`: a composition with associativity, a right unit and monotonicity. +The lawful table and the GHC table are instances. + +*Reason.* Step 3 of Stage 2 asks which table is sound. One proof for the two tables answers the question for both. +The proof also uses `a ≤ a + b`. This holds because `+` is the maximum. It is not one of the 15 law fields. + +[[DC-2.4]] +=== DC-2.4: the concrete signature of Stage 2 + +*Choice.* `Wager.Role.Classic` has the base types Int, Bool, Char, Unit, the newtype state `age` (so `Int@age` is `Age`), the generative constant `proxy`, and two primitives. +`isAge` tells `Int@age` from `Int`. `deep` inspects the argument of `proxy` with `isAge`. +The declared grade of the parameter of `proxy` is a parameter of the signature. + +*Reason.* The task asks for a test with a generative constant with an unused parameter, below a function that inspects its argument. +A primitive that inspects the head only cannot see below `proxy`. `deep` can, by the delegation of DC-1.1. + +[[DC-2.5]] +=== DC-2.5: the 4-point role structure is a finding only + +*Choice.* `Wager.Role.Role4` proves that a structure with a separate grade "absent" has all 15 law fields and the GHC rule. +Stage 2 does not build a kinding or a noninterference theorem on it. + +*Reason.* T1 names a 3-point carrier with `𝟘 = phantom`. A 4-point carrier changes T1, the relation `≈` and the phantom part of T2. These changes are decisions of the owner. + +== Stage 3 + +[[DC-3.1]] +=== DC-3.1: the source calculus is a small fragment of System FC + +*Choice.* The source calculus (`Wager.FC`) follows Breitner, Eisenberg, Peyton Jones and Weirich, "Safe Zero-cost Coercions for Haskell". It has: + +* base types, functions, pairs and sums; +* newtypes with no parameter and newtypes with one parameter, each with a declared role; +* total closed type-level functions with one argument; +* coercions at the three roles, with reflexivity, symmetry, transitivity, the rule from nominal to representational, the phantom rule, role-gated congruence, the newtype rules and the rules of the type-level functions; +* terms with `cast`, and `coerce` as the function `λx. cast γ x`; +* erasure into an untyped calculus. + +*Limits.* Each limit makes the fragment smaller, so each limit makes claim W weaker. + +* A type is closed. A term has no type variable, and there is no `∀`. +* A newtype has 0 parameters or 1 parameter. A type-level function has 1 argument. +* The data types are the function, the pair and the sum. Their parameters are representational. A signature cannot declare a data type. +* The constructor of each newtype is visible. There is no abstract type. +* There is no decomposition rule (`nth`), no coercion between polymorphic types and no coercion variable. +* A source term has no grade. System FC has no grades. + +[[DC-3.2]] +=== DC-3.2: recursion is kept out by construction + +*Choice.* The body of a newtype with one parameter is a `Body`: the parameter, a base type, a function, a pair, a sum, or a type-level function on a body. +A body cannot mention a declared newtype. The representation of a newtype with no parameter is an erased type. + +*Reason.* The task says: keep recursion out. With this choice the functions `ev` (nominal value) and `er` (erased type) are structurally recursive. No termination argument is needed. + +*Consequence 1.* Role inference (`roleOf`) is a structural function. In a body, the role phantom means "the parameter does not occur". +The rule for a type-level function is `nominal · r` with the lawful table: a parameter that does not occur below the function stays phantom. +`Source-Role-Soundness` is proved with this rule. + +*Consequence 2.* The fragment cannot declare the body that separates the lawful table from the role inference of GHC, as Breitner et al. describe it: a phantom newtype below a type-level function, such as `F (Tag a)`. This development did not run GHC. +For that body the lawful table gives the role phantom to `a`. Phantom is wrong there: `F (Tag Int)` and `F (Tag Bool)` are different types (`Wager.Examples.Stage3.Nominal-Soundness-Examples.f-sees-phantom`). +A larger fragment with such bodies must use another inference rule. Stage 3 proves nothing about such a body. +The coercion rules of this fragment do have the rule of GHC for a newtype (DC-3.3). + +*Alternative.* A list of declarations in which each body can mention the earlier newtypes. This is more faithful and much larger. It was not built. + +[[DC-3.3]] +=== DC-3.3: one coercion relation with a role index + +*Choice.* `Co r τ σ` (`Wager.FC.Coercion`) has the role `r` as an index. +The congruence rule for a newtype `N` has a premise at the role `mulG r (role N)`. `mulG` is the GHC composition table of T1. + +*Reason.* This development reads the rule of Breitner et al. in this way: at the role nominal the arguments are nominally equal, at the role representational the arguments are equal at the declared role, at the role phantom there is no condition. +The entry `nominal · phantom = nominal` says that a newtype is generative: `Tag Int` and `Tag Bool` are different types, also when the parameter of `Tag` is phantom. + +*Note.* `Co` is a relation of the source calculus. The target calculus does not have it (`RELATION-LEDGER.adoc`, entry R14). + +[[DC-3.4]] +=== DC-3.4: type-level functions look at the head of the argument + +*Choice.* A source type-level function has the same form as a target primitive (DC-1.1): one equation for each head. +For a newtype with one parameter, the right side is a base type, or another function on the PARAMETER of the newtype (`F (N τ) = G τ`). + +*Reason.* A closed type family of Haskell can match on the argument of a type constructor (this development did not run GHC). The form also keeps each function total. + +*Difference from the target.* A target primitive on `capp c A` can look at `A`. In the planned translation of Stage 4, `A` is the representation of the newtype, not its parameter. +Stage 4 must show what this difference costs. + +[[DC-3.5]] +=== DC-3.5: source terms are typed by construction + +*Choice.* `STm Γ τ` (`Wager.FC.Term`) is the set of the terms of the type τ. There is no separate typing relation for source terms. +`cast γ e` needs a coercion `γ : Co rep τ σ`. The constructor and the destructor of a newtype are casts along the newtype rule. + +*Reason.* A program with a wrong `coerce` is then not a term. "The source calculus rejects the program" means: the type of its terms has no inhabitant of that form, or the coercion type is empty (`¬ Co rep τ σ`). + +[[DC-3.6]] +=== DC-3.6: the erasure semantics + +*Choice.* `Wager.Erased.Untyped` has untyped terms, big-step call-by-value evaluation with closures, erased types (a base type, a function, a pair, a sum) and a typing of untyped terms with erased types. +The erasure of a source term (`eraseTm`) removes each cast. No other change is made. + +*Reason.* The task asks for an erasure semantics in which coercions vanish. A cast vanishes by the definition of `eraseTm`, and `coerce` erases to `λx. x`. +The module does not depend on the source calculus. Stage 4 can erase the target calculus into the same untyped calculus and compare the two results there. + +*Not proved here.* Stage 3 does not prove that a typed untyped term evaluates to a value of its erased type. It proves that erasure preserves typing (`Wager.Proofs.erasure-preserves-typing`). + +== Stage 4 + +[[DC-4.1]] +=== DC-4.1: a newtype is a trope state on its representation, and a state scheme gives the number of states + +*Choice.* The translation (`Wager.Trans`) makes the source type `N τ` the target type `A@s`: the carrier `A` is the translation of the representation of `N τ`, and `s` is a state. +A state scheme (`Wager.Trans.Scheme.StateScheme`) says which state. The state of `N τ` is the pair of `N` and an index. The index keeps what a type-level function can see of the argument τ. + +Two schemes exist: + +* `rowScheme`: the index is the row of the results of all the type-level functions on `N τ`. It exists for each source signature. +* `twoState`: there is one index. The newtype is a two-state trope (raw, wrapped), as in Stage 2. It exists when no type-level function looks at the argument of a newtype. + +*Reason.* Stage 2 made a newtype a two-state trope. This is not enough for the signature `taggedS rep`, which has a newtype with a phantom parameter and a function that looks at that parameter (`Wager.Proofs.no-two-state-translation`, in the sense of DC-4.8). Agda checked this one signature. +`Tag Int` and `Tag Bool` have one representation, and the function tells them apart. They need two states of one carrier. + +*Finite state sets.* Document 07 says that a trope has a finite set of states. The index type of the row scheme is `Fam → Base`. +It is finite when the signature has a finite number of functions and of base types. Agda did not check this sentence. The Agda signature type has no finiteness condition. + +*Limit that this result depends on.* The result of a type-level function is a base type (DC-1.1, DC-3.4). A function that returns a part of its argument, such as `F (Tag a) = a`, is outside the fragment. +For such a function a row has no finite bound. This development proves nothing about it. + +[[DC-4.2]] +=== DC-4.2: the target signature of the translation + +*Choice.* `Wager.Trans.Target` builds the target signature from the source signature and the state scheme: + +* the base types and the literals of the source; +* one state for each newtype with no parameter, and one state for each newtype with a parameter and each index. Each state has the grade representational; +* one primitive for each type-level function. Each primitive has the grade nominal. On a state, a primitive reads its result from the index. It does not look at the carrier. + +A function type `τ → σ` becomes `arr 𝟙 (T τ) (T σ)`. + +*Consequence.* The target signature respects its declared grades (`Wager.Proofs.target-signature-valid`). The hypothesis `Valid` of T2 thus holds for each signature that the translation gives. +No state has a phantom parameter. A phantom parameter of the source is not a type argument in the target: it is in the name of the state. + +[[DC-4.3]] +=== DC-4.3: the trope operations are wrap and unwrap, for each instance + +*Choice.* The term signature has two operations for each instance of a newtype: `wrap : A → A@s` and `unwrap : A@s → A`. + +*Reason.* The carrier of an operation is a closed type (DC-1.4). An operation for each instance is the form of one polymorphic operation in a calculus with no type variable in terms. +The set of operations is thus not finite. Document 07 says that the set of API operations of a trope is finite. This development gives no finite bound for the operations. + +[[DC-4.4]] +=== DC-4.4: a coercion is a pair of term transformers + +*Choice.* `Wager.Trans.Coercion.coI` translates a coercion to a pair of transformers `Tm n → Tm n` (forwards, backwards). The blocks are: + +* wrap and unwrap (the newtype rules); +* the map of a function, of a pair and of a sum (congruence); +* unwrap, the map of the body, wrap (congruence for a newtype); +* composition (transitivity), exchange of the two directions (symmetry), and the identity. + +A nominal coercion is the identity transformer. Its typing uses rule `t-conv`, because the two translated types are convertible (`Wager.Trans.Nominal.nominal-defeq`). +`coerceT γ` is the function `λx. (transformer of γ) x`. The translation of `cast γ e` is the transformer of γ on the translation of `e`. + +*No cast.* The target has no cast judgement and no cast term. Each transformer is built from the term formers of Stage 1. + +*Detail.* The map of a function is `(λf. λx. g (f (h x))) t`. It keeps a β-redex, so that `t` is not moved under a binder. + +*Lemma that Stage 5 states as a theorem.* `nominal-defeq` is the content of T6. Stage 4 needs it for the typing of a cast, so its proof is in Stage 4. Stage 5 puts the statement of T6 in `Statements.agda`. + +[[DC-4.5]] +=== DC-4.5: which grade algebra types the translation + +*Choice.* Two results, with two conditions: + +* A translated coercion is typed in EACH grade algebra (`Wager.Proofs.coercion-is-a-term`). It uses each variable one time, and each binder has the grade 𝟙. +* A translated program is typed in each grade algebra in which the grade 𝟙 is unrestricted: `𝟘 ≤ 𝟙` and `𝟙 + 𝟙 ≤ 𝟙` (`Wager.Proofs.t5-typing`). The one-point algebra `Wager.Grade.Trivial` is an example. + +*Reason.* System FC has no usage discipline: a source term can drop a variable and can use it two times. +The rules of Stage 1 bind the two components of a pair and the variable of a `case` branch at the grade 𝟙, as the anytype checker does. A source term can drop a component. Thus 𝟙 itself must allow this. + +*Consequence.* In the algebra `Affine` (systemet order) the grade 1 is linear. The translation of the source function `λx. 5`, which drops its argument, has no type there (`Wager.Examples.Stage4.Coercions-In-Affine.const-rejected`). Agda checked this one function. This development does not prove that the two conditions are necessary. +The two conditions name the grades 𝟘 and 𝟙 only. They are hypotheses of a theorem. They are not side conditions of a rule. + +[[DC-4.6]] +=== DC-4.6: observational equality is a logical relation on untyped values + +*Choice.* `Wager.Erased.LogRel.𝒱 a` relates two untyped values at the erased type `a`: one literal at a base type, related components for a pair, one injection and related contents for a sum, and for two function values related results on related arguments. +T3 and the behaviour part of T5 are stated with it. On a first-order type (no function) the relation is equality of values. + +*The erasure of the target.* `eraseT` removes each trope transition and each type annotation. No other change is made. + +*Not proved here.* This development does not define contextual equivalence, and it does not prove that `𝒱` agrees with it. +It also does not prove that the reduction of the target (`_⟶_`, Stage 1) agrees with the evaluation of the erased target term. + +[[DC-4.7]] +=== DC-4.7: the form of the role correspondence + +*Choice.* The body of a newtype `N` is the type-level function `bodyFun N g` of the target, with the grade `g` for its parameter. +The correspondence says: graded kinding, with the lawful role table, accepts `g` exactly when the inferred source role is at most `g` (`Wager.Proofs.role-correspondence`). + +*Reason.* The task says: "the source assigns the role ρ to a parameter if and only if the target kinding assigns the matching grade". +Kinding has a subusage rule, so it accepts each grade above the least one. "The matching grade" is thus the least accepted grade. + +*Limit.* The correspondence is about the body. In the translation the newtype `N` itself is not a type-level function of the target, because the state depends on the index of the argument. + +[[DC-4.8]] +=== DC-4.8: what "no translation" means + +*Choice.* `Wager.Trans.TwoState.Translation` says what a translation of types must keep: a nominal coercion becomes conversion, a type-level function becomes a type-level function of the target, and two different base types stay different. +`TwoState` adds: each newtype with a parameter is one state on the translation of its representation. +`Wager.Proofs.no-two-state-translation` says that the signature `taggedS rep` has no such translation, into any target signature. + +*Reason.* "This program has no translation" needs a definition of "translation". The three conditions are properties that claim W asks for. The fourth condition is the form of Stage 2. +The translation with the row scheme meets the three conditions (`Wager.Proofs.row-translation-exists`), so the conditions are not empty. diff --git a/verification/proofs/agda/Wager/Erased/LogRel.agda b/verification/proofs/agda/Wager/Erased/LogRel.agda new file mode 100644 index 0000000..1991b79 --- /dev/null +++ b/verification/proofs/agda/Wager/Erased/LogRel.agda @@ -0,0 +1,78 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Observational equality of untyped values, at an erased type +-- (Stage 4). It is a logical relation, by recursion on the erased type: +-- +-- base type the two values are one literal of that base type; +-- function the two values are closures, and on related arguments +-- the two bodies evaluate to related results; +-- pair the two values are pairs with related components; +-- sum the two values have one injection and related contents. +-- +-- The relation is used in theorem statements only (specification). +-- On a first-order type (no function) it is equality of values. +open import Cubical.Foundations.Prelude + +module Wager.Erased.LogRel {B Lit : Type} (litTy : Lit → B) where + +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.Sigma using (_×_; _,_; Σ-syntax) + +open import Wager.Erased.Untyped +open Terms Lit + +private + variable + n m : ℕ + + VRel : Type₁ + VRel = UVal → UVal → Type + +data RBase (b : B) : VRel where + r-lit : ∀ ℓ → litTy ℓ ≡ b → RBase b (vlit ℓ) (vlit ℓ) + +data RArr (P Q : VRel) : VRel where + r-clo : ∀ {ρ : UEnv n} {t : UTm (suc n)} {ρ' : UEnv m} {t' : UTm (suc m)} → + (∀ v w → P v w → + Σ[ r ∈ UVal ] Σ[ s ∈ UVal ] + ((v ∷ᵉ ρ) ⊢ t ⇓ r) × ((w ∷ᵉ ρ') ⊢ t' ⇓ s) × Q r s) → + RArr P Q (vclo ρ t) (vclo ρ' t') + +data RProd (P Q : VRel) : VRel where + r-pair : ∀ {v₁ v₂ w₁ w₂} → P v₁ w₁ → Q v₂ w₂ → RProd P Q (vpair v₁ v₂) (vpair w₁ w₂) + +data RSum (P Q : VRel) : VRel where + r-inl : ∀ {v w} → P v w → RSum P Q (vinl v) (vinl w) + r-inr : ∀ {v w} → Q v w → RSum P Q (vinr v) (vinr w) + +-- THE RELATION. +𝒱 : ETy B → UVal → UVal → Type +𝒱 (ebase b) = RBase b +𝒱 (earr a b) = RArr (𝒱 a) (𝒱 b) +𝒱 (eprod a b) = RProd (𝒱 a) (𝒱 b) +𝒱 (esum a b) = RSum (𝒱 a) (𝒱 b) + +-- A term in an environment evaluates to a value that is related to v. +𝒞 : ETy B → UVal → UEnv n → UTm n → Type +𝒞 a v ρ t = Σ[ w ∈ UVal ] (ρ ⊢ t ⇓ w) × 𝒱 a v w + +-- Two terms in two environments evaluate to related values. +ℰ : ETy B → UEnv n → UTm n → UEnv m → UTm m → Type +ℰ a ρ t ρ' t' = Σ[ v ∈ UVal ] (ρ ⊢ t ⇓ v) × 𝒞 a v ρ' t' + +------------------------------------------------------------------------ +-- First-order types: on them the relation is equality. + +data FO : ETy B → Type where + fo-base : ∀ {b} → FO (ebase b) + fo-prod : ∀ {a b} → FO a → FO b → FO (eprod a b) + fo-sum : ∀ {a b} → FO a → FO b → FO (esum a b) + +𝒱-fo : ∀ {a v w} → FO a → 𝒱 a v w → v ≡ w +𝒱-fo fo-base (r-lit ℓ p) = refl +𝒱-fo (fo-prod x y) (r-pair h k) = cong₂ vpair (𝒱-fo x h) (𝒱-fo y k) +𝒱-fo (fo-sum x y) (r-inl h) = cong vinl (𝒱-fo x h) +𝒱-fo (fo-sum x y) (r-inr h) = cong vinr (𝒱-fo y h) diff --git a/verification/proofs/agda/Wager/Erased/Untyped.agda b/verification/proofs/agda/Wager/Erased/Untyped.agda new file mode 100644 index 0000000..14fe313 --- /dev/null +++ b/verification/proofs/agda/Wager/Erased/Untyped.agda @@ -0,0 +1,129 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on scoped terms. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The untyped calculus that a program erases to (Stage 3). +-- +-- ETy erased types: a base type, a function, a pair or a sum. +-- An erased type has no newtype and no type-level function. +-- UTm untyped terms (de Bruijn). There is no coercion, no cast and +-- no trope transition in this syntax. +-- _⊢_⇓_ big-step evaluation, call by value, with closures. +-- _⊢ᵉ_∶_ typing of an untyped term with erased types. +-- +-- The module does not depend on the source calculus or on the target +-- calculus. Each of the two erases into it. +module Wager.Erased.Untyped where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) + +data ETy (B : Type) : Type where + ebase : B → ETy B + earr eprod esum : ETy B → ETy B → ETy B + +------------------------------------------------------------------------ +-- Terms, values and evaluation. + +module Terms (Lit : Type) where + + private + variable + n m : ℕ + + data UTm : ℕ → Type where + uvar : Fin n → UTm n + ulam : UTm (suc n) → UTm n + uapp : UTm n → UTm n → UTm n + upair : UTm n → UTm n → UTm n + -- The body sees the first component at index 1 and the second at index 0. + uletp : UTm n → UTm (suc (suc n)) → UTm n + uinl : UTm n → UTm n + uinr : UTm n → UTm n + ucase : UTm n → UTm (suc n) → UTm (suc n) → UTm n + ulit : Lit → UTm n + + -- A value. A function value is a closure: an environment and a body. + data UVal : Type where + vclo : (Fin n → UVal) → UTm (suc n) → UVal + vpair : UVal → UVal → UVal + vinl : UVal → UVal + vinr : UVal → UVal + vlit : Lit → UVal + + UEnv : ℕ → Type + UEnv n = Fin n → UVal + + infixr 5 _∷ᵉ_ + _∷ᵉ_ : UVal → UEnv n → UEnv (suc n) + (v ∷ᵉ ρ) zero = v + (v ∷ᵉ ρ) (suc i) = ρ i + + -- The empty environment. + ∅ᵉ : UEnv 0 + ∅ᵉ () + + infix 3 _⊢_⇓_ + data _⊢_⇓_ : UEnv n → UTm n → UVal → Type where + ⇓-var : ∀ {ρ : UEnv n} i → ρ ⊢ uvar i ⇓ ρ i + ⇓-lam : ∀ {ρ : UEnv n} {b} → ρ ⊢ ulam b ⇓ vclo ρ b + ⇓-app : ∀ {ρ : UEnv n} {ρ' : UEnv m} {f a b w v} → + ρ ⊢ f ⇓ vclo ρ' b → ρ ⊢ a ⇓ w → (w ∷ᵉ ρ') ⊢ b ⇓ v → + ρ ⊢ uapp f a ⇓ v + ⇓-pair : ∀ {ρ : UEnv n} {s t v w} → + ρ ⊢ s ⇓ v → ρ ⊢ t ⇓ w → ρ ⊢ upair s t ⇓ vpair v w + ⇓-letp : ∀ {ρ : UEnv n} {s b v w r} → + ρ ⊢ s ⇓ vpair v w → (w ∷ᵉ v ∷ᵉ ρ) ⊢ b ⇓ r → + ρ ⊢ uletp s b ⇓ r + ⇓-inl : ∀ {ρ : UEnv n} {t v} → ρ ⊢ t ⇓ v → ρ ⊢ uinl t ⇓ vinl v + ⇓-inr : ∀ {ρ : UEnv n} {t v} → ρ ⊢ t ⇓ v → ρ ⊢ uinr t ⇓ vinr v + ⇓-casel : ∀ {ρ : UEnv n} {s l r v w} → + ρ ⊢ s ⇓ vinl v → (v ∷ᵉ ρ) ⊢ l ⇓ w → ρ ⊢ ucase s l r ⇓ w + ⇓-caser : ∀ {ρ : UEnv n} {s l r v w} → + ρ ⊢ s ⇓ vinr v → (v ∷ᵉ ρ) ⊢ r ⇓ w → ρ ⊢ ucase s l r ⇓ w + ⇓-lit : ∀ {ρ : UEnv n} {ℓ} → ρ ⊢ ulit ℓ ⇓ vlit ℓ + +------------------------------------------------------------------------ +-- Typing of untyped terms with erased types. + +module Typing {B Lit : Type} (litTy : Lit → B) where + open Terms Lit + + private + variable + n : ℕ + + ECx : ℕ → Type + ECx n = Fin n → ETy B + + infixl 5 _▹ᵉ_ + _▹ᵉ_ : ECx n → ETy B → ECx (suc n) + (Δ ▹ᵉ a) zero = a + (Δ ▹ᵉ a) (suc i) = Δ i + + ∅ᶜ : ECx 0 + ∅ᶜ () + + infix 3 _⊢ᵉ_∶_ + data _⊢ᵉ_∶_ : ECx n → UTm n → ETy B → Type where + u-var : ∀ {Δ : ECx n} {a} i → Δ i ≡ a → Δ ⊢ᵉ uvar i ∶ a + u-lam : ∀ {Δ : ECx n} {a b t} → + (Δ ▹ᵉ a) ⊢ᵉ t ∶ b → Δ ⊢ᵉ ulam t ∶ earr a b + u-app : ∀ {Δ : ECx n} {a b f t} → + Δ ⊢ᵉ f ∶ earr a b → Δ ⊢ᵉ t ∶ a → Δ ⊢ᵉ uapp f t ∶ b + u-pair : ∀ {Δ : ECx n} {a b s t} → + Δ ⊢ᵉ s ∶ a → Δ ⊢ᵉ t ∶ b → Δ ⊢ᵉ upair s t ∶ eprod a b + u-letp : ∀ {Δ : ECx n} {a b c s t} → + Δ ⊢ᵉ s ∶ eprod a b → (Δ ▹ᵉ a ▹ᵉ b) ⊢ᵉ t ∶ c → + Δ ⊢ᵉ uletp s t ∶ c + u-inl : ∀ {Δ : ECx n} {a b t} → Δ ⊢ᵉ t ∶ a → Δ ⊢ᵉ uinl t ∶ esum a b + u-inr : ∀ {Δ : ECx n} {a b t} → Δ ⊢ᵉ t ∶ b → Δ ⊢ᵉ uinr t ∶ esum a b + u-case : ∀ {Δ : ECx n} {a b c s l r} → + Δ ⊢ᵉ s ∶ esum a b → + (Δ ▹ᵉ a) ⊢ᵉ l ∶ c → (Δ ▹ᵉ b) ⊢ᵉ r ∶ c → + Δ ⊢ᵉ ucase s l r ∶ c + u-lit : ∀ {Δ : ECx n} {b} ℓ → litTy ℓ ≡ b → Δ ⊢ᵉ ulit ℓ ∶ ebase b diff --git a/verification/proofs/agda/Wager/Everything.agda b/verification/proofs/agda/Wager/Everything.agda index c0b297f..67bd9b1 100644 --- a/verification/proofs/agda/Wager/Everything.agda +++ b/verification/proofs/agda/Wager/Everything.agda @@ -34,3 +34,38 @@ import Wager.L2.Preservation import Wager.L2.Progress import Wager.Proofs import Wager.Examples.Stage1 +import Wager.Role.Role +import Wager.Role.Role4 +import Wager.Role.Table +import Wager.Role.Signature +import Wager.Role.RepEq +import Wager.Role.Validity +import Wager.Role.Classic +import Wager.L1.KindingInversion +import Wager.Role.Noninterference +import Wager.Role.Lawful +import Wager.Role.ClassicProofs +import Wager.Examples.Stage2 +import Wager.Erased.Untyped +import Wager.FC.Signature +import Wager.FC.Types +import Wager.FC.Coercion +import Wager.FC.Term +import Wager.FC.Classic +import Wager.FC.RoleSoundness +import Wager.FC.Erasure +import Wager.FC.ClassicProofs +import Wager.Examples.Stage3 +import Wager.FC.Tagged +import Wager.Erased.LogRel +import Wager.Trans.Scheme +import Wager.Trans.Target +import Wager.Trans.Nominal +import Wager.Trans.Coercion +import Wager.Trans.TwoState +import Wager.Grade.Trivial +import Wager.Trans.Typing +import Wager.Trans.Simulation +import Wager.Trans.RoleCorrespondence +import Wager.Trans.TwoStateProofs +import Wager.Examples.Stage4 diff --git a/verification/proofs/agda/Wager/Examples/Stage2.agda b/verification/proofs/agda/Wager/Examples/Stage2.agda new file mode 100644 index 0000000..040b2f9 --- /dev/null +++ b/verification/proofs/agda/Wager/Examples/Stage2.agda @@ -0,0 +1,191 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinded syntax. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Stage 2 anti-vacuity examples. Each theorem of Stage 2 has one closed +-- example that satisfies the hypotheses, and one closed example that +-- the system rejects. The rejected examples that are also statements +-- (T4, the Proxy test) are in Wager.Proofs. This file has the others. +module Wager.Examples.Stage2 where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_; Σ-syntax) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Grade.Affine +open import Wager.Role.Role +open import Wager.Role.Table +open import Wager.Role.Signature +open import Wager.Role.Classic +import Wager.Role.ClassicProofs as CP +import Wager.L1.Syntax +import Wager.L1.Conversion +import Wager.L1.Normal +import Wager.L1.Eval +import Wager.L1.Heads +import Wager.L1.Kinding +import Wager.Role.RepEq +import Wager.Role.Validity +import Wager.L2.Typing +import Wager.L2.Inversion +open import Wager.Proofs + +------------------------------------------------------------------------ +-- T2 with the lawful table. The signature is `classicSig rep`: `proxy` +-- has the declared grade representational, and the signature is valid. + +module T2-Examples where + private + RS = classicSig rep + S = toSig RS + open Wager.L1.Syntax S + open Wager.L1.Normal S + open Wager.L1.Eval S + open Wager.Role.RepEq RS + open Types rep + open CP.LawfulKinding rep + + -- λa. a →[1] Proxy a + arrF : Ty [] (★ ⇒[ rep ] ★) + arrF = lam (arr a1 (var vz) (Proxy (var vz))) + + arrF-kinded : ε ⊢ᵏ arrF + arrF-kinded = k-lam (k-sub (k-arr (k-var vz) (k-capp proxy (k-var vz))) le) + where + le : (unitᵏ vz ⊕ᵏ (rep ⊙ᵏ unitᵏ vz)) ≼ᵏ (ε ▹ᵏ rep) + le k vz = refl + + -- ACCEPTED (T2-Representational): the newtype coercion lifts through + -- the arrow and through `proxy`: (Age → Proxy Age) ≈ (Int → Proxy Int). + accepted-representational : nf (app arrF Age) ≈ nf (app arrF Int) + accepted-representational = + t2-representational RS CP.ProxyB.valid arrF arrF-kinded refl Age Int (CP.Generic.age≈int rep) + + -- ACCEPTED (T2-Phantom): `constF` does not use its parameter, so its + -- results on Age and on Bool have the same normal form. + accepted-phantom : nf (app (constF ph) Age) ≡ nf (app (constF ph) Bool') + accepted-phantom = + t2-phantom RS CP.ProxyB.valid (constF ph) constF-phantom Age Bool' + + -- REJECTED: `classicF` has no kinding at the grade representational + -- (this is T4), so T2 says nothing about it. Its results differ. + rejected : (¬ (ε ⊢ᵏ classicF rep)) + × (¬ (nf (app (classicF rep) Age) ≈ nf (app (classicF rep) Int))) + rejected = t4-kinding-rejects rep refl ε , snd t4-not-equivalent rep + + -- ACCEPTED (T4, anti-vacuity): the same function has a kinding at the + -- grade nominal. The kinding judgement does not reject everything. + classic-at-nominal : ε ⊢ᵏ classicF nom + classic-at-nominal = classicF-nominal + +------------------------------------------------------------------------ +-- Noninterference with the GHC table. The proof does not use the law +-- `a · 𝟘 = 𝟘`, so the GHC table is an instance. + +module GHC-Examples where + private + RS = classicSig rep + S = toSig RS + open Wager.L1.Syntax S + open Wager.L1.Normal S + open Wager.L1.Eval S + open Wager.L1.Kinding S (tableOps tableG) + open Wager.Role.RepEq RS + open Wager.Role.Validity RS mulG + open Types rep + + private + ε : KUsage [] + ε k () + + -- `classicSig rep` respects its declared grades with the GHC table. + valid-ghc : Valid + valid-ghc = record { cvalid = cv ; pvalid = pv } + where + cv : ∀ c ρ {v w} → R★ (mulG ρ (cgrade c)) v w → R★ ρ (ncapp c v) (ncapp c w) + cv age ph h = tt + cv age rep h = ≈-capp age h + cv age nom h = cong (ncapp age) h + cv proxy ph h = tt + cv proxy rep h = ≈-capp proxy h + cv proxy nom h = cong (ncapp proxy) h + + pv : ∀ p ρ {v w} → R★ (mulG ρ (pgrade p)) v w → R★ ρ (inspect p v) (inspect p w) + pv p ph h = tt + pv p rep h = ≡→≈ (cong (inspect p) h) + pv p nom h = cong (inspect p) h + + arrF : Ty [] (★ ⇒[ rep ] ★) + arrF = lam (arr a1 (var vz) (Proxy (var vz))) + + arrF-kinded : ε ⊢ᵏ arrF + arrF-kinded = k-lam (k-sub (k-arr (k-var vz) (k-capp proxy (k-var vz))) le) + where + le : (unitᵏ vz ⊕ᵏ (rep ⊙ᵏ unitᵏ vz)) ≼ᵏ (ε ▹ᵏ rep) + le k vz = refl + + -- ACCEPTED: a representational observer and a representational grade. + accepted : nf (app arrF Age) ≈ nf (app arrF Int) + accepted = + noninterference RS tableG valid-ghc arrF arrF-kinded rep Age Int (CP.Generic.age≈int rep) + + -- With the GHC table, the grade phantom gives `≈` for all arguments. + -- It does not give `≡`: a nominal observer needs equal arguments, + -- because nominal · phantom = nominal. + ghc-phantom : (F : Ty [] (★ ⇒[ ph ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + (A B : Ty [] ★) → nf (app F A) ≈ nf (app F B) + ghc-phantom F d A B = noninterference RS tableG valid-ghc F d rep A B tt + +------------------------------------------------------------------------ +-- The newtype `Age` as a two-state trope on Int, with the Affine +-- algebra on the term grades. + +module Trope-Examples where + private + RS = classicSig rep + S = toSig RS + open Wager.L1.Syntax S using (Ty; ★; []; base; capp) + open Wager.L1.Conversion S + open Wager.L1.Heads S + open Types rep + private TS = classicTSig + open Wager.L2.Typing S TS affineOps + open Wager.L2.Inversion S TS affine + + Γ₀ : Cx 0 + Γ₀ () + + ε : Usage 0 + ε = 0ᵘ + + -- ACCEPTED: wrap 5 has the type Int@age. + wrapped-typed : ε ▸ Γ₀ ⊢ step wrapAge (lit 5) ∶ Age + wrapped-typed = t-step wrapAge (t-lit 5) + + -- ACCEPTED: unwrap (wrap 5) has the type Int, and it reduces to 5. + roundTrip-typed : ε ▸ Γ₀ ⊢ step unwrapAge (step wrapAge (lit 5)) ∶ Int + roundTrip-typed = t-step unwrapAge wrapped-typed + + roundTrip-steps : step unwrapAge (step wrapAge (lit 5)) ⟶ lit {n = 0} 5 + roundTrip-steps = β-strip (v-step v-lit refl) refl + + -- REJECTED: unwrap 5 has no typing. The transition `unwrapAge` starts + -- at the state `age`, and the literal has the raw type. + unwrap-raw-rejected : ∀ {γ : Usage 0} {C : Ty [] ★} → + ¬ (γ ▸ Γ₀ ⊢ step unwrapAge (lit 5) ∶ C) + unwrap-raw-rejected d = + let (γ' , c , le , d') = inv-step d + in headClash (snd (inv-lit d')) refl + + -- REJECTED: wrap 5 does not have the raw type. No conversion relates + -- Int@age and Int: the only way between them is a transition. + wrapped-not-raw : ¬ DefEq {Γ = []} Age Int + wrapped-not-raw d = headClash d refl diff --git a/verification/proofs/agda/Wager/Examples/Stage3.agda b/verification/proofs/agda/Wager/Examples/Stage3.agda new file mode 100644 index 0000000..09b5604 --- /dev/null +++ b/verification/proofs/agda/Wager/Examples/Stage3.agda @@ -0,0 +1,218 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on typing derivations. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Stage 3 anti-vacuity examples. Each theorem of Stage 3 has one closed +-- example that satisfies the hypotheses, and one closed example that +-- the source calculus rejects. The examples for the classic program are +-- statements, and they are in Wager.Proofs. This file has the others. +-- +-- The signature of this file: +-- +-- newtype Age = MkAge Int +-- newtype Box a = MkBox (a, Int) -- inferred role: representational +-- newtype Tag a = MkTag Int -- inferred role: phantom +-- newtype T a = MkT (F a) -- inferred role: nominal +-- type family F a where { F Int = Bool ; F Age = Char ; F (Tag a) = G a } +-- type family G a where { G Int = Bool ; G Bool = Char } +-- +-- The signature is `taggedS d` of Wager.FC.Tagged: d is the declared role +-- of the parameter of Box. Tag is declared phantom and T is declared nominal. +module Wager.Examples.Stage3 where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (true; false) +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Grade.Finite using (false≢true) +open import Wager.Role.Role +open import Wager.FC.Signature +open import Wager.FC.Tagged +open import Wager.Erased.Untyped +import Wager.FC.Types +import Wager.FC.Coercion +import Wager.FC.Term +import Wager.FC.RoleSoundness +import Wager.FC.Erasure +open import Wager.Proofs + + +------------------------------------------------------------------------ +-- The role check. + +module Role-Check where + + -- Accepted: Box declared representational (the inferred role). + wr-rep : SSig.WellRoled (taggedS rep) + wr-rep boxE = refl + wr-rep tagE = refl + wr-rep teeE = refl + + -- Accepted: Box declared nominal (a declared role above the inferred role). + wr-nom : SSig.WellRoled (taggedS nom) + wr-nom boxE = refl + wr-nom tagE = refl + wr-nom teeE = refl + + -- Rejected: Box declared phantom. + wr-ph-rejected : ¬ SSig.WellRoled (taggedS ph) + wr-ph-rejected wr = false≢true (wr boxE) + +------------------------------------------------------------------------ +-- Coercions, in the signature with Box declared representational. + +private + SS = taggedS rep + +open Wager.FC.Types SS +open Wager.FC.Coercion SS +open Wager.FC.Term SS +open Wager.FC.RoleSoundness SS +open Typing litTy +open Role-Check using (wr-rep) +open TTypes rep renaming (Tee to T) + + +private + IsInt : BaseName → Type + IsInt bInt = Unit + IsInt _ = ⊥ + + IsBool : BaseName → Type + IsBool bBool = Unit + IsBool _ = ⊥ + + IsEInt : ETy BaseName → Type + IsEInt (ebase b) = IsInt b + IsEInt _ = ⊥ + + IsEChar : ETy BaseName → Type + IsEChar (ebase bChar) = Unit + IsEChar _ = ⊥ + + IsVBool : VTy → Type + IsVBool (vbase b) = IsBool b + IsVBool _ = ⊥ + + IsTagInt : VTy → Type + IsTagInt (vnt₁ tagE (vbase b)) = IsInt b + IsTagInt _ = ⊥ + +module Role-Soundness-Examples where + + -- Accepted: Box Age ~R Box Int, by congruence at the role + -- representational and the newtype rule for Age. + box-co : Co rep (Box sAge) (Box sInt) + box-co = c-nt₁ boxE (c-ax₀ ageE) + + -- The instance of Source-Role-Soundness for this coercion. + box-er : er (Box sAge) ≡ er (Box sInt) + box-er = source-role-soundness SS wr-rep _ _ box-co + + -- Accepted: Tag Int ~R Tag Bool, because the parameter of Tag is phantom. + tag-co : Co rep (Tag sInt) (Tag sBool) + tag-co = c-nt₁ tagE c-ph + + -- Rejected: there is no coercion Int ~R Bool. + int-bool-rejected : ¬ Co rep sInt sBool + int-bool-rejected γ = subst IsEInt (source-role-soundness SS wr-rep _ _ γ) tt + + -- Rejected: there is no coercion T Age ~R T Int. The erased types are + -- Char and Bool. + tee-rejected : ¬ Co rep (T sAge) (T sInt) + tee-rejected γ = subst IsEChar (source-role-soundness SS wr-rep _ _ γ) tt + +module Nominal-Soundness-Examples where + + -- Accepted: F (Tag Int) ~N Bool, with the equations F (Tag a) = G a + -- and G Int = Bool. + f-tag-int : Co nom (F (Tag sInt)) sBool + f-tag-int = c-trans (c-fnt₁ fE tagE sInt) (c-fbase gE bInt) + + f-tag-bool : Co nom (F (Tag sBool)) sChar + f-tag-bool = c-trans (c-fnt₁ fE tagE sBool) (c-fbase gE bBool) + + -- The instance of Source-Nominal-Soundness. + f-tag-int-ev : ev (F (Tag sInt)) ≡ ev sBool + f-tag-int-ev = source-nominal-soundness SS _ _ f-tag-int + + -- Rejected: Tag Int and Tag Bool are NOT nominally equal. The + -- parameter of Tag is phantom, but a newtype is generative. + tag-nominal-rejected : ¬ Co nom (Tag sInt) (Tag sBool) + tag-nominal-rejected γ = subst IsTagInt (source-nominal-soundness SS _ _ γ) tt + + -- Rejected: F (Tag Int) and F (Tag Bool) are not nominally equal. + -- A type-level function sees the argument of a phantom parameter. + -- (Stage 4 uses this example.) + f-sees-phantom : ¬ Co nom (F (Tag sInt)) (F (Tag sBool)) + f-sees-phantom γ = subst IsVBool (source-nominal-soundness SS _ _ γ) tt + +------------------------------------------------------------------------ +-- Terms, erasure and evaluation. + +module Term-Examples where + open Role-Soundness-Examples + + -- MkAge 5 : Age (the constructor of a newtype is a cast) + anAge : STm ∅ˢ sAge + anAge = cast (c-sym (c-ax₀ ageE)) (slit ℓint) + + -- MkBox (MkAge 5, 7) : Box Age + aBox : STm ∅ˢ (Box sAge) + aBox = cast (c-sym (c-ax₁ boxE sAge)) (spair anAge (slit ℓint)) + + -- coerce (MkBox (MkAge 5, 7)) : Box Int + prog : STm ∅ˢ (Box sInt) + prog = sapp (coerce box-co) aBox + + -- Accepted (Cast-Vanishes, Coerce-Erases-To-Identity): the erased + -- program has no cast and no newtype constructor. + prog-erased : eraseTm prog ≡ uapp (ulam (uvar zero)) (upair (ulit ℓint) (ulit ℓint)) + prog-erased = refl + + -- Rejected: a function that is not a coercion does not erase to the + -- identity function. + private + IsId : ∀ {n} → UTm n → Type + IsId (ulam (uvar zero)) = Unit + IsId _ = ⊥ + + const-not-identity : ¬ (eraseTm (slam {τ = sInt} {Γ = ∅ˢ} (slit ℓint)) ≡ ulam (uvar zero)) + const-not-identity p = subst IsId (sym p) tt + + -- Accepted: the erased program evaluates to the pair of the two literals. + prog-value : ∅ᵉ ⊢ eraseTm prog ⇓ vpair (vlit ℓint) (vlit ℓint) + prog-value = ⇓-app ⇓-lam (⇓-pair ⇓-lit ⇓-lit) (⇓-var zero) + + -- Accepted (Erasure-Preserves-Typing): the erased program has the + -- erased type of `Box Int`, the pair type (Int, Int). + prog-typed : (λ i → er (∅ˢ i)) ⊢ᵉ eraseTm prog ∶ eprod (ebase bInt) (ebase bInt) + prog-typed = erasure-preserves-typing SS wr-rep prog + + -- Rejected: an untyped term with no erased type (a literal in the + -- position of a function). + stuck-untyped : ∀ {a} → ¬ (∅ᶜ ⊢ᵉ uapp (ulit ℓint) (ulit ℓint) ∶ a) + stuck-untyped (u-app () _) + + -- The binding order of `sletp` agrees in typing and in evaluation: + -- index 1 is the first component. + first : STm ∅ˢ sInt + first = sletp (spair (slit ℓint) (slit ℓbool)) (svar (suc zero)) + + first-value : ∅ᵉ ⊢ eraseTm first ⇓ vlit ℓint + first-value = ⇓-letp (⇓-pair ⇓-lit ⇓-lit) (⇓-var (suc zero)) + + -- A sum and a case: the left branch is taken. + pick : STm ∅ˢ sInt + pick = scase (sinl {σ = sBool} (slit ℓint)) (svar zero) (slit ℓint) + + pick-value : ∅ᵉ ⊢ eraseTm pick ⇓ vlit ℓint + pick-value = ⇓-casel (⇓-inl ⇓-lit) (⇓-var zero) diff --git a/verification/proofs/agda/Wager/Examples/Stage4.agda b/verification/proofs/agda/Wager/Examples/Stage4.agda new file mode 100644 index 0000000..c9366cb --- /dev/null +++ b/verification/proofs/agda/Wager/Examples/Stage4.agda @@ -0,0 +1,229 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on typing derivations and values. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Stage 4 anti-vacuity examples. Each theorem of Stage 4 has one closed +-- example that satisfies the hypotheses, and one closed example that is +-- rejected. +-- +-- The source signature is `taggedS rep` of Wager.FC.Tagged (Age, Box, +-- the phantom newtype Tag, the nominal newtype T, the functions F and +-- G). The state scheme is the row scheme. +module Wager.Examples.Stage4 where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (true; false) +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_; _,_; fst; snd; Σ-syntax) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Grade.Algebra +open import Wager.Grade.Finite using (false≢true) +open import Wager.Grade.Affine +open import Wager.Grade.Trivial +open import Wager.Role.Role +open import Wager.Role.Table +open import Wager.FC.Signature +open import Wager.FC.Tagged +open import Wager.FC.Classic using (classicS) +open import Wager.Erased.Untyped +import Wager.FC.Types +import Wager.FC.Coercion +import Wager.FC.Term +import Wager.Trans.Scheme +import Wager.Trans.Target +import Wager.Trans.Coercion +import Wager.Trans.TwoState +import Wager.Erased.LogRel +import Wager.L1.Conversion +import Wager.L1.Normal +import Wager.L1.Eval +import Wager.L1.Equality +import Wager.L1.Kinding +import Wager.L2.Typing +import Wager.L2.Inversion +import Wager.L2.Preservation +open import Wager.Examples.Stage3 using (module Role-Check; module Role-Soundness-Examples; module Term-Examples) +open import Wager.Proofs + +private + SS = taggedS rep + Sc = Wager.Trans.Scheme.rowScheme SS + +open Wager.FC.Types SS +open Wager.FC.Coercion SS +open Wager.FC.Term SS +open TTypes rep +open Role-Check using (wr-rep) +open Role-Soundness-Examples using (box-co; tag-co) +open Term-Examples using (prog) +open Wager.Erased.LogRel litTy + +------------------------------------------------------------------------ +-- Coercions are terms of the target, in the affine algebra. + +module Coercions-In-Affine where + open Wager.Trans.Target SS Sc affineOps using (tSig; tTSig; T; arr; ★; []) + open Wager.Trans.Coercion SS Sc affineOps using (coerceT; tr; tlam; lit; Tm) + open Wager.L1.Conversion tSig + open Wager.L1.Normal tSig using (Nf; nbase) + open Wager.L1.Eval tSig using (nf) + open Wager.L1.Equality tSig using (defEq→nf) + open Wager.L2.Typing tSig tTSig affineOps using (Cx; Usage; _▸_⊢_∶_; 0ᵘ; _≤ᵘ_) + open Wager.L2.Inversion tSig tTSig affine using (inv-lit) + open Wager.L2.Preservation tSig tTSig affine using (inv-lam) + open GradeOps affineOps using (_≤_; 𝟘; 𝟙) + + private + ∅ : Cx 0 + ∅ () + + -- Accepted (Coercion-Is-A-Term): Box Age → Box Int is a typed + -- function of the target. Its parameter has the grade 1 (linear). + box-typed : 0ᵘ ▸ ∅ ⊢ coerceT box-co ∶ arr a1 (T (Box sAge)) (T (Box sInt)) + box-typed = coercion-is-a-term SS Sc affine wr-rep box-co ∅ + + -- Accepted: the phantom coercion Tag Int → Tag Bool is a typed + -- function of the target (two trope transitions). + tag-typed : 0ᵘ ▸ ∅ ⊢ coerceT tag-co ∶ arr a1 (T (Tag sInt)) (T (Tag sBool)) + tag-typed = coercion-is-a-term SS Sc affine wr-rep tag-co ∅ + + -- The two target types are two different states of the carrier Int: + -- they are NOT convertible. The function F tells them apart. + private + IsBoolNf : Nf [] ★ → Type + IsBoolNf (nbase bBool) = Unit + IsBoolNf _ = ⊥ + + tag-states-differ : ¬ DefEq (T (Tag sInt)) (T (Tag sBool)) + tag-states-differ e = subst IsBoolNf (defEq→nf (d-papp {p = fE} e)) tt + + -- Rejected (T5-Typing needs an unrestricted grade 1): in the affine + -- algebra the grade 1 is linear. The hypothesis 0 ≤ 1 is false, and + -- the translation of a function that drops its argument has no type. + affine-not-unrestricted : ¬ (𝟘 ≤ 𝟙) + affine-not-unrestricted p = false≢true p + + constFun : STm ∅ˢ (sInt ⇒ˢ sInt) + constFun = slam (slit ℓint) + + const-rejected : ∀ {γ : Usage 0} {Γ : Cx 0} {C} → ¬ (γ ▸ Γ ⊢ tr constFun ∶ C) + const-rejected d = + let (B , γ' , c , le , d') = inv-lam d + in false≢true (fst (inv-lit d') zero) + +------------------------------------------------------------------------ +-- Whole programs, in the one-point algebra (no usage discipline). + +module Programs where + open Wager.Trans.Target SS Sc trivialOps using (tSig; tTSig; T) + open Wager.Trans.Coercion SS Sc trivialOps using (coerceT; tr; eraseT) + open Wager.L2.Typing tSig tTSig trivialOps using (_▸_⊢_∶_) + + -- prog = coerce (MkBox (MkAge 5, 7)) : Box Int (Wager.Examples.Stage3) + + -- Accepted (T5-Typing): the translated program has the translated type. + prog-typed : (λ _ → tt) ▸ (λ i → T (∅ˢ i)) ⊢ tr prog ∶ T (Box sInt) + prog-typed = t5-typing SS Sc trivial wr-rep tt tt prog + + -- The erased translation. The trope transitions vanished. The map of + -- the pair stays: the erased coercion is `λp. let (x, y) = p in (x, y)`. + prog-erased : + eraseT (tr prog) + ≡ uapp (ulam (uletp (uvar zero) (upair (uvar (suc zero)) (uvar zero)))) + (upair (ulit ℓint) (ulit ℓint)) + prog-erased = refl + + -- Accepted (T5-Behaviour): the erased source program and the erased + -- translation evaluate to one value, the pair of the two literals. + source-value : ∅ᵉ ⊢ eraseTm prog ⇓ vpair (vlit ℓint) (vlit ℓint) + source-value = ⇓-app ⇓-lam (⇓-pair ⇓-lit ⇓-lit) (⇓-var zero) + + target-value : ∅ᵉ ⊢ eraseT (tr prog) ⇓ vpair (vlit ℓint) (vlit ℓint) + target-value = + ⇓-app ⇓-lam (⇓-pair ⇓-lit ⇓-lit) + (⇓-letp (⇓-var zero) (⇓-pair (⇓-var (suc zero)) (⇓-var zero))) + + -- The instance of the theorem for this program. + prog-same-value : + Σ[ v ∈ UVal ] (∅ᵉ ⊢ eraseTm prog ⇓ v) × (∅ᵉ ⊢ eraseT (tr prog) ⇓ v) + prog-same-value = + t5-behaviour-first-order SS Sc trivial wr-rep prog (fo-prod fo-base fo-base) + + -- Accepted (T3): the erased coercion Box Age → Box Int is + -- observationally equal to the identity function. + box-identity : + Σ[ f ∈ UVal ] (∅ᵉ ⊢ eraseT (coerceT box-co) ⇓ f) + × 𝒱 (earr (er (Box sAge)) (er (Box sAge))) (vclo ∅ᵉ (uvar zero)) f + box-identity = t3 SS Sc trivial wr-rep box-co + +------------------------------------------------------------------------ +-- Rejected (T3): the relation `𝒱` is not trivial. The function that +-- swaps the two sides of a sum is NOT observationally equal to the +-- identity function. + +module Not-The-Identity where + private + eInt : ETy BaseName + eInt = ebase bInt + + swapBody : UTm 1 + swapBody = ucase (uvar zero) (uinr (uvar zero)) (uinl (uvar zero)) + + five : UVal + five = vinl (vlit ℓint) + + swap-not-identity : + ¬ 𝒱 (earr (esum eInt eInt) (esum eInt eInt)) (vclo ∅ᵉ (uvar zero)) (vclo ∅ᵉ swapBody) + swap-not-identity (r-clo h) with h five five (r-inl (r-lit ℓint refl)) + ... | _ , _ , ⇓-var zero , ⇓-casel (⇓-var zero) (⇓-inr (⇓-var zero)) , () + +------------------------------------------------------------------------ +-- Role correspondence, in the lawful role table. + +module Role-Examples where + open Wager.Trans.Target SS Sc trivialOps using (tSig; bodyFun; []) + open Wager.L1.Kinding tSig (tableOps tableZ) + + -- Accepted: kinding accepts the grade representational for the body + -- of Box, and the grade phantom for the body of Tag. + box-rep : Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun boxE rep) + box-rep = fst (role-correspondence SS Sc trivial boxE rep) refl + + tag-ph : Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun tagE ph) + tag-ph = fst (role-correspondence SS Sc trivial tagE ph) refl + + -- Rejected: kinding rejects the grade representational for the body + -- of T (the parameter is below a type-level function), and the grade + -- phantom for the body of Box. + tee-rep-rejected : (γ : KUsage []) → ¬ (γ ⊢ᵏ bodyFun teeE rep) + tee-rep-rejected γ d = false≢true (snd (role-correspondence SS Sc trivial teeE rep) γ d) + + box-ph-rejected : (γ : KUsage []) → ¬ (γ ⊢ᵏ bodyFun boxE ph) + box-ph-rejected γ d = false≢true (snd (role-correspondence SS Sc trivial boxE ph) γ d) + +------------------------------------------------------------------------ +-- Two-state tropes. + +module Two-State-Examples where + + -- Accepted: the classic signature of Stage 3 (Age, T, F) has a + -- two-state translation. No function looks at the argument of T. + classic-two-state : + Σ[ t ∈ Wager.Trans.TwoState.Translation (classicS nom) _ ] + Wager.Trans.TwoState.TwoState (classicS nom) _ t + classic-two-state = + two-state-translation-exists (classicS nom) trivialOps (λ _ _ → bUnit) (λ F N → refl) + + -- Rejected: the tagged signature has no two-state translation + -- (`Wager.Proofs.no-two-state-translation`). It has the translation + -- with the row scheme. + tagged-row : Wager.Trans.TwoState.Translation SS _ + tagged-row = row-translation-exists SS trivialOps diff --git a/verification/proofs/agda/Wager/FC/Classic.agda b/verification/proofs/agda/Wager/FC/Classic.agda new file mode 100644 index 0000000..1c7f080 --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Classic.agda @@ -0,0 +1,76 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The classic unsound program, in the source calculus (definitions only). +-- +-- newtype Age = MkAge Int +-- type family F a where { F Int = Bool ; F Age = Char } +-- newtype T a = MkT (F a) +-- +-- The parameter of T has the inferred role nominal, because it is the +-- argument of a type-level function. The declared role `d` of the +-- parameter is a parameter of the signature: +-- d = nom the correct declaration; +-- d = rep the wrong declaration. With it, `T Age` and `T Int` are +-- representationally equal, and a Char becomes a Bool. +module Wager.FC.Classic where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Sum.Base using (inl) + +open import Wager.Role.Role +open import Wager.Role.Classic using (BaseName; bInt; bBool; bChar; bUnit) public +open import Wager.Erased.Untyped using (ebase) +open import Wager.FC.Signature +import Wager.FC.Types + +-- One literal for each base type. +data LitName : Type where + ℓint ℓbool ℓchar ℓunit : LitName + +data Nt₀ : Type where + ageN : Nt₀ + +data Nt₁ : Type where + teeN : Nt₁ + +data FamName : Type where + famF : FamName + +litTyC : LitName → BaseName +litTyC ℓint = bInt +litTyC ℓbool = bBool +litTyC ℓchar = bChar +litTyC ℓunit = bUnit + +private + -- F Int = Bool, and Unit on each other base type. + fBaseC : FamName → BaseName → BaseName + fBaseC famF bInt = bBool + fBaseC famF _ = bUnit + +-- `d` is the declared role of the parameter of T. +classicS : Role → SSig +classicS d = record + { Base = BaseName ; Lit = LitName ; litTy = litTyC + ; N₀ = Nt₀ ; rep₀ = λ _ → ebase bInt + ; N₁ = Nt₁ ; Fam = FamName + ; body = λ _ → bfam famF bvar ; role = λ _ → d + ; fBase = fBaseC + ; fNt₀ = λ _ _ → bChar -- F Age = Char + ; fNt₁ = λ _ _ → inl bUnit ; fOther = λ _ → bUnit } + +module STypes (d : Role) where + open Wager.FC.Types (classicS d) + + sInt sBool sChar sAge : STy + sInt = sbase bInt + sBool = sbase bBool + sChar = sbase bChar + sAge = nt₀ ageN + + sT sF : STy → STy + sT τ = nt₁ teeN τ + sF τ = fam famF τ diff --git a/verification/proofs/agda/Wager/FC/ClassicProofs.agda b/verification/proofs/agda/Wager/FC/ClassicProofs.agda new file mode 100644 index 0000000..b244692 --- /dev/null +++ b/verification/proofs/agda/Wager/FC/ClassicProofs.agda @@ -0,0 +1,103 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on typing derivations. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The classic unsound program in the source calculus: proofs (Stage 3). +module Wager.FC.ClassicProofs where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_; _,_) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Grade.Finite using (false≢true) +open import Wager.Role.Role +open import Wager.FC.Signature +open import Wager.FC.Classic +open import Wager.Erased.Untyped +import Wager.FC.Types +import Wager.FC.Coercion +import Wager.FC.Term +import Wager.FC.RoleSoundness + +private + IsChar : BaseName → Type + IsChar bChar = Unit + IsChar _ = ⊥ + + bChar≢bBool : ¬ (bChar ≡ bBool) + bChar≢bBool p = subst IsChar p tt + + IsEChar : ETy BaseName → Type + IsEChar (ebase b) = IsChar b + IsEChar _ = ⊥ + + eChar≢eBool : ¬ (ebase bChar ≡ ebase bBool) + eChar≢eBool p = subst IsEChar p tt + +-- The inferred role of the parameter of T is nominal. The check +-- rejects each declared role below nominal. +classic-rejected : (d : Role) → leR d rep ≡ true → ¬ SSig.WellRoled (classicS d) +classic-rejected ph _ wr = false≢true (wr teeN) +classic-rejected rep _ wr = false≢true (wr teeN) +classic-rejected nom p _ = false≢true p + +------------------------------------------------------------------------ +-- The wrong declaration: the parameter of T is representational. + +module Bad where + open STypes rep + open Wager.FC.Types (classicS rep) + open Wager.FC.Coercion (classicS rep) + open Wager.FC.Term (classicS rep) + open Typing litTy + + -- T Age ~R T Int, by congruence at the declared role and Age ~R Int. + tAge~tInt : Co rep (sT sAge) (sT sInt) + tAge~tInt = c-nt₁ teeN (c-ax₀ ageN) + + -- Char ~N F Age ~R T Age ~R T Int ~R F Int ~N Bool. + char~bool : Co rep sChar sBool + char~bool = + c-trans (c-sym (c-sub (c-fnt₀ famF ageN))) + (c-trans (c-sym (c-ax₁ teeN sAge)) + (c-trans tAge~tInt + (c-trans (c-ax₁ teeN sInt) + (c-sub (c-fbase famF bInt))))) + + -- A Char literal, cast to the type Bool. + exploit : STm ∅ˢ sBool + exploit = cast char~bool (slit ℓchar) + + exploit-erased : eraseTm exploit ≡ ulit ℓchar + exploit-erased = refl + + exploit-value : ∅ᵉ ⊢ eraseTm exploit ⇓ vlit ℓchar + exploit-value = ⇓-lit + + exploit-untyped : ¬ (∅ᶜ ⊢ᵉ eraseTm exploit ∶ er sBool) + exploit-untyped (u-lit ℓ p) = bChar≢bBool p + +------------------------------------------------------------------------ +-- The correct declaration: the parameter of T is nominal. + +module Good where + open STypes nom + open Wager.FC.Types (classicS nom) + open Wager.FC.Coercion (classicS nom) + open Wager.FC.RoleSoundness (classicS nom) + + accepted : WellRoled + accepted teeN = refl + + age~int : Co rep sAge sInt + age~int = c-ax₀ ageN + + -- er (T Age) = Char and er (T Int) = Bool. + no-coercion : ¬ Co rep (sT sAge) (sT sInt) + no-coercion γ = eChar≢eBool (rep-sound accepted γ) diff --git a/verification/proofs/agda/Wager/FC/Coercion.agda b/verification/proofs/agda/Wager/FC/Coercion.agda new file mode 100644 index 0000000..3634cdf --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Coercion.agda @@ -0,0 +1,70 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Coercions of the source calculus (Stage 3). +-- +-- `Co r τ σ` is a proof term for the equality of τ and σ at the role r: +-- nom nominal equality (the equality of the type checker); +-- rep representational equality (the two types have one +-- representation), the equality that `coerce` uses; +-- ph phantom equality (each two types are equal at this role). +-- +-- The rules follow Breitner et al.: reflexivity, symmetry, +-- transitivity, the rule from nominal to representational, the phantom +-- rule, role-gated congruence, the newtype rules and the rules of the +-- type-level functions. +-- +-- This relation belongs to the SOURCE calculus. The target calculus of +-- the wager has no such relation. +open import Wager.FC.Signature + +module Wager.FC.Coercion (SS : SSig) where + +open import Cubical.Foundations.Prelude + +open import Wager.Role.Role +open import Wager.FC.Types SS + +private + variable + r : Role + τ τ' σ σ' υ : STy + +data Co : Role → STy → STy → Type where + c-refl : Co nom τ τ + c-sym : Co r τ σ → Co r σ τ + c-trans : Co r τ σ → Co r σ υ → Co r τ υ + -- Nominal equality gives representational equality. + c-sub : Co nom τ σ → Co rep τ σ + -- Each two types are equal at the role phantom. + c-ph : Co ph τ σ + + -- Role-gated congruence. The parameters of a function, a pair and a + -- sum are representational. + c-arr : Co r τ τ' → Co r σ σ' → Co r (τ ⇒ˢ σ) (τ' ⇒ˢ σ') + c-prod : Co r τ τ' → Co r σ σ' → Co r (τ ×ˢ σ) (τ' ×ˢ σ') + c-sum : Co r τ τ' → Co r σ σ' → Co r (τ +ˢ σ) (τ' +ˢ σ') + -- A newtype with the declared role `role N`. The premise has the + -- role `mulG r (role N)`, with the composition table of GHC: + -- at nom the arguments are equal at nom (also for a phantom parameter); + -- at rep the arguments are equal at the declared role; + -- at ph there is no condition. + c-nt₁ : (N : N₁) → Co (mulG r (role N)) τ σ → Co r (nt₁ N τ) (nt₁ N σ) + -- The parameter of a type-level function is nominal. + c-fam : (F : Fam) → Co nom τ σ → Co nom (fam F τ) (fam F σ) + + -- Newtype rules: a newtype is representationally equal to its + -- representation. + c-ax₀ : (N : N₀) → Co rep (nt₀ N) (embE (rep₀ N)) + c-ax₁ : (N : N₁) (τ : STy) → Co rep (nt₁ N τ) (inst (body N) τ) + + -- The equations of a type-level function, by the head of the argument. + c-fbase : (F : Fam) (b : Base) → Co nom (fam F (sbase b)) (sbase (fBase F b)) + c-fnt₀ : (F : Fam) (N : N₀) → Co nom (fam F (nt₀ N)) (sbase (fNt₀ F N)) + c-fnt₁ : (F : Fam) (N : N₁) (τ : STy) → + Co nom (fam F (nt₁ N τ)) (resS (fNt₁ F N) τ) + c-farr : (F : Fam) (τ σ : STy) → Co nom (fam F (τ ⇒ˢ σ)) (sbase (fOther F)) + c-fprod : (F : Fam) (τ σ : STy) → Co nom (fam F (τ ×ˢ σ)) (sbase (fOther F)) + c-fsum : (F : Fam) (τ σ : STy) → Co nom (fam F (τ +ˢ σ)) (sbase (fOther F)) diff --git a/verification/proofs/agda/Wager/FC/Erasure.agda b/verification/proofs/agda/Wager/FC/Erasure.agda new file mode 100644 index 0000000..ad8da4f --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Erasure.agda @@ -0,0 +1,68 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on typed terms. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Erasure preserves typing (Stage 3). +-- +-- In a signature that passes the role check, the erasure of a source +-- term of the type τ has the erased type `er τ`. The case of a cast is +-- the soundness of the roles: the two types of the coercion have one +-- erased type, so the erased term needs no change. +open import Wager.FC.Signature + +module Wager.FC.Erasure (SS : SSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) + +open import Wager.Role.Role +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +open import Wager.FC.Term SS +open import Wager.FC.RoleSoundness SS +open import Wager.Erased.Untyped +open Typing litTy + +private + variable + n : ℕ + + -- A context of erased types that agrees with a source context. + Agree : ECx n → SCx n → Type + Agree Δ Γ = ∀ i → Δ i ≡ er (Γ i) + + agree-ext : ∀ {Δ : ECx n} {Γ : SCx n} τ → Agree Δ Γ → Agree (Δ ▹ᵉ er τ) (Γ ▹ˢ τ) + agree-ext τ h zero = refl + agree-ext τ h (suc i) = h i + +module _ (wr : WellRoled) where + + erase-typing′ : ∀ {Γ : SCx n} {τ} (e : STm Γ τ) (Δ : ECx n) → Agree Δ Γ → + Δ ⊢ᵉ eraseTm e ∶ er τ + erase-typing′ (svar i) Δ h = u-var i (h i) + erase-typing′ (slam {τ = τ} b) Δ h = + u-lam (erase-typing′ b (Δ ▹ᵉ er τ) (agree-ext τ h)) + erase-typing′ (sapp f a) Δ h = u-app (erase-typing′ f Δ h) (erase-typing′ a Δ h) + erase-typing′ (spair s t) Δ h = u-pair (erase-typing′ s Δ h) (erase-typing′ t Δ h) + erase-typing′ (sletp {τ = τ} {σ = σ} s b) Δ h = + u-letp (erase-typing′ s Δ h) + (erase-typing′ b (Δ ▹ᵉ er τ ▹ᵉ er σ) (agree-ext σ (agree-ext τ h))) + erase-typing′ (sinl t) Δ h = u-inl (erase-typing′ t Δ h) + erase-typing′ (sinr t) Δ h = u-inr (erase-typing′ t Δ h) + erase-typing′ (scase {τ = τ} {σ = σ} s l r) Δ h = + u-case (erase-typing′ s Δ h) + (erase-typing′ l (Δ ▹ᵉ er τ) (agree-ext τ h)) + (erase-typing′ r (Δ ▹ᵉ er σ) (agree-ext σ h)) + erase-typing′ (slit ℓ) Δ h = u-lit ℓ refl + -- The cast vanished in the term. The type changes along the equality + -- of the two erased types. + erase-typing′ (cast γ e) Δ h = + subst (λ a → Δ ⊢ᵉ eraseTm e ∶ a) (rep-sound wr γ) (erase-typing′ e Δ h) + + erase-typing : ∀ {Γ : SCx n} {τ} (e : STm Γ τ) → + (λ i → er (Γ i)) ⊢ᵉ eraseTm e ∶ er τ + erase-typing {Γ = Γ} e = erase-typing′ e (λ i → er (Γ i)) (λ i → refl) diff --git a/verification/proofs/agda/Wager/FC/RoleSoundness.agda b/verification/proofs/agda/Wager/FC/RoleSoundness.agda new file mode 100644 index 0000000..67548ad --- /dev/null +++ b/verification/proofs/agda/Wager/FC/RoleSoundness.agda @@ -0,0 +1,219 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on coercions. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Soundness of the roles of the source calculus (Stage 3). +-- +-- A coercion at the role r relates two types whose values are related +-- at r: +-- nom the nominal values are equal; +-- rep the erased types are equal; +-- ph no condition. +-- The representational part needs the role check `WellRoled`. +open import Wager.FC.Signature + +module Wager.FC.RoleSoundness (SS : SSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Grade.Finite using (false≢true) +open import Wager.Role.Role +open import Wager.Erased.Untyped using (ETy; ebase; earr; eprod; esum) +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS + +RelV : Role → VTy → VTy → Type +RelV ph v w = Unit +RelV rep v w = erV v ≡ erV w +RelV nom v w = v ≡ w + +-- A relation at a role gives the relation at each lower role. +RelV-anti : ∀ a b {v w} → leR a b ≡ true → RelV b v w → RelV a v w +RelV-anti ph b _ _ = tt +RelV-anti rep ph p _ = ⊥.rec (false≢true p) +RelV-anti rep rep _ x = x +RelV-anti rep nom _ x = cong erV x +RelV-anti nom ph p _ = ⊥.rec (false≢true p) +RelV-anti nom rep p _ = ⊥.rec (false≢true p) +RelV-anti nom nom _ x = x + +private + RelV-sym : ∀ r {v w} → RelV r v w → RelV r w v + RelV-sym ph _ = tt + RelV-sym rep p = sym p + RelV-sym nom p = sym p + + RelV-trans : ∀ r {u v w} → RelV r u v → RelV r v w → RelV r u w + RelV-trans ph _ _ = tt + RelV-trans rep p q = p ∙ q + RelV-trans nom p q = p ∙ q + + RelV-arr : ∀ r {a a' b b'} → RelV r a a' → RelV r b b' → RelV r (varr a b) (varr a' b') + RelV-arr ph _ _ = tt + RelV-arr rep p q = cong₂ earr p q + RelV-arr nom p q = cong₂ varr p q + + RelV-prod : ∀ r {a a' b b'} → RelV r a a' → RelV r b b' → RelV r (vprod a b) (vprod a' b') + RelV-prod ph _ _ = tt + RelV-prod rep p q = cong₂ eprod p q + RelV-prod nom p q = cong₂ vprod p q + + RelV-sum : ∀ r {a a' b b'} → RelV r a a' → RelV r b b' → RelV r (vsum a b) (vsum a' b') + RelV-sum ph _ _ = tt + RelV-sum rep p q = cong₂ esum p q + RelV-sum nom p q = cong₂ vsum p q + +-- Three facts about the composition `nominal · _` of the lawful table. +nomZ-l : ∀ a b → leR (mulZ nom a) (mulZ nom (maxR a b)) ≡ true +nomZ-l ph b = refl +nomZ-l rep ph = refl +nomZ-l rep rep = refl +nomZ-l rep nom = refl +nomZ-l nom b = refl + +nomZ-r : ∀ a b → leR (mulZ nom b) (mulZ nom (maxR a b)) ≡ true +nomZ-r ph ph = refl +nomZ-r ph rep = refl +nomZ-r ph nom = refl +nomZ-r rep ph = refl +nomZ-r rep rep = refl +nomZ-r rep nom = refl +nomZ-r nom ph = refl +nomZ-r nom rep = refl +nomZ-r nom nom = refl + +nomZ-idem : ∀ a → mulZ nom (mulZ nom a) ≡ mulZ nom a +nomZ-idem ph = refl +nomZ-idem rep = refl +nomZ-idem nom = refl + +------------------------------------------------------------------------ +-- A body respects the inferred role of its parameter. + +-- The nominal value of a body: equal for two arguments that are related +-- at `nominal · (inferred role)`. +body-nom : ∀ β {v w} → RelV (mulZ nom (roleOf β)) v w → evB β v ≡ evB β w +body-nom bvar p = p +body-nom (bbase b) p = refl +body-nom (barr β γ) p = + cong₂ varr (body-nom β (RelV-anti _ _ (nomZ-l (roleOf β) (roleOf γ)) p)) + (body-nom γ (RelV-anti _ _ (nomZ-r (roleOf β) (roleOf γ)) p)) +body-nom (bprod β γ) p = + cong₂ vprod (body-nom β (RelV-anti _ _ (nomZ-l (roleOf β) (roleOf γ)) p)) + (body-nom γ (RelV-anti _ _ (nomZ-r (roleOf β) (roleOf γ)) p)) +body-nom (bsum β γ) p = + cong₂ vsum (body-nom β (RelV-anti _ _ (nomZ-l (roleOf β) (roleOf γ)) p)) + (body-nom γ (RelV-anti _ _ (nomZ-r (roleOf β) (roleOf γ)) p)) +body-nom (bfam F β) {v} {w} p = + cong (λ x → vbase (applyF F x)) + (body-nom β (subst (λ r → RelV r v w) (nomZ-idem (roleOf β)) p)) + +-- The erased type of a body: equal for two arguments that are related +-- at the inferred role. +body-rep : ∀ β {v w} → RelV (roleOf β) v w → erB β v (erV v) ≡ erB β w (erV w) +body-rep bvar p = p +body-rep (bbase b) p = refl +body-rep (barr β γ) p = + cong₂ earr (body-rep β (RelV-anti _ _ (max-upper-l (roleOf β) (roleOf γ)) p)) + (body-rep γ (RelV-anti _ _ (max-upper-r (roleOf β) (roleOf γ)) p)) +body-rep (bprod β γ) p = + cong₂ eprod (body-rep β (RelV-anti _ _ (max-upper-l (roleOf β) (roleOf γ)) p)) + (body-rep γ (RelV-anti _ _ (max-upper-r (roleOf β) (roleOf γ)) p)) +body-rep (bsum β γ) p = + cong₂ esum (body-rep β (RelV-anti _ _ (max-upper-l (roleOf β) (roleOf γ)) p)) + (body-rep γ (RelV-anti _ _ (max-upper-r (roleOf β) (roleOf γ)) p)) +body-rep (bfam F β) p = cong (λ x → ebase (applyF F x)) (body-nom β p) + +------------------------------------------------------------------------ +-- Instances of a body, and the embedding of erased types. + +ev-inst : ∀ β τ → ev (inst β τ) ≡ evB β (ev τ) +ev-inst bvar τ = refl +ev-inst (bbase b) τ = refl +ev-inst (barr β γ) τ = cong₂ varr (ev-inst β τ) (ev-inst γ τ) +ev-inst (bprod β γ) τ = cong₂ vprod (ev-inst β τ) (ev-inst γ τ) +ev-inst (bsum β γ) τ = cong₂ vsum (ev-inst β τ) (ev-inst γ τ) +ev-inst (bfam F β) τ = cong (λ x → vbase (applyF F x)) (ev-inst β τ) + +er-inst : ∀ β τ → er (inst β τ) ≡ erB β (ev τ) (er τ) +er-inst bvar τ = refl +er-inst (bbase b) τ = refl +er-inst (barr β γ) τ = cong₂ earr (er-inst β τ) (er-inst γ τ) +er-inst (bprod β γ) τ = cong₂ eprod (er-inst β τ) (er-inst γ τ) +er-inst (bsum β γ) τ = cong₂ esum (er-inst β τ) (er-inst γ τ) +er-inst (bfam F β) τ = cong (λ x → ebase (applyF F x)) (ev-inst β τ) + +er-embE : ∀ a → er (embE a) ≡ a +er-embE (ebase b) = refl +er-embE (earr a b) = cong₂ earr (er-embE a) (er-embE b) +er-embE (eprod a b) = cong₂ eprod (er-embE a) (er-embE b) +er-embE (esum a b) = cong₂ esum (er-embE a) (er-embE b) + +ev-resS : ∀ x τ → ev (resS x τ) ≡ vbase (resB x (λ G → applyF G (ev τ))) +ev-resS (inl b) τ = refl +ev-resS (inr G) τ = refl + +------------------------------------------------------------------------ +-- Soundness of nominal coercions. No role check is needed. + +nom-sound : ∀ {τ σ} → Co nom τ σ → ev τ ≡ ev σ +nom-sound c-refl = refl +nom-sound (c-sym γ) = sym (nom-sound γ) +nom-sound (c-trans γ δ) = nom-sound γ ∙ nom-sound δ +nom-sound (c-arr γ δ) = cong₂ varr (nom-sound γ) (nom-sound δ) +nom-sound (c-prod γ δ) = cong₂ vprod (nom-sound γ) (nom-sound δ) +nom-sound (c-sum γ δ) = cong₂ vsum (nom-sound γ) (nom-sound δ) +nom-sound (c-nt₁ N γ) = cong (vnt₁ N) (nom-sound γ) +nom-sound (c-fam F γ) = cong (λ x → vbase (applyF F x)) (nom-sound γ) +nom-sound (c-fbase F b) = refl +nom-sound (c-fnt₀ F N) = refl +nom-sound (c-fnt₁ F N τ) = sym (ev-resS (fNt₁ F N) τ) +nom-sound (c-farr F τ σ) = refl +nom-sound (c-fprod F τ σ) = refl +nom-sound (c-fsum F τ σ) = refl + +------------------------------------------------------------------------ +-- Soundness of coercions at each role, for a signature that passes the +-- role check. + +module _ (wr : WellRoled) where + + private + -- The congruence rule for a newtype. The representational case is + -- the one place that uses the role check. + nt-sound : ∀ r N {v w} → RelV (mulG r (role N)) v w → RelV r (vnt₁ N v) (vnt₁ N w) + nt-sound ph N p = tt + nt-sound rep N p = body-rep (body N) (RelV-anti _ _ (wr N) p) + nt-sound nom N p = cong (vnt₁ N) p + + sound : ∀ {r τ σ} → Co r τ σ → RelV r (ev τ) (ev σ) + sound c-refl = refl + sound (c-sym {r = r} γ) = RelV-sym r (sound γ) + sound (c-trans {r = r} γ δ) = RelV-trans r (sound γ) (sound δ) + sound (c-sub γ) = cong erV (sound γ) + sound c-ph = tt + sound (c-arr {r = r} γ δ) = RelV-arr r (sound γ) (sound δ) + sound (c-prod {r = r} γ δ) = RelV-prod r (sound γ) (sound δ) + sound (c-sum {r = r} γ δ) = RelV-sum r (sound γ) (sound δ) + sound (c-nt₁ {r = r} N γ) = nt-sound r N (sound γ) + sound (c-fam F γ) = cong (λ x → vbase (applyF F x)) (sound γ) + sound (c-ax₀ N) = sym (er-embE (rep₀ N)) + sound (c-ax₁ N τ) = sym (er-inst (body N) τ) + sound (c-fbase F b) = refl + sound (c-fnt₀ F N) = refl + sound (c-fnt₁ F N τ) = sym (ev-resS (fNt₁ F N) τ) + sound (c-farr F τ σ) = refl + sound (c-fprod F τ σ) = refl + sound (c-fsum F τ σ) = refl + + -- The headline form: a representational coercion relates two types + -- with one erased type. + rep-sound : ∀ {τ σ} → Co rep τ σ → er τ ≡ er σ + rep-sound = sound diff --git a/verification/proofs/agda/Wager/FC/Signature.agda b/verification/proofs/agda/Wager/FC/Signature.agda new file mode 100644 index 0000000..9ff918c --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Signature.agda @@ -0,0 +1,73 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The signature of the source calculus (Stage 3). +-- +-- The source calculus is a small fragment of System FC with roles, +-- after Breitner, Eisenberg, Peyton Jones and Weirich, "Safe Zero-cost +-- Coercions for Haskell". A signature declares: +-- +-- base types and literals; +-- newtypes with no parameter newtype N = MkN +-- newtypes with one parameter newtype N a = MkN +-- and a declared role for `a`; +-- total closed type-level functions with one argument. A function +-- looks at the head of its argument, as a closed type family does. +-- +-- Recursion is kept out by construction: a body cannot mention a +-- declared newtype (DESIGN-CHOICES.adoc, DC-3.2). +module Wager.FC.Signature where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (true) +open import Cubical.Data.Sum.Base using (_⊎_) + +open import Wager.Role.Role +open import Wager.Erased.Untyped using (ETy) + +-- The body of a newtype declaration with one parameter. +data Body (B F : Type) : Type where + bvar : Body B F -- the parameter + bbase : B → Body B F + barr bprod bsum : Body B F → Body B F → Body B F + bfam : F → Body B F → Body B F -- a type-level function + +-- Role inference for the parameter of a body. +-- The parameter itself is used at the role representational. +-- A function, a pair and a sum join the uses of their parts. +-- A type-level function makes each use below it nominal. +-- A body without the parameter gives the role phantom. +roleOf : ∀ {B F} → Body B F → Role +roleOf bvar = rep +roleOf (bbase _) = ph +roleOf (barr β γ) = maxR (roleOf β) (roleOf γ) +roleOf (bprod β γ) = maxR (roleOf β) (roleOf γ) +roleOf (bsum β γ) = maxR (roleOf β) (roleOf γ) +roleOf (bfam _ β) = mulZ nom (roleOf β) + +record SSig : Type₁ where + field + Base : Type + Lit : Type + litTy : Lit → Base + -- Newtypes with no parameter, and the representation of each. + N₀ : Type + rep₀ : N₀ → ETy Base + -- Newtypes with one parameter, type-level functions, the body of + -- each newtype and the declared role of its parameter. + N₁ : Type + Fam : Type + body : N₁ → Body Base Fam + role : N₁ → Role + -- The equations of a type-level function, by the head of the argument: + fBase : Fam → Base → Base -- F b = b' + fNt₀ : Fam → N₀ → Base -- F N = b' + fNt₁ : Fam → N₁ → Base ⊎ Fam -- F (N τ) = b' or = G τ + fOther : Fam → Base -- F (function, pair or sum) = b' + + -- THE SOURCE ROLE CHECK. The declared role of each parameter is not + -- below the inferred role. + WellRoled : Type + WellRoled = (N : N₁) → leR (roleOf (body N)) (role N) ≡ true diff --git a/verification/proofs/agda/Wager/FC/Tagged.agda b/verification/proofs/agda/Wager/FC/Tagged.agda new file mode 100644 index 0000000..6c93f6e --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Tagged.agda @@ -0,0 +1,86 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- A source signature with a phantom newtype (definitions only). +-- Stage 3 uses it for examples. Stage 4 uses it for the program that +-- has no translation with two-state tropes. +-- +-- newtype Age = MkAge Int +-- newtype Box a = MkBox (a, Int) -- inferred role: representational +-- newtype Tag a = MkTag Int -- inferred role: phantom +-- newtype T a = MkT (F a) -- inferred role: nominal +-- type family F a where { F Int = Bool ; F Age = Char ; F (Tag a) = G a } +-- type family G a where { G Int = Bool ; G Bool = Char } +-- +-- `taggedS d` is this signature with the declared role d for the +-- parameter of Box. Tag is declared phantom and T is declared nominal. +module Wager.FC.Tagged where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Role.Role +open import Wager.FC.Signature +open import Wager.FC.Classic using (BaseName; bInt; bBool; bChar; bUnit; LitName; ℓint; ℓbool; ℓchar; ℓunit; litTyC) public +open import Wager.Erased.Untyped using (ebase) +import Wager.FC.Types + +data Nt₀E : Type where + ageE : Nt₀E + +data Nt₁E : Type where + boxE tagE teeE : Nt₁E + +data FamE : Type where + fE gE : FamE + +private + bodyE : Nt₁E → Body BaseName FamE + bodyE boxE = bprod bvar (bbase bInt) + bodyE tagE = bbase bInt + bodyE teeE = bfam fE bvar + + roleE : Role → Nt₁E → Role + roleE d boxE = d + roleE d tagE = ph + roleE d teeE = nom + + fBaseE : FamE → BaseName → BaseName + fBaseE fE bInt = bBool + fBaseE gE bInt = bBool + fBaseE gE bBool = bChar + fBaseE _ _ = bUnit + + fNt₀E : FamE → Nt₀E → BaseName + fNt₀E fE ageE = bChar + fNt₀E gE ageE = bUnit + + -- F (Tag a) = G a: the function F looks at the argument of Tag. + fNt₁E : FamE → Nt₁E → BaseName ⊎ FamE + fNt₁E fE tagE = inr gE + fNt₁E _ _ = inl bUnit + +taggedS : Role → SSig +taggedS d = record + { Base = BaseName ; Lit = LitName ; litTy = litTyC + ; N₀ = Nt₀E ; rep₀ = λ _ → ebase bInt + ; N₁ = Nt₁E ; Fam = FamE + ; body = bodyE ; role = roleE d + ; fBase = fBaseE ; fNt₀ = fNt₀E ; fNt₁ = fNt₁E ; fOther = λ _ → bUnit } + +module TTypes (d : Role) where + open Wager.FC.Types (taggedS d) + + sInt sBool sChar sAge : STy + sInt = sbase bInt + sBool = sbase bBool + sChar = sbase bChar + sAge = nt₀ ageE + + Box Tag Tee F : STy → STy + Box = nt₁ boxE + Tag = nt₁ tagE + Tee = nt₁ teeE + F = fam fE diff --git a/verification/proofs/agda/Wager/FC/Term.agda b/verification/proofs/agda/Wager/FC/Term.agda new file mode 100644 index 0000000..f88fc30 --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Term.agda @@ -0,0 +1,77 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on typed terms. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Terms of the source calculus, their typing and their erasure +-- (Stage 3). +-- +-- A term is typed by construction: `STm Γ τ` is the set of the terms of +-- the type τ in the context Γ. The term `cast γ e` needs a coercion +-- `γ : Co rep τ σ`. A program that has no such coercion is not a term: +-- this is how the source calculus rejects a wrong `coerce`. +-- +-- Erasure maps a term to an untyped term. A cast vanishes. +open import Wager.FC.Signature + +module Wager.FC.Term (SS : SSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) + +open import Wager.Role.Role +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +open import Wager.Erased.Untyped +open Terms Lit public + +private + variable + n : ℕ + τ σ υ : STy + +-- A context: the (closed) type of each term variable. +SCx : ℕ → Type +SCx n = Fin n → STy + +infixl 5 _▹ˢ_ +_▹ˢ_ : SCx n → STy → SCx (suc n) +(Γ ▹ˢ τ) zero = τ +(Γ ▹ˢ τ) (suc i) = Γ i + +∅ˢ : SCx 0 +∅ˢ () + +data STm : SCx n → STy → Type where + svar : ∀ {Γ : SCx n} i → STm Γ (Γ i) + slam : ∀ {Γ : SCx n} → STm (Γ ▹ˢ τ) σ → STm Γ (τ ⇒ˢ σ) + sapp : ∀ {Γ : SCx n} → STm Γ (τ ⇒ˢ σ) → STm Γ τ → STm Γ σ + spair : ∀ {Γ : SCx n} → STm Γ τ → STm Γ σ → STm Γ (τ ×ˢ σ) + -- The body sees the first component at index 1 and the second at index 0. + sletp : ∀ {Γ : SCx n} → STm Γ (τ ×ˢ σ) → STm (Γ ▹ˢ τ ▹ˢ σ) υ → STm Γ υ + sinl : ∀ {Γ : SCx n} → STm Γ τ → STm Γ (τ +ˢ σ) + sinr : ∀ {Γ : SCx n} → STm Γ σ → STm Γ (τ +ˢ σ) + scase : ∀ {Γ : SCx n} → STm Γ (τ +ˢ σ) → STm (Γ ▹ˢ τ) υ → STm (Γ ▹ˢ σ) υ → STm Γ υ + slit : ∀ {Γ : SCx n} ℓ → STm Γ (sbase (litTy ℓ)) + -- A cast along a representational coercion. + cast : ∀ {Γ : SCx n} → Co rep τ σ → STm Γ τ → STm Γ σ + +-- `coerce`, at the two types of a representational coercion. +coerce : ∀ {Γ : SCx n} → Co rep τ σ → STm Γ (τ ⇒ˢ σ) +coerce γ = slam (cast γ (svar zero)) + +-- Erasure. The last clause is the point: a cast vanishes. +eraseTm : ∀ {Γ : SCx n} → STm Γ τ → UTm n +eraseTm (svar i) = uvar i +eraseTm (slam b) = ulam (eraseTm b) +eraseTm (sapp f a) = uapp (eraseTm f) (eraseTm a) +eraseTm (spair s t) = upair (eraseTm s) (eraseTm t) +eraseTm (sletp s b) = uletp (eraseTm s) (eraseTm b) +eraseTm (sinl t) = uinl (eraseTm t) +eraseTm (sinr t) = uinr (eraseTm t) +eraseTm (scase s l r) = ucase (eraseTm s) (eraseTm l) (eraseTm r) +eraseTm (slit ℓ) = ulit ℓ +eraseTm (cast γ e) = eraseTm e diff --git a/verification/proofs/agda/Wager/FC/Types.agda b/verification/proofs/agda/Wager/FC/Types.agda new file mode 100644 index 0000000..542f354 --- /dev/null +++ b/verification/proofs/agda/Wager/FC/Types.agda @@ -0,0 +1,121 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Source types (Stage 3), and two functions on them: +-- +-- ev the nominal value of a type. Each type-level function is +-- computed. A newtype stays, with the value of its argument. +-- er the erased type. Each newtype is replaced by its +-- representation. +-- +-- The two functions are total and structurally recursive. +open import Wager.FC.Signature + +module Wager.FC.Types (SS : SSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Erased.Untyped using (ETy; ebase; earr; eprod; esum) +open SSig SS public + +infixr 20 _⇒ˢ_ +infixr 30 _+ˢ_ +infixr 40 _×ˢ_ + +-- Closed source types. +data STy : Type where + sbase : Base → STy + _⇒ˢ_ : STy → STy → STy + _×ˢ_ : STy → STy → STy + _+ˢ_ : STy → STy → STy + nt₀ : N₀ → STy + nt₁ : N₁ → STy → STy + fam : Fam → STy → STy + +-- The body of a newtype, with a type for the parameter. +inst : Body Base Fam → STy → STy +inst bvar τ = τ +inst (bbase b) τ = sbase b +inst (barr β γ) τ = inst β τ ⇒ˢ inst γ τ +inst (bprod β γ) τ = inst β τ ×ˢ inst γ τ +inst (bsum β γ) τ = inst β τ +ˢ inst γ τ +inst (bfam F β) τ = fam F (inst β τ) + +-- An erased type is a source type. +embE : ETy Base → STy +embE (ebase b) = sbase b +embE (earr a b) = embE a ⇒ˢ embE b +embE (eprod a b) = embE a ×ˢ embE b +embE (esum a b) = embE a +ˢ embE b + +-- The right side of the equation `F (N τ) = ...`. +resS : Base ⊎ Fam → STy → STy +resS (inl b) τ = sbase b +resS (inr G) τ = fam G τ + +------------------------------------------------------------------------ +-- Nominal values. + +data VTy : Type where + vbase : Base → VTy + varr vprod vsum : VTy → VTy → VTy + vnt₀ : N₀ → VTy + vnt₁ : N₁ → VTy → VTy + +resB : Base ⊎ Fam → (Fam → Base) → Base +resB (inl b) f = b +resB (inr G) f = f G + +-- A type-level function on a value. The recursion is on the value. +applyF : Fam → VTy → Base +applyF F (vbase b) = fBase F b +applyF F (varr _ _) = fOther F +applyF F (vprod _ _) = fOther F +applyF F (vsum _ _) = fOther F +applyF F (vnt₀ N) = fNt₀ F N +applyF F (vnt₁ N v) = resB (fNt₁ F N) (λ G → applyF G v) + +ev : STy → VTy +ev (sbase b) = vbase b +ev (τ ⇒ˢ σ) = varr (ev τ) (ev σ) +ev (τ ×ˢ σ) = vprod (ev τ) (ev σ) +ev (τ +ˢ σ) = vsum (ev τ) (ev σ) +ev (nt₀ N) = vnt₀ N +ev (nt₁ N τ) = vnt₁ N (ev τ) +ev (fam F τ) = vbase (applyF F (ev τ)) + +-- The value of a body, from the value of the parameter. +evB : Body Base Fam → VTy → VTy +evB bvar v = v +evB (bbase b) v = vbase b +evB (barr β γ) v = varr (evB β v) (evB γ v) +evB (bprod β γ) v = vprod (evB β v) (evB γ v) +evB (bsum β γ) v = vsum (evB β v) (evB γ v) +evB (bfam F β) v = vbase (applyF F (evB β v)) + +------------------------------------------------------------------------ +-- Erased types. + +-- The erased type of a body, from the value `v` of the parameter and +-- the erased type `e` of the parameter. +erB : Body Base Fam → VTy → ETy Base → ETy Base +erB bvar v e = e +erB (bbase b) v e = ebase b +erB (barr β γ) v e = earr (erB β v e) (erB γ v e) +erB (bprod β γ) v e = eprod (erB β v e) (erB γ v e) +erB (bsum β γ) v e = esum (erB β v e) (erB γ v e) +erB (bfam F β) v e = ebase (applyF F (evB β v)) + +erV : VTy → ETy Base +erV (vbase b) = ebase b +erV (varr v w) = earr (erV v) (erV w) +erV (vprod v w) = eprod (erV v) (erV w) +erV (vsum v w) = esum (erV v) (erV w) +erV (vnt₀ N) = rep₀ N +erV (vnt₁ N v) = erB (body N) v (erV v) + +er : STy → ETy Base +er τ = erV (ev τ) diff --git a/verification/proofs/agda/Wager/Grade/Algebra.agda b/verification/proofs/agda/Wager/Grade/Algebra.agda index ab8abe5..683e36f 100644 --- a/verification/proofs/agda/Wager/Grade/Algebra.agda +++ b/verification/proofs/agda/Wager/Grade/Algebra.agda @@ -70,3 +70,35 @@ record GradeAlgebra (R : Type) : Type₁ where laws : GradeLaws ops open GradeOps ops public open GradeLaws laws public + +-- The laws without `mul-zero` (a · 𝟘 ≡ 𝟘). Stage 2 examines a +-- structure that has these 14 laws and fails `mul-zero`. +record GradeLawsExceptMulZero {R : Type} (ops : GradeOps R) : Type where + open GradeOps ops + field + add-assoc : ∀ a b c → (a + b) + c ≡ a + (b + c) + add-comm : ∀ a b → a + b ≡ b + a + add-zero : ∀ a → a + 𝟘 ≡ a + mul-assoc : ∀ a b c → (a · b) · c ≡ a · (b · c) + one-mul : ∀ a → 𝟙 · a ≡ a + mul-one : ∀ a → a · 𝟙 ≡ a + zero-mul : ∀ a → 𝟘 · a ≡ 𝟘 + left-distrib : ∀ a b c → a · (b + c) ≡ (a · b) + (a · c) + right-distrib : ∀ a b c → (a + b) · c ≡ (a · c) + (b · c) + le-refl : ∀ a → a ≤ a + le-trans : ∀ a b c → a ≤ b → b ≤ c → a ≤ c + le-antisym : ∀ a b → a ≤ b → b ≤ a → a ≡ b + add-mono : ∀ a b c d → a ≤ b → c ≤ d → (a + c) ≤ (b + d) + mul-mono : ∀ a b c d → a ≤ b → c ≤ d → (a · c) ≤ (b · d) + +-- The 14 laws and `mul-zero` together are exactly the 15 laws. +withMulZero : {R : Type} {ops : GradeOps R} → GradeLawsExceptMulZero ops → + (∀ a → GradeOps._·_ ops a (GradeOps.𝟘 ops) ≡ GradeOps.𝟘 ops) → GradeLaws ops +withMulZero L mz = record + { add-assoc = add-assoc ; add-comm = add-comm ; add-zero = add-zero + ; mul-assoc = mul-assoc ; one-mul = one-mul ; mul-one = mul-one + ; zero-mul = zero-mul ; mul-zero = mz + ; left-distrib = left-distrib ; right-distrib = right-distrib + ; le-refl = le-refl ; le-trans = le-trans ; le-antisym = le-antisym + ; add-mono = add-mono ; mul-mono = mul-mono } + where open GradeLawsExceptMulZero L diff --git a/verification/proofs/agda/Wager/Grade/Finite.agda b/verification/proofs/agda/Wager/Grade/Finite.agda index 9592c30..d93fe3a 100644 --- a/verification/proofs/agda/Wager/Grade/Finite.agda +++ b/verification/proofs/agda/Wager/Grade/Finite.agda @@ -191,3 +191,20 @@ module Check {A : Type} (F : Finite A) (B : BoolOps A) where ; left-distrib = left-distrib! h₉ ; right-distrib = right-distrib! h₁₀ ; le-refl = le-refl! h₁₁ ; le-trans = le-trans! h₁₂ ; le-antisym = le-antisym! h₁₃ ; add-mono = add-mono! h₁₄ ; mul-mono = mul-mono! h₁₅ } + + -- The 14 checks without `mul-zero?`. + mkLaws14 : + add-assoc? ≡ true → add-comm? ≡ true → add-zero? ≡ true → + mul-assoc? ≡ true → one-mul? ≡ true → mul-one? ≡ true → + zero-mul? ≡ true → + left-distrib? ≡ true → right-distrib? ≡ true → + le-refl? ≡ true → le-trans? ≡ true → le-antisym? ≡ true → + add-mono? ≡ true → mul-mono? ≡ true → + GradeLawsExceptMulZero (toOps B) + mkLaws14 h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₉ h₁₀ h₁₁ h₁₂ h₁₃ h₁₄ h₁₅ = record + { add-assoc = add-assoc! h₁ ; add-comm = add-comm! h₂ ; add-zero = add-zero! h₃ + ; mul-assoc = mul-assoc! h₄ ; one-mul = one-mul! h₅ ; mul-one = mul-one! h₆ + ; zero-mul = zero-mul! h₇ + ; left-distrib = left-distrib! h₉ ; right-distrib = right-distrib! h₁₀ + ; le-refl = le-refl! h₁₁ ; le-trans = le-trans! h₁₂ ; le-antisym = le-antisym! h₁₃ + ; add-mono = add-mono! h₁₄ ; mul-mono = mul-mono! h₁₅ } diff --git a/verification/proofs/agda/Wager/Grade/Trivial.agda b/verification/proofs/agda/Wager/Grade/Trivial.agda new file mode 100644 index 0000000..8be1d9b --- /dev/null +++ b/verification/proofs/agda/Wager/Grade/Trivial.agda @@ -0,0 +1,31 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The one-point grade algebra: no usage discipline. +-- In this algebra the grade 𝟙 is unrestricted (𝟘 ≤ 𝟙 and 𝟙 + 𝟙 ≤ 𝟙). +-- Stage 4 uses it for the translation of whole source programs, +-- because System FC has no usage discipline. +module Wager.Grade.Trivial where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Unit using (Unit; tt) + +open import Wager.Grade.Algebra + +trivialOps : GradeOps Unit +trivialOps = record + { _+_ = λ _ _ → tt ; _·_ = λ _ _ → tt ; 𝟘 = tt ; 𝟙 = tt ; _≤_ = λ _ _ → Unit } + +trivialLaws : GradeLaws trivialOps +trivialLaws = record + { add-assoc = λ _ _ _ → refl ; add-comm = λ _ _ → refl ; add-zero = λ _ → refl + ; mul-assoc = λ _ _ _ → refl ; one-mul = λ _ → refl ; mul-one = λ _ → refl + ; zero-mul = λ _ → refl ; mul-zero = λ _ → refl + ; left-distrib = λ _ _ _ → refl ; right-distrib = λ _ _ _ → refl + ; le-refl = λ _ → tt ; le-trans = λ _ _ _ _ _ → tt ; le-antisym = λ _ _ _ _ → refl + ; add-mono = λ _ _ _ _ _ _ → tt ; mul-mono = λ _ _ _ _ _ _ → tt } + +trivial : GradeAlgebra Unit +trivial = record { ops = trivialOps ; laws = trivialLaws } diff --git a/verification/proofs/agda/Wager/L1/KindingInversion.agda b/verification/proofs/agda/Wager/L1/KindingInversion.agda new file mode 100644 index 0000000..94d7f20 --- /dev/null +++ b/verification/proofs/agda/Wager/L1/KindingInversion.agda @@ -0,0 +1,81 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinding derivations. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Inversion of graded kinding through the subusage rule `k-sub`. +-- A proof that a type has NO kinding derivation at a grade uses these +-- lemmas. They need the order `≤` to be reflexive and transitive. +open import Cubical.Foundations.Prelude +open import Wager.L1.Signature +open import Wager.Grade.Algebra + +module Wager.L1.KindingInversion + (S : Sig) (K : GradeOps (Sig.KG S)) + (le-refl : ∀ a → GradeOps._≤_ K a a) + (le-trans : ∀ a b c → GradeOps._≤_ K a b → GradeOps._≤_ K b c → GradeOps._≤_ K a c) + where + +open import Cubical.Data.Sigma using (_×_; Σ-syntax) + +open import Wager.L1.Syntax S +open import Wager.L1.Kinding S K +open GradeOps K + +private + variable + Γ : Ctx + k j : Kind + g : KG + +≼ᵏ-refl : (γ : KUsage Γ) → γ ≼ᵏ γ +≼ᵏ-refl γ k x = le-refl (γ k x) + +≼ᵏ-trans : {γ δ ε : KUsage Γ} → γ ≼ᵏ δ → δ ≼ᵏ ε → γ ≼ᵏ ε +≼ᵏ-trans p q k x = le-trans _ _ _ (p k x) (q k x) + +inv-k-var : {γ : KUsage Γ} {x : Var Γ k} → γ ⊢ᵏ var x → unitᵏ x ≼ᵏ γ +inv-k-var (k-var x) = ≼ᵏ-refl _ +inv-k-var (k-sub d le) = ≼ᵏ-trans (inv-k-var d) le + +inv-k-base : ∀ {γ : KUsage Γ} {b} → γ ⊢ᵏ base b → 0ᵏ ≼ᵏ γ +inv-k-base (k-base b) = ≼ᵏ-refl _ +inv-k-base (k-sub d le) = ≼ᵏ-trans (inv-k-base d) le + +inv-k-capp : ∀ {γ : KUsage Γ} {c} {A : Ty Γ ★} → γ ⊢ᵏ capp c A → + Σ[ δ ∈ KUsage Γ ] (δ ⊢ᵏ A) × ((cgrade c ⊙ᵏ δ) ≼ᵏ γ) +inv-k-capp (k-capp c d) = _ , d , ≼ᵏ-refl _ +inv-k-capp (k-sub d le) = + let (δ , d' , le') = inv-k-capp d in δ , d' , ≼ᵏ-trans le' le + +inv-k-papp : ∀ {γ : KUsage Γ} {p} {A : Ty Γ ★} → γ ⊢ᵏ papp p A → + Σ[ δ ∈ KUsage Γ ] (δ ⊢ᵏ A) × ((pgrade p ⊙ᵏ δ) ≼ᵏ γ) +inv-k-papp (k-papp p d) = _ , d , ≼ᵏ-refl _ +inv-k-papp (k-sub d le) = + let (δ , d' , le') = inv-k-papp d in δ , d' , ≼ᵏ-trans le' le + +inv-k-lam : {γ : KUsage Γ} {b : Ty (k ∷ Γ) j} → γ ⊢ᵏ lam {g = g} b → + Σ[ γ' ∈ KUsage Γ ] ((γ' ▹ᵏ g) ⊢ᵏ b) × (γ' ≼ᵏ γ) +inv-k-lam (k-lam d) = _ , d , ≼ᵏ-refl _ +inv-k-lam (k-sub d le) = + let (γ' , d' , le') = inv-k-lam d in γ' , d' , ≼ᵏ-trans le' le + +inv-k-arr : ∀ {γ : KUsage Γ} {q} {A B : Ty Γ ★} → γ ⊢ᵏ arr q A B → + Σ[ δ ∈ KUsage Γ ] Σ[ ε ∈ KUsage Γ ] (δ ⊢ᵏ A) × (ε ⊢ᵏ B) × ((δ ⊕ᵏ ε) ≼ᵏ γ) +inv-k-arr (k-arr d e) = _ , _ , d , e , ≼ᵏ-refl _ +inv-k-arr (k-sub d le) = + let (δ , ε , d' , e' , le') = inv-k-arr d in δ , ε , d' , e' , ≼ᵏ-trans le' le + +inv-k-prod : ∀ {γ : KUsage Γ} {A B : Ty Γ ★} → γ ⊢ᵏ (A ⊗ B) → + Σ[ δ ∈ KUsage Γ ] Σ[ ε ∈ KUsage Γ ] (δ ⊢ᵏ A) × (ε ⊢ᵏ B) × ((δ ⊕ᵏ ε) ≼ᵏ γ) +inv-k-prod (k-prod d e) = _ , _ , d , e , ≼ᵏ-refl _ +inv-k-prod (k-sub d le) = + let (δ , ε , d' , e' , le') = inv-k-prod d in δ , ε , d' , e' , ≼ᵏ-trans le' le + +inv-k-sum : ∀ {γ : KUsage Γ} {A B : Ty Γ ★} → γ ⊢ᵏ (A ⊕ B) → + Σ[ δ ∈ KUsage Γ ] Σ[ ε ∈ KUsage Γ ] (δ ⊢ᵏ A) × (ε ⊢ᵏ B) × ((δ ⊕ᵏ ε) ≼ᵏ γ) +inv-k-sum (k-sum d e) = _ , _ , d , e , ≼ᵏ-refl _ +inv-k-sum (k-sub d le) = + let (δ , ε , d' , e' , le') = inv-k-sum d in δ , ε , d' , e' , ≼ᵏ-trans le' le diff --git a/verification/proofs/agda/Wager/L2/Inversion.agda b/verification/proofs/agda/Wager/L2/Inversion.agda index 400dbb8..4141c1f 100644 --- a/verification/proofs/agda/Wager/L2/Inversion.agda +++ b/verification/proofs/agda/Wager/L2/Inversion.agda @@ -54,3 +54,11 @@ inv-app (t-conv d e) = inv-app (t-sub d le) = let (q , A , B , γ₁ , γ₂ , c , le' , d₁ , d₂) = inv-app d in q , A , B , γ₁ , γ₂ , c , ≤ᵘ-trans le' le , d₁ , d₂ + +inv-step : {γ : Usage n} {Γ : Cx n} {o : Op} {t : Tm n} {C : Ty [] ★} → + γ ▸ Γ ⊢ step o t ∶ C → + Σ[ γ' ∈ Usage n ] + DefEq (carrier o at to o) C × (γ' ≤ᵘ γ) × (γ' ▸ Γ ⊢ t ∶ carrier o at from o) +inv-step (t-step o d) = _ , d-refl , ≤ᵘ-refl _ , d +inv-step (t-conv d e) = let (γ' , c , le , d') = inv-step d in γ' , d-trans c e , le , d' +inv-step (t-sub d le) = let (γ' , c , le' , d') = inv-step d in γ' , c , ≤ᵘ-trans le' le , d' diff --git a/verification/proofs/agda/Wager/PLAN.adoc b/verification/proofs/agda/Wager/PLAN.adoc index f5c657e..5835f7d 100644 --- a/verification/proofs/agda/Wager/PLAN.adoc +++ b/verification/proofs/agda/Wager/PLAN.adoc @@ -1,7 +1,7 @@ // SPDX-License-Identifier: CC-BY-SA-4.0 // SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) = Wager: plan -Status: Stage 0 deliverable. It is a proposal. It waits for the owner. +Status: Stage 0 deliverable. The owner accepted it on 2026-11-10. Stages 0 to 2 are complete. :sectnums: == Goal @@ -13,7 +13,7 @@ A proof is a success. A checked counterexample is a success. A vague result is a . Agda 2.8.0 and cubical v0.9 are installed and recorded in `TOOLCHAIN.adoc`. The gate failed on a false lemma, a `postulate` and a hole, and passes on the restored file. . The stock cubical v0.9 library forces `--guardedness` on each importer (DC-0.2). This conflicts with a task rule. -. `scripts/check-proof-status.sh` is red on this branch, because the task forbids the marker line in `PROOF-STATUS.adoc`. +. `scripts/check-proof-status.sh` was red at Stage 0, because the task did not allow the marker line in `PROOF-STATUS.adoc`. This is resolved since 2026-11-10 (`VERDICT.adoc`, F5). . The systemet `Affine` order (`0 ≤ ω`, `1 ≤ ω`, and `0`, `1` not comparable) differs from the anytype order (`0 ≤ 1 ≤ ω`). Stage 1 uses the systemet order. . The documents leave the L2 rule table open (doc 03) and say that a trope has a finite state set (doc 07). Both facts matter in stages 1 and 4. diff --git a/verification/proofs/agda/Wager/Proofs.agda b/verification/proofs/agda/Wager/Proofs.agda index 13d24c6..3d8bceb 100644 --- a/verification/proofs/agda/Wager/Proofs.agda +++ b/verification/proofs/agda/Wager/Proofs.agda @@ -50,3 +50,198 @@ module _ (S : Sig) (TS : Wager.L2.Signature.TSig S) (R : GradeAlgebra (Sig.TG S) -- Progress uses the operations only, and no law. t0-progress : T0-Progress t0-progress = Wager.L2.Progress.progress S TS (GradeAlgebra.ops R) + +------------------------------------------------------------------------ +-- STAGE 2 +------------------------------------------------------------------------ + +open import Cubical.Data.Sigma using (_,_) +open import Wager.Role.Role +open import Wager.Role.Role4 using (role4Laws; role4-ghc-rule) +open import Wager.Role.Table +open import Wager.Role.Signature +import Wager.Role.Noninterference +import Wager.Role.Lawful +import Wager.Role.ClassicProofs as CP +open import Wager.FC.Signature +import Wager.FC.RoleSoundness +import Wager.FC.Erasure +import Wager.FC.ClassicProofs +import Wager.Trans.Scheme +import Wager.Trans.Typing +import Wager.Trans.Simulation +import Wager.Trans.RoleCorrespondence +import Wager.Trans.TwoStateProofs + +module _ where + open T1-Statements + + t1-lawful : T1-Lawful + t1-lawful = roleZLaws + + t1-ghc-other-laws : T1-GHC-Other-Laws + t1-ghc-other-laws = roleGLaws14 + + t1-ghc-mul-zero-fails : T1-GHC-MulZero-Fails + t1-ghc-mul-zero-fails = roleG-mul-zero-fails + + t1-ghc-fails-at-nominal-only : T1-GHC-Fails-At-Nominal-Only + t1-ghc-fails-at-nominal-only = + roleG-mul-zero-ph , roleG-mul-zero-rep , roleG-mul-zero-nom + +module _ (RS : RoleSig) (T : RoleTable) where + open Noninterference-Statements RS T + + noninterference : Noninterference + noninterference = Wager.Role.Noninterference.noninterference RS T + +module _ (RS : RoleSig) where + open T2-Statements RS + + t2-representational : T2-Representational + t2-representational = Wager.Role.Lawful.t2-representational RS + + t2-phantom : T2-Phantom + t2-phantom = Wager.Role.Lawful.t2-phantom RS + +module _ where + open T4-Statements + + t4-kinding-rejects : T4-Kinding-Rejects + t4-kinding-rejects = CP.T4.t4-kinding-rejects + + t4-not-equivalent : T4-Not-Equivalent + t4-not-equivalent = CP.T4.t4-not-equivalent-1 , CP.T4.t4-not-equivalent-2 + +module _ where + open Proxy-Statements + + lawful-unsound-with-phantom-constant : A.Lawful-Unsound-With-Phantom-Constant + lawful-unsound-with-phantom-constant = + (CP.LawfulKinding.ε ph , CP.ProxyA.deepF-phantom) , CP.Generic.deepF-separates ph ph + + t2-phantom-fails-without-valid : A.T2-Phantom-Fails-Without-Valid + t2-phantom-fails-without-valid = + (CP.LawfulKinding.ε ph , CP.ProxyA.proxyF-phantom) , CP.Generic.proxyF-separates ph ph + + phantom-constant-not-valid : A.Phantom-Constant-Not-Valid + phantom-constant-not-valid = CP.ProxyA.not-valid + + rep-constant-valid : B.Rep-Constant-Valid + rep-constant-valid = CP.ProxyB.valid + + no-phantom-coercion : B.No-Phantom-Coercion + no-phantom-coercion = CP.ProxyB.no-phantom-coercion + + ghc-rejects-deep : C.GHC-Rejects-Deep + ghc-rejects-deep = CP.ProxyC.ghc-rejects-deep + + ghc-rejects-unused-parameter : C.GHC-Rejects-Unused-Parameter + ghc-rejects-unused-parameter = + (CP.LawfulKinding.ε ph , CP.LawfulKinding.constF-phantom ph) , CP.ProxyC.ghc-rejects-unused + +module _ where + open Role4-Statements + + role4-lawful : Role4-Lawful + role4-lawful = role4Laws + + role4-has-ghc-rule : Role4-Has-GHC-Rule + role4-has-ghc-rule = role4-ghc-rule + +------------------------------------------------------------------------ +-- STAGE 3 +------------------------------------------------------------------------ + +module _ (SS : SSig) where + open Source-Statements SS + private + module RS = Wager.FC.RoleSoundness SS + module ER = Wager.FC.Erasure SS + + source-nominal-soundness : Source-Nominal-Soundness + source-nominal-soundness τ σ = RS.nom-sound + + source-role-soundness : Source-Role-Soundness + source-role-soundness wr τ σ = RS.rep-sound wr + + cast-vanishes : Cast-Vanishes + cast-vanishes γ e = refl + + coerce-erases-to-identity : Coerce-Erases-To-Identity + coerce-erases-to-identity γ = refl + + erasure-preserves-typing : Erasure-Preserves-Typing + erasure-preserves-typing wr = ER.erase-typing wr + +module _ where + open Classic-Source-Statements + private module SP = Wager.FC.ClassicProofs + + classic-rejected : Classic-Rejected + classic-rejected = SP.classic-rejected + + classic-bad-coercion : Bad.Classic-Bad-Coercion + classic-bad-coercion = SP.Bad.tAge~tInt + + classic-unsound-if-accepted : Bad.Classic-Unsound-If-Accepted + classic-unsound-if-accepted = + SP.Bad.exploit , SP.Bad.exploit-erased , SP.Bad.exploit-value , SP.Bad.exploit-untyped + + classic-nominal-accepted : Good.Classic-Nominal-Accepted + classic-nominal-accepted = SP.Good.accepted + + classic-nominal-no-coercion : Good.Classic-Nominal-No-Coercion + classic-nominal-no-coercion = SP.Good.age~int , SP.Good.no-coercion + +------------------------------------------------------------------------ +-- STAGE 4 +------------------------------------------------------------------------ + +module _ (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (A : GradeAlgebra R) where + open Translation-Statements SS Sc A + private + module TY = Wager.Trans.Typing SS Sc A + module SI = Wager.Trans.Simulation SS Sc (GradeAlgebra.ops A) + module RC = Wager.Trans.RoleCorrespondence SS Sc (GradeAlgebra.ops A) + + coercion-is-a-term : Coercion-Is-A-Term + coercion-is-a-term wr γ Γ = TY.coerce-typed wr γ Γ + + t3 : T3 + t3 wr γ = SI.coerce-identity wr γ + + t3-first-order : T3-First-Order + t3-first-order wr γ = SI.coerce-identity-fo wr γ + + t5-typing : T5-Typing + t5-typing wr u0 u2 e = TY.tr-typed wr u0 u2 e + + t5-behaviour : T5-Behaviour + t5-behaviour wr e = SI.behaviour wr e + + t5-behaviour-first-order : T5-Behaviour-First-Order + t5-behaviour-first-order wr e = SI.behaviour-fo wr e + + target-signature-valid : Target-Signature-Valid + target-signature-valid = RC.target-valid + + role-correspondence : Role-Correspondence + role-correspondence = RC.role-correspondence + + role-check-is-kinding : Role-Check-Is-Kinding + role-check-is-kinding = RC.role-check-is-kinding + +module _ where + open Two-State-Statements + private module TS = Wager.Trans.TwoStateProofs + + row-translation-exists : ∀ SS {R} (ops : GradeOps R) → Row-Translation-Exists SS ops + row-translation-exists SS ops = TS.row-translation SS ops + + two-state-translation-exists : ∀ SS {R} (ops : GradeOps R) → Two-State-Translation-Exists SS ops + two-state-translation-exists SS ops = TS.two-state-translation SS ops + + no-two-state-translation : No-Two-State-Translation + no-two-state-translation = TS.no-two-state diff --git a/verification/proofs/agda/Wager/RELATION-LEDGER.adoc b/verification/proofs/agda/Wager/RELATION-LEDGER.adoc index 3c8c065..28fcb46 100644 --- a/verification/proofs/agda/Wager/RELATION-LEDGER.adoc +++ b/verification/proofs/agda/Wager/RELATION-LEDGER.adoc @@ -1,7 +1,7 @@ // SPDX-License-Identifier: CC-BY-SA-4.0 // SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) = Wager: relation ledger -Status: Stage 1. Each later stage adds its entries in the same commit as its rules. +Status: Stage 4. Each later stage adds its entries in the same commit as its rules. :toc: left :sectnums: @@ -18,10 +18,11 @@ Each entry has one class: | specification only | The relation is used in theorem statements. No typing or kinding rule uses it. | proof-internal | The relation is used in proofs only. No rule and no statement uses it. | ADDED | The relation is not in 00-notation, and a typing or kinding rule uses it. +| source | The relation belongs to the source calculus (the fragment of System FC). The target calculus does not have it. It does not count against the wager. |=== -An ADDED entry counts against the wager. *Stage 1 has no ADDED entry.* -Stage 1 has one "baseline, changed" entry (R1). The owner decides how it counts. +An ADDED entry counts against the wager. *Stages 1, 2, 3 and 4 have no ADDED entry.* +The ledger has one "baseline, changed" entry (R1). The owner decides how it counts. == Judgement forms of the target calculus @@ -97,10 +98,87 @@ Stage 1 has one "baseline, changed" entry (R1). The owner decides how it counts. | `SubTyping` in `Wager.L2.Substitution` | proof-internal | Typing of a parallel substitution with a usage matrix. It is a family of R4 judgements. + +| R11 +| `_≈_` in `Wager.Role.RepEq` (Stage 2) +| specification only +| Representational equivalence on closed normal types: the least congruence that contains newtype unfolding. + The statements of T2 and T4 use it. No typing rule and no kinding rule uses it. + +| R12 +| `R★` and `Valid` in `Wager.Role.Validity` (Stage 2) +| specification only +| `R★ ρ` is what an observer of the role ρ can tell apart: nothing (phantom), types up to `≈` (representational), types up to identity (nominal). + `Valid` says that each constant and each primitive of a signature respects its declared grade. + The statements of noninterference and of T2 use them. No rule uses them. + +| R13 +| `LR`, `EnvLR` in `Wager.Role.Noninterference` (Stage 2) +| proof-internal +| The logical relation on closed values, indexed by the role of the observer. |=== +== Relations of the source calculus and of the erased calculus (Stage 3) + +Stage 3 defines the source calculus. It adds no rule and no relation to the target calculus. + +[cols="1,3,2,5",options="header"] +|=== +| Id | Agda identifier | Class | Notes + +| R14 +| `Co` in `Wager.FC.Coercion` +| source +| The coercion relation of System FC, at the three roles. `cast` and `coerce` use it at the role representational. + The wager says that the target calculus does not need this relation. The target calculus does not have it. + +| R15 +| `STm` in `Wager.FC.Term`, `WellRoled` in `Wager.FC.Signature` +| source +| Typing of source terms (by construction), and the role check of a source signature. + +| R16 +| `_⊢_⇓_` and `_⊢ᵉ_∶_` in `Wager.Erased.Untyped` +| specification only +| Big-step evaluation of untyped terms, and typing of untyped terms with erased types. + The statements of Stage 3 use them. No typing rule and no kinding rule of the target calculus uses them. + +| R17 +| `RelV` in `Wager.FC.RoleSoundness` +| proof-internal +| What a coercion at each role must keep: the nominal value (nominal), the erased type (representational), nothing (phantom). +|=== + +== Relations of the translation (Stage 4) + +Stage 4 defines the translation. It adds no rule and no relation to the target calculus. +The translated terms use the rules of Stage 1 only: the rule `t-step` types each trope transition, and the rule `t-conv` types the translation of a nominal coercion. + +[cols="1,3,2,5",options="header"] +|=== +| Id | Agda identifier | Class | Notes + +| R18 +| `𝒱`, `𝒞`, `ℰ` and `FO` in `Wager.Erased.LogRel` +| specification only +| Observational equality of untyped values at an erased type (a logical relation), and the first-order types. + The statements of T3 and of T5 use them. No typing rule and no kinding rule uses them. + +| R19 +| `Translation` and `TwoState` in `Wager.Trans.TwoState` +| specification only +| What a translation of types must keep, and the two-state form. The statement `No-Two-State-Translation` uses them. + +| R20 +| `TyTr`, `IsoTyped` in `Wager.Trans.Typing`; `CoRel`, `CoRelIso` in `Wager.Trans.Simulation` +| proof-internal +| A term transformer keeps typing, and a term transformer keeps the erased behaviour. +|=== + +`StateScheme` (`Wager.Trans.Scheme`) is data of the translation: an index type and a table. It is not a relation. + == What is absent -* There is no coercion relation and no cast judgement. -* There is no representational equality. Stage 2 adds one as "specification only". +* The target calculus has no coercion relation and no cast judgement. The coercion relation `Co` (R14) is in the source calculus only. The translation of Stage 4 makes each representational coercion a term of the target, with no new judgement. +* Representational equivalence exists as "specification only" (R11). It is not a judgement of the calculus. * There is no subtyping relation between types. diff --git a/verification/proofs/agda/Wager/RULE-DIFF-LEDGER.adoc b/verification/proofs/agda/Wager/RULE-DIFF-LEDGER.adoc index 94113a3..1c6e8f1 100644 --- a/verification/proofs/agda/Wager/RULE-DIFF-LEDGER.adoc +++ b/verification/proofs/agda/Wager/RULE-DIFF-LEDGER.adoc @@ -1,7 +1,7 @@ // SPDX-License-Identifier: CC-BY-SA-4.0 // SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) = Wager: rule-diff ledger -Status: Stage 1. *The ledger is empty.* +Status: Stage 4. *The ledger is empty.* :toc: left :sectnums: @@ -54,3 +54,30 @@ The evidence is structural, and Agda checks it. They are data of the signature, not of a rule. A later stage chooses these entries for a specific algebra. If a theorem then needs a condition on the entries, `VERDICT.adoc` records the condition with the class "signature primitive". + +== Stage 2 + +Stage 2 adds no typing rule and no kinding rule. The kinding judgement of Stage 1 is used with the role tables as it is. + +The signature of Stage 2 (`Wager.Role.Classic`) has entries that name grades: each primitive has the grade `nom`, the newtype state `age` has the grade `rep`. +These are signature entries, not rules. + +T2 needs a condition on the entries: the predicate `Valid` of `Wager.Role.Validity`. +`VERDICT.adoc` records this condition with the class "signature primitive". +It is not an entry of this ledger, because no rule has a side condition. + +== Stage 3 + +Stage 3 adds no typing rule and no kinding rule to the target calculus. + +The source rule `c-nt₁` (`Wager.FC.Coercion`) names the GHC composition table `mulG`. +It is a rule of the source calculus, the fragment of System FC. It is not a rule of the target calculus, so it is not an entry of this ledger. + +== Stage 4 + +Stage 4 adds no typing rule and no kinding rule to the target calculus. The translation gives terms that the rules of Stage 1 type. + +The translation names the grade `𝟙` only: a function type becomes `arr 𝟙`, and each binder of a translated term has the grade `𝟙`. + +Theorem T5 (typing of a translated program) has two hypotheses on the grade algebra: `𝟘 ≤ 𝟙` and `𝟙 + 𝟙 ≤ 𝟙`. +They name the grades `𝟘` and `𝟙` only. They are hypotheses of a theorem and not side conditions of a rule, so they are not entries of this ledger. `VERDICT.adoc` records them at T5. diff --git a/verification/proofs/agda/Wager/Role/Classic.agda b/verification/proofs/agda/Wager/Role/Classic.agda new file mode 100644 index 0000000..750eb4d --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Classic.agda @@ -0,0 +1,112 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The concrete signature of Stage 2 (definitions only). +-- +-- base types Int, Bool, Char, Unit +-- newtype state age: Int@age is the newtype `Age` over Int, +-- Int@raw is the bare type Int +-- constant proxy: a generative constant, `Proxy A`. +-- Its parameter grade `pg` is a parameter of +-- the signature, so that Stage 2 can test it +-- primitives isAge: tells the newtype from its representation +-- a base type ↦ Bool, A@age ↦ Char, +-- Proxy A ↦ Bool, other ↦ Unit +-- deep: on `Proxy A` it inspects A with isAge, +-- on each other type it gives Unit +-- each primitive has the declared grade `nominal` +-- tropes wrapAge: Int@raw → Int@age, unwrapAge: Int@age → Int@raw +module Wager.Role.Classic where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Nat.Base using (ℕ) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Grade.Affine using (Affine) +open import Wager.Role.Role +open import Wager.Role.Signature +import Wager.L1.Syntax +import Wager.L2.Signature + +data BaseName : Type where + bInt bBool bChar bUnit : BaseName + +data ConName : Type where + age proxy : ConName + +data PrimName : Type where + isAge deep : PrimName + +data OpName : Type where + wrapAge unwrapAge : OpName + +private + cgradeC : Role → ConName → Role + cgradeC pg age = rep + cgradeC pg proxy = pg + + isNewtypeC : ConName → Bool + isNewtypeC age = true + isNewtypeC proxy = false + + onBaseC : PrimName → BaseName → BaseName + onBaseC isAge _ = bBool + onBaseC deep _ = bUnit + + onConC : PrimName → ConName → BaseName ⊎ PrimName + onConC isAge age = inl bChar + onConC isAge proxy = inl bBool + onConC deep age = inl bUnit + onConC deep proxy = inr isAge + +-- `pg` is the declared grade of the parameter of `proxy`. +classicSig : Role → RoleSig +classicSig pg = record + { TG = Affine ; Base = BaseName + ; Con₁ = ConName ; cgrade = cgradeC pg ; isNewtype = isNewtypeC + ; Prim = PrimName ; pgrade = λ _ → nom + ; onBase = onBaseC ; onCon = onConC ; onOther = λ _ → bUnit } + +module Types (pg : Role) where + open Wager.L1.Syntax (toSig (classicSig pg)) + open Wager.L2.Signature (toSig (classicSig pg)) + + private + variable + Γ : Ctx + + Int Bool' Age : Ty Γ ★ + Int = base bInt + Bool' = base bBool + Age = capp age Int -- Int@age + + Proxy : Ty Γ ★ → Ty Γ ★ + Proxy A = capp proxy A + + -- The classic type-level function: it maps the newtype and its + -- representation to different types (Age ↦ Char, Int ↦ Bool). + classicF : (g : Role) → Ty [] (★ ⇒[ g ] ★) + classicF g = lam (papp isAge (var vz)) + + -- λa. Proxy a + proxyF : (g : Role) → Ty [] (★ ⇒[ g ] ★) + proxyF g = lam (Proxy (var vz)) + + -- λa. deep (Proxy a): an inspection below the generative constant. + deepF : (g : Role) → Ty [] (★ ⇒[ g ] ★) + deepF g = lam (papp deep (Proxy (var vz))) + + -- λa. isAge Int: the parameter does not occur in the body. + constF : (g : Role) → Ty [] (★ ⇒[ g ] ★) + constF g = lam (papp isAge Int) + + -- The newtype `Age` as a two-state trope on Int. + classicTSig : TSig + classicTSig = record + { Lit = ℕ ; litTy = λ _ → bInt + ; Op = OpName ; carrier = λ _ → base bInt + ; from = λ { wrapAge → nothing ; unwrapAge → just age } + ; to = λ { wrapAge → just age ; unwrapAge → nothing } } diff --git a/verification/proofs/agda/Wager/Role/ClassicProofs.agda b/verification/proofs/agda/Wager/Role/ClassicProofs.agda new file mode 100644 index 0000000..7669663 --- /dev/null +++ b/verification/proofs/agda/Wager/Role/ClassicProofs.agda @@ -0,0 +1,236 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinded syntax. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- T4 (the classic unsound program at the type level) and the Proxy +-- test of Stage 2, for the concrete signature of Wager.Role.Classic. +module Wager.Role.ClassicProofs where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_; Σ-syntax) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Grade.Finite using (false≢true) +open import Wager.Role.Role +open import Wager.Role.Table +open import Wager.Role.Signature +open import Wager.Role.Classic +import Wager.L1.Syntax +import Wager.L1.Normal +import Wager.L1.Eval +import Wager.L1.Kinding +import Wager.L1.KindingInversion +import Wager.Role.RepEq +import Wager.Role.Validity +import Wager.Role.Lawful + +private + -- Facts about the role order, by computation. + ph-not-above-rep : ∀ x → leR rep x ≡ true → leR (mulZ nom x) ph ≡ true → ⊥ + ph-not-above-rep ph p q = false≢true p + ph-not-above-rep rep p q = false≢true q + ph-not-above-rep nom p q = false≢true q + + rep-not-above-nom : ∀ x → leR rep x ≡ true → leR (mulZ nom x) rep ≡ true → ⊥ + rep-not-above-nom ph p q = false≢true p + rep-not-above-nom rep p q = false≢true q + rep-not-above-nom nom p q = false≢true q + + nom-below : ∀ g → leR g rep ≡ true → leR nom g ≡ true → ⊥ + nom-below ph p q = false≢true q + nom-below rep p q = false≢true q + nom-below nom p q = false≢true p + + IsRep : Role → Type + IsRep rep = Unit + IsRep _ = ⊥ + + rep≢ph : ¬ (rep ≡ ph) + rep≢ph p = subst IsRep p tt + +-- Lemmas that hold for each declared grade `pg` of `proxy`. +module Generic (pg : Role) where + private S = toSig (classicSig pg) + open Wager.L1.Syntax S + open Wager.L1.Normal S + open Wager.L1.Eval S + open Wager.Role.RepEq (classicSig pg) + open Types pg + + -- Discrimination of closed normal types. + IsCharNf : Nf [] ★ → Type + IsCharNf (nbase bChar) = Unit + IsCharNf _ = ⊥ + + IsIntArg : Nf [] ★ → Type + IsIntArg (ncapp _ (nbase bInt)) = Unit + IsIntArg _ = ⊥ + + char≉bool : ¬ (nbase bChar ≈ nbase bBool) + char≉bool e = subst IsCharNf (≈→strip e) tt + + -- The newtype and its representation are equivalent. + age≈int : nf {Γ = []} Age ≈ nf Int + age≈int = ≈-unfold age refl + + -- `classicF` maps Age to Char and Int to Bool. + classicF-age : ∀ g → nf (app (classicF g) Age) ≡ nbase bChar + classicF-age g = refl + + classicF-int : ∀ g → nf (app (classicF g) Int) ≡ nbase bBool + classicF-int g = refl + + classicF-separates : ∀ g → ¬ (nf (app (classicF g) Age) ≈ nf (app (classicF g) Int)) + classicF-separates g = char≉bool + + -- `deepF` looks below Proxy: it also maps Age to Char and Int to Bool. + deepF-separates : ∀ g → ¬ (nf (app (deepF g) Age) ≈ nf (app (deepF g) Int)) + deepF-separates g = char≉bool + + proxyF-separates : ∀ g → ¬ (nf (app (proxyF g) Int) ≡ nf (app (proxyF g) Bool')) + proxyF-separates g p = subst IsIntArg p tt + +-- Kinding with the lawful table. +module LawfulKinding (pg : Role) where + private S = toSig (classicSig pg) + open Wager.L1.Syntax S + open Wager.L1.Kinding S (tableOps tableZ) public + open Wager.L1.KindingInversion S (tableOps tableZ) leR-refl leR-trans public + open Types pg + + ε : KUsage [] + ε k () + + -- T4: no derivation for `classicF` at a grade below representational. + classicF-rejected : (g : Role) → leR g rep ≡ true → (γ : KUsage []) → ¬ (γ ⊢ᵏ classicF g) + classicF-rejected g le γ d = + let (γ' , d₁ , _) = inv-k-lam d + (δ , d₂ , le₂) = inv-k-papp d₁ + le₃ = inv-k-var d₂ + in reject g le (δ ★ vz) (le₃ ★ vz) (le₂ ★ vz) + where + reject : ∀ g → leR g rep ≡ true → ∀ x → leR rep x ≡ true → leR (mulZ nom x) g ≡ true → ⊥ + reject ph _ x p q = ph-not-above-rep x p q + reject rep _ x p q = rep-not-above-nom x p q + reject nom l x p q = false≢true l + + -- `classicF` at the grade nominal has a derivation. + classicF-nominal : ε ⊢ᵏ classicF nom + classicF-nominal = k-lam (k-sub (k-papp isAge (k-var vz)) le) + where + le : (nom ⊙ᵏ unitᵏ vz) ≼ᵏ (ε ▹ᵏ nom) + le k vz = refl + + -- `constF = λa. isAge Int` at the grade phantom has a derivation. + constF-phantom : ε ⊢ᵏ constF ph + constF-phantom = k-lam (k-sub (k-papp isAge (k-base bInt)) le) + where + le : (nom ⊙ᵏ 0ᵏ) ≼ᵏ (ε ▹ᵏ ph) + le k vz = refl + +------------------------------------------------------------------------ +-- T4. The signature is `classicSig rep`. + +module T4 where + open Wager.L1.Syntax (toSig (classicSig rep)) using ([]) + open Generic rep + open LawfulKinding rep + + t4-kinding-rejects : (g : Role) → leR g rep ≡ true → (γ : KUsage []) → + ¬ (γ ⊢ᵏ Types.classicF rep g) + t4-kinding-rejects = classicF-rejected + + t4-not-equivalent-1 = age≈int + t4-not-equivalent-2 = classicF-separates + +------------------------------------------------------------------------ +-- The Proxy test, part A: lawful table, `proxy` declared phantom. + +module ProxyA where + private S = toSig (classicSig ph) + open Wager.L1.Syntax S + open Wager.L1.Normal S + open Wager.L1.Eval S + open Generic ph + open LawfulKinding ph + open Types ph + open Wager.Role.Validity (classicSig ph) mulZ + + -- Kinding accepts the grade phantom for `deepF`: + -- nominal · (phantom · representational) = phantom. + deepF-phantom : ε ⊢ᵏ deepF ph + deepF-phantom = k-lam (k-sub (k-papp deep (k-capp proxy (k-var vz))) le) + where + le : (nom ⊙ᵏ (ph ⊙ᵏ unitᵏ vz)) ≼ᵏ (ε ▹ᵏ ph) + le k vz = refl + + proxyF-phantom : ε ⊢ᵏ proxyF ph + proxyF-phantom = k-lam (k-sub (k-capp proxy (k-var vz)) le) + where + le : (ph ⊙ᵏ unitᵏ vz) ≼ᵏ (ε ▹ᵏ ph) + le k vz = refl + + -- The signature does not respect its declared grades: a nominal + -- observer tells `Proxy Int` from `Proxy Bool`. + not-valid : ¬ Valid + not-valid V = + proxyF-separates ph (Valid.cvalid V proxy nom {v = nbase bInt} {w = nbase bBool} tt) + +------------------------------------------------------------------------ +-- The Proxy test, part B: lawful table, `proxy` declared representational. + +module ProxyB where + private S = toSig (classicSig rep) + open Wager.L1.Syntax S + open Wager.L1.Normal S + open Wager.L1.Eval S + open Types rep + open Wager.Role.RepEq (classicSig rep) + open Wager.Role.Validity (classicSig rep) mulZ + open Wager.Role.Lawful (classicSig rep) using (valid-lawful) + + valid : Valid + valid = valid-lawful (λ { age → rep≢ph ; proxy → rep≢ph }) (λ p → refl) + + private + IsProxyInt : Nf [] ★ → Type + IsProxyInt (ncapp proxy (nbase bInt)) = Unit + IsProxyInt _ = ⊥ + + -- `Proxy Int` and `Proxy Bool` are not equivalent. + no-phantom-coercion : ¬ (nf {Γ = []} (Proxy Int) ≈ nf (Proxy Bool')) + no-phantom-coercion e = subst IsProxyInt (≈→strip e) tt + +------------------------------------------------------------------------ +-- The Proxy test, part C: GHC table, `proxy` declared phantom. + +module ProxyC where + private S = toSig (classicSig ph) + open Wager.L1.Syntax S + open Types ph + private + module KG where + open Wager.L1.Kinding S (tableOps tableG) public + open Wager.L1.KindingInversion S (tableOps tableG) leR-refl leR-trans public + + -- The GHC table rejects each grade below nominal for `deepF`. + ghc-rejects-deep : (g : Role) → leR g rep ≡ true → (γ : KG.KUsage []) → + ¬ (γ KG.⊢ᵏ deepF g) + ghc-rejects-deep g le γ d = + let (γ' , d₁ , _) = KG.inv-k-lam d + (δ , d₂ , le₂) = KG.inv-k-papp d₁ + in nom-below g le (le₂ ★ vz) + + -- The GHC table rejects the grade phantom for `constF`, which does + -- not use its parameter: nominal · phantom = nominal. + ghc-rejects-unused : (γ : KG.KUsage []) → ¬ (γ KG.⊢ᵏ constF ph) + ghc-rejects-unused γ d = + let (γ' , d₁ , _) = KG.inv-k-lam d + (δ , d₂ , le₂) = KG.inv-k-papp d₁ + in false≢true (le₂ ★ vz) diff --git a/verification/proofs/agda/Wager/Role/Lawful.agda b/verification/proofs/agda/Wager/Role/Lawful.agda new file mode 100644 index 0000000..4b0eb0b --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Lawful.agda @@ -0,0 +1,75 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- T2 with the lawful table, and a sufficient condition for a +-- signature to respect its declared grades. +open import Wager.Role.Signature + +module Wager.Role.Lawful (RS : RoleSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Role.Role +open import Wager.Role.Table +open import Wager.L1.Syntax (toSig RS) +open import Wager.L1.Normal (toSig RS) +open import Wager.L1.Eval (toSig RS) +open import Wager.L1.Kinding (toSig RS) (tableOps tableZ) +open import Wager.Role.RepEq RS +open import Wager.Role.Validity RS mulZ +open import Wager.Role.Noninterference RS tableZ + +-- T2, first part: a grade below representational respects `≈`. +t2-representational : + Valid → + ∀ {r : Role} (F : Ty [] (★ ⇒[ r ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + leR r rep ≡ true → + (A B : Ty [] ★) → nf A ≈ nf B → nf (app F A) ≈ nf (app F B) +t2-representational V {r} F d le A B h = + noninterference V F d rep A B (R★-anti r rep le h) + +-- T2, second part: the grade phantom gives equal normal forms. The +-- proof uses the entry nominal · phantom = phantom of the lawful table. +t2-phantom : + Valid → + (F : Ty [] (★ ⇒[ ph ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + (A B : Ty [] ★) → nf (app F A) ≡ nf (app F B) +t2-phantom V F d A B = noninterference V F d nom A B tt + +------------------------------------------------------------------------ +-- A sufficient condition for `Valid`, with the lawful table: +-- no constant has the parameter grade phantom, and each primitive has +-- the parameter grade nominal. + +private + capp-R★ : ∀ ρ c {v w : CNf} → R★ ρ v w → R★ ρ (ncapp c v) (ncapp c w) + capp-R★ ph c h = tt + capp-R★ rep c h = ≈-capp c h + capp-R★ nom c h = cong (ncapp c) h + + cvalid-at : ∀ g c ρ {v w : CNf} → ¬ (g ≡ ph) → + R★ (mulZ ρ g) v w → R★ ρ (ncapp c v) (ncapp c w) + cvalid-at ph c ρ n h = ⊥.rec (n refl) + cvalid-at rep c ph n h = tt + cvalid-at rep c rep n h = ≈-capp c h + cvalid-at rep c nom n h = cong (ncapp c) h + cvalid-at nom c ph n h = tt + cvalid-at nom c rep n h = ≡→≈ (cong (ncapp c) h) + cvalid-at nom c nom n h = cong (ncapp c) h + + pvalid-nom : ∀ p ρ {v w : CNf} → R★ (mulZ ρ nom) v w → R★ ρ (inspect p v) (inspect p w) + pvalid-nom p ph h = tt + pvalid-nom p rep h = ≡→≈ (cong (inspect p) h) + pvalid-nom p nom h = cong (inspect p) h + +valid-lawful : (∀ c → ¬ (cgrade c ≡ ph)) → (∀ p → pgrade p ≡ nom) → Valid +valid-lawful noPh allNom = record + { cvalid = λ c ρ h → cvalid-at (cgrade c) c ρ (noPh c) h + ; pvalid = λ p ρ {v} {w} h → + pvalid-nom p ρ (subst (λ g → R★ (mulZ ρ g) v w) (allNom p) h) } diff --git a/verification/proofs/agda/Wager/Role/Noninterference.agda b/verification/proofs/agda/Wager/Role/Noninterference.agda new file mode 100644 index 0000000..341c1e5 --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Noninterference.agda @@ -0,0 +1,172 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinding derivations. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Noninterference for roles (the proof of T2), for a composition +-- table T and a signature that respects its declared grades. +-- +-- The proof is a logical relation on closed values, indexed by the +-- role of an observer. It uses three properties of the table +-- (associativity, the right unit, monotonicity) and one property of +-- the role order that is not a grade law: a ≤ a + b. +-- It does not use `a · 𝟘 = 𝟘`. +open import Wager.Role.Signature +open import Wager.Role.Table + +module Wager.Role.Noninterference (RS : RoleSig) (T : RoleTable) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_) + +open import Wager.Grade.Finite using (false≢true) +open import Wager.Role.Role +open RoleTable T +open import Wager.L1.Syntax (toSig RS) +open import Wager.L1.Normal (toSig RS) +open import Wager.L1.Eval (toSig RS) +open import Wager.L1.Completeness (toSig RS) using (renVal-id) +open import Wager.L1.Kinding (toSig RS) (tableOps T) +open import Wager.Role.RepEq RS +open import Wager.Role.Validity RS mul + +private + variable + Γ : Ctx + k j : Kind + +------------------------------------------------------------------------ +-- The observers. + +R★-refl : ∀ ρ (v : CNf) → R★ ρ v v +R★-refl ph v = tt +R★-refl rep v = ≈-refl +R★-refl nom v = refl + +-- A weaker observer tells fewer types apart. +R★-anti : ∀ ρ ρ' {v w : CNf} → leR ρ ρ' ≡ true → R★ ρ' v w → R★ ρ v w +R★-anti ph ρ' le h = tt +R★-anti rep ph le h = ⊥.rec (false≢true le) +R★-anti rep rep le h = h +R★-anti rep nom le h = ≡→≈ h +R★-anti nom ph le h = ⊥.rec (false≢true le) +R★-anti nom rep le h = ⊥.rec (false≢true le) +R★-anti nom nom le h = h + +R★-arr : ∀ ρ q {a a' b b' : CNf} → R★ ρ a a' → R★ ρ b b' → + R★ ρ (narr q a b) (narr q a' b') +R★-arr ph q h h' = tt +R★-arr rep q h h' = ≈-arr q h h' +R★-arr nom q h h' = cong₂ (narr q) h h' + +R★-prod : ∀ ρ {a a' b b' : CNf} → R★ ρ a a' → R★ ρ b b' → R★ ρ (a n⊗ b) (a' n⊗ b') +R★-prod ph h h' = tt +R★-prod rep h h' = ≈-prod h h' +R★-prod nom h h' = cong₂ _n⊗_ h h' + +R★-sum : ∀ ρ {a a' b b' : CNf} → R★ ρ a a' → R★ ρ b b' → R★ ρ (a n⊕ b) (a' n⊕ b') +R★-sum ph h h' = tt +R★-sum rep h h' = ≈-sum h h' +R★-sum nom h h' = cong₂ _n⊕_ h h' + +------------------------------------------------------------------------ +-- The logical relation on closed values. + +LR : Role → ∀ k → Val [] k → Val [] k → Type +LR ρ ★ v w = R★ ρ v w +LR ρ (k ⇒[ g ] j) F G = + ∀ ρ₁ → leR ρ₁ ρ ≡ true → (a a' : Val [] k) → LR (mul ρ₁ g) k a a' → + LR ρ₁ j (snd F [] idᵣ a) (snd G [] idᵣ a') + +LR-anti : ∀ k ρ ρ' {v w : Val [] k} → leR ρ ρ' ≡ true → LR ρ' k v w → LR ρ k v w +LR-anti ★ ρ ρ' le h = R★-anti ρ ρ' le h +LR-anti (k ⇒[ g ] j) ρ ρ' le h = + λ ρ₁ le₁ a a' ha → h ρ₁ (leR-trans ρ₁ ρ ρ' le₁ le) a a' ha + +-- Two environments that the observer cannot tell apart, variable by +-- variable, at the grade of each variable. +EnvLR : Role → KUsage Γ → Env [] Γ → Env [] Γ → Type +EnvLR {Γ} ρ γ η η' = ∀ k (x : Var Γ k) → LR (mul ρ (γ k x)) k (η k x) (η' k x) + +private + mul-mono-r : ∀ ρ a b → leR a b ≡ true → leR (mul ρ a) (mul ρ b) ≡ true + mul-mono-r ρ a b le = mul-mono ρ ρ a b (leR-refl ρ) le + + mul-mono-l : ∀ ρ₁ ρ g → leR ρ₁ ρ ≡ true → leR (mul ρ₁ g) (mul ρ g) ≡ true + mul-mono-l ρ₁ ρ g le = mul-mono ρ₁ ρ g g le (leR-refl g) + + unit-self : (x : Var Γ k) → unitᵏ x k x ≡ rep + unit-self vz = refl + unit-self (vs x) = unit-self x + + lam-env : ∀ {g : Role} {γ : KUsage Γ} {η η' : Env [] Γ} (ρ ρ₁ : Role) → + leR ρ₁ ρ ≡ true → EnvLR ρ γ η η' → + {a a' : Val [] j} → LR (mul ρ₁ g) j a a' → + EnvLR ρ₁ (γ ▹ᵏ g) (renEnv idᵣ η ,, a) (renEnv idᵣ η' ,, a') + lam-env ρ ρ₁ le e ha k vz = ha + lam-env {γ = γ} {η} {η'} ρ ρ₁ le e ha k (vs x) = + subst2 (LR (mul ρ₁ (γ k x)) k) + (sym (renVal-id k (η k x))) (sym (renVal-id k (η' k x))) + (LR-anti k _ _ (mul-mono-l ρ₁ ρ (γ k x) le) (e k x)) + +------------------------------------------------------------------------ +-- The fundamental lemma, for a signature that respects its grades. + +module _ (V : Valid) where + open Valid V + + fund : {γ : KUsage Γ} {t : Ty Γ k} → γ ⊢ᵏ t → + ∀ ρ {η η' : Env [] Γ} → EnvLR ρ γ η η' → LR ρ k (eval t η) (eval t η') + fund {k = k} (k-var x) ρ {η} {η'} e = + subst (λ r → LR r k (η k x) (η' k x)) (cong (mul ρ) (unit-self x) ∙ mul-one ρ) (e k x) + fund (k-base b) ρ e = R★-refl ρ (nbase b) + fund (k-capp {γ = γ} c d) ρ {η} {η'} e = + cvalid c ρ + (fund d (mul ρ (cgrade c)) + (λ k x → subst (λ r → LR r k (η k x) (η' k x)) + (sym (mul-assoc ρ (cgrade c) (γ k x))) (e k x))) + fund (k-papp {γ = γ} p d) ρ {η} {η'} e = + pvalid p ρ + (fund d (mul ρ (pgrade p)) + (λ k x → subst (λ r → LR r k (η k x) (η' k x)) + (sym (mul-assoc ρ (pgrade p) (γ k x))) (e k x))) + fund (k-arr {γ = γ} {δ = δ} {q = q} d d') ρ e = + R★-arr ρ q + (fund d ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (max-upper-l (γ k x) (δ k x))) (e k x))) + (fund d' ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (max-upper-r (γ k x) (δ k x))) (e k x))) + fund (k-prod {γ = γ} {δ = δ} d d') ρ e = + R★-prod ρ + (fund d ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (max-upper-l (γ k x) (δ k x))) (e k x))) + (fund d' ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (max-upper-r (γ k x) (δ k x))) (e k x))) + fund (k-sum {γ = γ} {δ = δ} d d') ρ e = + R★-sum ρ + (fund d ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (max-upper-l (γ k x) (δ k x))) (e k x))) + (fund d' ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (max-upper-r (γ k x) (δ k x))) (e k x))) + fund (k-lam d) ρ e = + λ ρ₁ le₁ a a' ha → fund d ρ₁ (lam-env ρ ρ₁ le₁ e ha) + fund (k-app {k = k} {g = g} {γ = γ} {δ = δ} {a = a} d d') ρ {η} {η'} e = + fund d ρ + (λ k₁ x → LR-anti k₁ _ _ + (mul-mono-r ρ _ _ (max-upper-l (γ k₁ x) (mul g (δ k₁ x)))) (e k₁ x)) + ρ (leR-refl ρ) (eval a η) (eval a η') + (fund d' (mul ρ g) + (λ k₁ x → subst (λ r → LR r k₁ (η k₁ x) (η' k₁ x)) + (sym (mul-assoc ρ g (δ k₁ x))) + (LR-anti k₁ _ _ + (mul-mono-r ρ _ _ (max-upper-r (γ k₁ x) (mul g (δ k₁ x)))) + (e k₁ x)))) + fund (k-sub d le) ρ e = + fund d ρ (λ k x → LR-anti k _ _ (mul-mono-r ρ _ _ (le k x)) (e k x)) + + -- Noninterference for a closed type function of kind ★ ⇒[ r ] ★. + noninterference : + ∀ {r : Role} (F : Ty [] (★ ⇒[ r ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + (ρ : Role) (A B : Ty [] ★) → + R★ (mul ρ r) (nf A) (nf B) → R★ ρ (nf (app F A)) (nf (app F B)) + noninterference F d ρ A B h = + fund d ρ {idEnv} {idEnv} (λ k ()) ρ (leR-refl ρ) (nf A) (nf B) h diff --git a/verification/proofs/agda/Wager/Role/RepEq.agda b/verification/proofs/agda/Wager/Role/RepEq.agda new file mode 100644 index 0000000..d83c04d --- /dev/null +++ b/verification/proofs/agda/Wager/Role/RepEq.agda @@ -0,0 +1,68 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinded syntax. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Representational equivalence `≈` on closed normal types of kind ★: +-- the least congruence that contains newtype unfolding. +-- +-- SPECIFICATION ONLY. Theorem statements use `≈`. No typing rule and no +-- kinding rule uses it (RELATION-LEDGER.adoc). +open import Wager.Role.Signature + +module Wager.Role.RepEq (RS : RoleSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false; if_then_else_) + +open RoleSig RS using (isNewtype) +open import Wager.L1.Syntax (toSig RS) +open import Wager.L1.Normal (toSig RS) + +private + variable + Γ : Ctx + +-- Closed normal types of kind ★. +CNf : Type +CNf = Nf [] ★ + +infix 4 _≈_ +data _≈_ : CNf → CNf → Type where + ≈-refl : ∀ {v} → v ≈ v + ≈-sym : ∀ {v w} → v ≈ w → w ≈ v + ≈-trans : ∀ {u v w} → u ≈ v → v ≈ w → u ≈ w + -- Newtype unfolding: the newtype `A@s` and its representation A. + ≈-unfold : ∀ s {v} → isNewtype s ≡ true → ncapp s v ≈ v + -- Congruence for each type former of kind ★. + ≈-capp : ∀ c {v w} → v ≈ w → ncapp c v ≈ ncapp c w + ≈-arr : ∀ q {a a' b b'} → a ≈ a' → b ≈ b' → narr q a b ≈ narr q a' b' + ≈-prod : ∀ {a a' b b'} → a ≈ a' → b ≈ b' → (a n⊗ b) ≈ (a' n⊗ b') + ≈-sum : ∀ {a a' b b'} → a ≈ a' → b ≈ b' → (a n⊕ b) ≈ (a' n⊕ b') + +≡→≈ : ∀ {v w} → v ≡ w → v ≈ w +≡→≈ {v} p = subst (v ≈_) p ≈-refl + +-- The representation of a type: each newtype wrapper is removed. +strip : Nf Γ ★ → Nf Γ ★ +strip (ne n) = ne n +strip (nbase b) = nbase b +strip (ncapp c v) = if isNewtype c then strip v else ncapp c (strip v) +strip (narr q a b) = narr q (strip a) (strip b) +strip (a n⊗ b) = strip a n⊗ strip b +strip (a n⊕ b) = strip a n⊕ strip b + +-- Equivalent types have the same representation. A proof that two +-- types are NOT equivalent uses this lemma. +≈→strip : ∀ {v w} → v ≈ w → strip v ≡ strip w +≈→strip ≈-refl = refl +≈→strip (≈-sym e) = sym (≈→strip e) +≈→strip (≈-trans e e') = ≈→strip e ∙ ≈→strip e' +≈→strip (≈-unfold s {v} p) = + cong (λ b → if b then strip v else ncapp s (strip v)) p +≈→strip (≈-capp c e) = cong (λ z → if isNewtype c then z else ncapp c z) (≈→strip e) +≈→strip (≈-arr q e e') = cong₂ (narr q) (≈→strip e) (≈→strip e') +≈→strip (≈-prod e e') = cong₂ _n⊗_ (≈→strip e) (≈→strip e') +≈→strip (≈-sum e e') = cong₂ _n⊕_ (≈→strip e) (≈→strip e') diff --git a/verification/proofs/agda/Wager/Role/Role.agda b/verification/proofs/agda/Wager/Role/Role.agda new file mode 100644 index 0000000..8441b21 --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Role.agda @@ -0,0 +1,165 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Roles as a grade structure (theorem T1). +-- +-- Role = { phantom, representational, nominal } +-- 𝟘 = phantom 𝟙 = representational +-- + = maximum in the order phantom < representational < nominal +-- · = role composition (outer · inner) +-- +-- There are two composition tables. They differ in one entry: +-- GHC table nominal · phantom = nominal +-- ("a nominal position makes everything below it nominal") +-- lawful table nominal · phantom = phantom +module Wager.Role.Role where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.List.Base using (List; []; _∷_) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Grade.Algebra +open import Wager.Grade.Finite + +data Role : Type where + ph rep nom : Role + +-- The order: ph ≤ rep ≤ nom. +leR : Role → Role → Bool +leR ph _ = true +leR rep ph = false +leR rep _ = true +leR nom nom = true +leR nom _ = false + +-- The join of two uses: the maximum. +maxR : Role → Role → Role +maxR ph b = b +maxR rep ph = rep +maxR rep b = b +maxR nom _ = nom + +-- Composition, GHC table: an outer phantom gives phantom, an outer +-- representational gives the inner role, an outer nominal gives nominal. +mulG : Role → Role → Role +mulG ph _ = ph +mulG rep b = b +mulG nom _ = nom + +-- Composition, lawful table: the same, but nominal · phantom = phantom. +mulZ : Role → Role → Role +mulZ ph _ = ph +mulZ rep b = b +mulZ nom ph = ph +mulZ nom _ = nom + +private + eqR : Role → Role → Bool + eqR ph ph = true + eqR rep rep = true + eqR nom nom = true + eqR _ _ = false + + eqR-sound : ∀ a b → eqR a b ≡ true → a ≡ b + eqR-sound ph ph _ = refl + eqR-sound rep rep _ = refl + eqR-sound nom nom _ = refl + eqR-sound ph rep p = ⊥.rec (false≢true p) + eqR-sound ph nom p = ⊥.rec (false≢true p) + eqR-sound rep ph p = ⊥.rec (false≢true p) + eqR-sound rep nom p = ⊥.rec (false≢true p) + eqR-sound nom ph p = ⊥.rec (false≢true p) + eqR-sound nom rep p = ⊥.rec (false≢true p) + + IsNom : Role → Type + IsNom nom = Unit + IsNom _ = ⊥ + +nom≢ph : ¬ (nom ≡ ph) +nom≢ph p = subst IsNom p tt + +nom≢rep : ¬ (nom ≡ rep) +nom≢rep p = subst IsNom p tt + +finRole : Finite Role +finRole = record + { elems = ph ∷ rep ∷ nom ∷ [] + ; complete = λ { P h ph → &&-l (P ph) h + ; P h rep → &&-l (P rep) (&&-r (P ph) h) + ; P h nom → &&-l (P nom) (&&-r (P rep) (&&-r (P ph) h)) } + ; _==_ = eqR + ; ==-sound = eqR-sound } + +roleGB roleZB : BoolOps Role +roleGB = record { add = maxR ; mul = mulG ; zero = ph ; one = rep ; leB = leR } +roleZB = record { add = maxR ; mul = mulZ ; zero = ph ; one = rep ; leB = leR } + +roleGOps roleZOps : GradeOps Role +roleGOps = toOps roleGB +roleZOps = toOps roleZB + +------------------------------------------------------------------------ +-- T1, lawful table: all 15 law fields hold. + +roleZLaws : GradeLaws roleZOps +roleZLaws = Check.mkLaws finRole roleZB + refl refl refl refl refl refl refl refl refl refl refl refl refl refl refl + +roleZ : GradeAlgebra Role +roleZ = record { ops = roleZOps ; laws = roleZLaws } + +------------------------------------------------------------------------ +-- T1, GHC table: 14 law fields hold, and `mul-zero` fails. + +roleGLaws14 : GradeLawsExceptMulZero roleGOps +roleGLaws14 = Check.mkLaws14 finRole roleGB + refl refl refl refl refl refl refl refl refl refl refl refl refl refl + +-- The Boolean check of `a · 𝟘 = 𝟘` computes to `false`. +roleG-mul-zero-check : Check.mul-zero? finRole roleGB ≡ false +roleG-mul-zero-check = refl + +-- The law fails, and it fails at `nom` only. +roleG-mul-zero-fails : ¬ (∀ a → mulG a ph ≡ ph) +roleG-mul-zero-fails h = nom≢ph (h nom) + +roleG-mul-zero-ph : mulG ph ph ≡ ph +roleG-mul-zero-ph = refl + +roleG-mul-zero-rep : mulG rep ph ≡ ph +roleG-mul-zero-rep = refl + +roleG-mul-zero-nom : ¬ (mulG nom ph ≡ ph) +roleG-mul-zero-nom = nom≢ph + +------------------------------------------------------------------------ +-- Facts about the order that do not depend on the composition table. + +leR-refl : ∀ a → leR a a ≡ true +leR-refl = GradeLaws.le-refl roleZLaws + +leR-trans : ∀ a b c → leR a b ≡ true → leR b c ≡ true → leR a c ≡ true +leR-trans = GradeLaws.le-trans roleZLaws + +-- A use is below the join of two uses. This is NOT one of the 15 laws. +-- It holds because `+` is the maximum. +max-upper-l : ∀ a b → leR a (maxR a b) ≡ true +max-upper-l ph b = refl +max-upper-l rep ph = refl +max-upper-l rep rep = refl +max-upper-l rep nom = refl +max-upper-l nom b = refl + +max-upper-r : ∀ a b → leR b (maxR a b) ≡ true +max-upper-r ph b = leR-refl b +max-upper-r rep ph = refl +max-upper-r rep rep = refl +max-upper-r rep nom = refl +max-upper-r nom ph = refl +max-upper-r nom rep = refl +max-upper-r nom nom = refl diff --git a/verification/proofs/agda/Wager/Role/Role4.agda b/verification/proofs/agda/Wager/Role/Role4.agda new file mode 100644 index 0000000..3ec6ae9 --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Role4.agda @@ -0,0 +1,109 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- A finding of Stage 2, outside T1: a 4-point role structure. +-- +-- The 3-point structures use one grade, `phantom`, for two notions: +-- "the variable does not occur" and "the variable occurs, and its +-- representation does not matter". This structure has two grades: +-- absent the variable does not occur (this is 𝟘) +-- phantom it occurs in phantom positions only +-- With `absent` as 𝟘, the GHC rule `nominal · phantom = nominal` and +-- all 15 law fields hold together. +module Wager.Role.Role4 where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.List.Base using (List; []; _∷_) + +open import Wager.Grade.Algebra +open import Wager.Grade.Finite + +data Role4 : Type where + ab ph4 rep4 nom4 : Role4 + +-- The order: ab ≤ ph4 ≤ rep4 ≤ nom4. +le4 : Role4 → Role4 → Bool +le4 ab _ = true +le4 ph4 ab = false +le4 ph4 _ = true +le4 rep4 ab = false +le4 rep4 ph4 = false +le4 rep4 _ = true +le4 nom4 nom4 = true +le4 nom4 _ = false + +max4 : Role4 → Role4 → Role4 +max4 ab b = b +max4 ph4 ab = ph4 +max4 ph4 b = b +max4 rep4 ab = rep4 +max4 rep4 ph4 = rep4 +max4 rep4 b = b +max4 nom4 _ = nom4 + +-- Composition: `absent` absorbs on both sides. On the other grades it +-- is the GHC table. +mul4 : Role4 → Role4 → Role4 +mul4 ab _ = ab +mul4 _ ab = ab +mul4 ph4 _ = ph4 +mul4 rep4 b = b +mul4 nom4 _ = nom4 + +private + eq4 : Role4 → Role4 → Bool + eq4 ab ab = true + eq4 ph4 ph4 = true + eq4 rep4 rep4 = true + eq4 nom4 nom4 = true + eq4 _ _ = false + + eq4-sound : ∀ a b → eq4 a b ≡ true → a ≡ b + eq4-sound ab ab _ = refl + eq4-sound ph4 ph4 _ = refl + eq4-sound rep4 rep4 _ = refl + eq4-sound nom4 nom4 _ = refl + eq4-sound ab ph4 p = ⊥.rec (false≢true p) + eq4-sound ab rep4 p = ⊥.rec (false≢true p) + eq4-sound ab nom4 p = ⊥.rec (false≢true p) + eq4-sound ph4 ab p = ⊥.rec (false≢true p) + eq4-sound ph4 rep4 p = ⊥.rec (false≢true p) + eq4-sound ph4 nom4 p = ⊥.rec (false≢true p) + eq4-sound rep4 ab p = ⊥.rec (false≢true p) + eq4-sound rep4 ph4 p = ⊥.rec (false≢true p) + eq4-sound rep4 nom4 p = ⊥.rec (false≢true p) + eq4-sound nom4 ab p = ⊥.rec (false≢true p) + eq4-sound nom4 ph4 p = ⊥.rec (false≢true p) + eq4-sound nom4 rep4 p = ⊥.rec (false≢true p) + +finRole4 : Finite Role4 +finRole4 = record + { elems = ab ∷ ph4 ∷ rep4 ∷ nom4 ∷ [] + ; complete = λ { P h ab → &&-l (P ab) h + ; P h ph4 → &&-l (P ph4) (&&-r (P ab) h) + ; P h rep4 → &&-l (P rep4) (&&-r (P ph4) (&&-r (P ab) h)) + ; P h nom4 → &&-l (P nom4) (&&-r (P rep4) (&&-r (P ph4) (&&-r (P ab) h))) } + ; _==_ = eq4 + ; ==-sound = eq4-sound } + +role4B : BoolOps Role4 +role4B = record { add = max4 ; mul = mul4 ; zero = ab ; one = rep4 ; leB = le4 } + +role4Ops : GradeOps Role4 +role4Ops = toOps role4B + +-- All 15 law fields hold. +role4Laws : GradeLaws role4Ops +role4Laws = Check.mkLaws finRole4 role4B + refl refl refl refl refl refl refl refl refl refl refl refl refl refl refl + +role4 : GradeAlgebra Role4 +role4 = record { ops = role4Ops ; laws = role4Laws } + +-- The GHC rule holds: a nominal position makes a phantom use nominal. +role4-ghc-rule : mul4 nom4 ph4 ≡ nom4 +role4-ghc-rule = refl diff --git a/verification/proofs/agda/Wager/Role/Signature.agda b/verification/proofs/agda/Wager/Role/Signature.agda new file mode 100644 index 0000000..89d51c0 --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Signature.agda @@ -0,0 +1,41 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- A signature whose kind grades are roles. +-- +-- It is a signature of the L1 language (Wager.L1.Signature) with the +-- carrier `Role` for kind grades, and one more datum: which unary +-- constants are newtype states. `A@s`, for a newtype state s, is the +-- newtype over the representation type A (DESIGN-CHOICES.adoc, DC-1.4). +module Wager.Role.Signature where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool) +open import Cubical.Data.Sum.Base using (_⊎_) + +open import Wager.L1.Signature +open import Wager.Role.Role + +record RoleSig : Type₁ where + field + TG : Type + Base : Type + Con₁ : Type + cgrade : Con₁ → Role + -- `true` for a newtype state, `false` for another generative constant. + isNewtype : Con₁ → Bool + Prim : Type + pgrade : Prim → Role + onBase : Prim → Base → Base + onCon : Prim → Con₁ → Base ⊎ Prim + onOther : Prim → Base + +toSig : RoleSig → Sig +toSig RS = record + { KG = Role ; TG = TG ; Base = Base + ; Con₁ = Con₁ ; cgrade = cgrade + ; Prim = Prim ; pgrade = pgrade + ; onBase = onBase ; onCon = onCon ; onOther = onOther } + where open RoleSig RS diff --git a/verification/proofs/agda/Wager/Role/Table.agda b/verification/proofs/agda/Wager/Role/Table.agda new file mode 100644 index 0000000..321f40d --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Table.agda @@ -0,0 +1,47 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- A composition table for roles, with the three properties that the +-- noninterference proof uses. `mul-zero` is not one of them, so the +-- GHC table is an instance too. +module Wager.Role.Table where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Bool.Base using (Bool; true; false) + +open import Wager.Grade.Algebra +open import Wager.Grade.Finite +open import Wager.Role.Role + +record RoleTable : Type where + field + mul : Role → Role → Role + mul-assoc : ∀ a b c → mul (mul a b) c ≡ mul a (mul b c) + mul-one : ∀ a → mul a rep ≡ a + mul-mono : ∀ a b c d → leR a b ≡ true → leR c d ≡ true → + leR (mul a c) (mul b d) ≡ true + +-- The grade operations of a table: `+` is the maximum, 𝟘 is phantom, +-- 𝟙 is representational, and `≤` is the role order. +tableOps : RoleTable → GradeOps Role +tableOps T = record + { _+_ = maxR ; _·_ = RoleTable.mul T ; 𝟘 = ph ; 𝟙 = rep + ; _≤_ = λ a b → leR a b ≡ true } + +-- The lawful table. +tableZ : RoleTable +tableZ = record + { mul = mulZ + ; mul-assoc = GradeLaws.mul-assoc roleZLaws + ; mul-one = GradeLaws.mul-one roleZLaws + ; mul-mono = GradeLaws.mul-mono roleZLaws } + +-- The GHC table. +tableG : RoleTable +tableG = record + { mul = mulG + ; mul-assoc = GradeLawsExceptMulZero.mul-assoc roleGLaws14 + ; mul-one = GradeLawsExceptMulZero.mul-one roleGLaws14 + ; mul-mono = GradeLawsExceptMulZero.mul-mono roleGLaws14 } diff --git a/verification/proofs/agda/Wager/Role/Validity.agda b/verification/proofs/agda/Wager/Role/Validity.agda new file mode 100644 index 0000000..393ab5f --- /dev/null +++ b/verification/proofs/agda/Wager/Role/Validity.agda @@ -0,0 +1,38 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- What it means that a signature respects its declared grades. +-- +-- An observer has a role: +-- a nominal observer sees the identity of a type +-- a representational observer sees a type up to `≈` +-- a phantom observer sees nothing +-- A constant or a primitive with the parameter grade g is VALID when, +-- for each observer ρ: arguments that the observer `ρ · g` cannot tell +-- apart give results that the observer ρ cannot tell apart. +-- +-- This file has definitions only. The composition table is a parameter. +open import Wager.Role.Signature +open import Wager.Role.Role + +module Wager.Role.Validity (RS : RoleSig) (mul : Role → Role → Role) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Unit using (Unit) + +open import Wager.L1.Syntax (toSig RS) +open import Wager.L1.Normal (toSig RS) +open import Wager.Role.RepEq RS + +-- What an observer of each role can tell apart. +R★ : Role → CNf → CNf → Type +R★ ph v w = Unit +R★ rep v w = v ≈ w +R★ nom v w = v ≡ w + +record Valid : Type where + field + cvalid : ∀ c ρ {v w} → R★ (mul ρ (cgrade c)) v w → R★ ρ (ncapp c v) (ncapp c w) + pvalid : ∀ p ρ {v w} → R★ (mul ρ (pgrade p)) v w → R★ ρ (inspect p v) (inspect p w) diff --git a/verification/proofs/agda/Wager/Statements.agda b/verification/proofs/agda/Wager/Statements.agda index 8275c30..f63201b 100644 --- a/verification/proofs/agda/Wager/Statements.agda +++ b/verification/proofs/agda/Wager/Statements.agda @@ -15,9 +15,9 @@ module Wager.Statements where open import Cubical.Foundations.Prelude open import Cubical.Data.Sigma using (_×_; Σ-syntax) -open import Cubical.Data.Sum.Base using (_⊎_) +open import Cubical.Data.Sum.Base using (_⊎_; inl) open import Cubical.Data.Nat.Base using (ℕ; zero; suc) -open import Cubical.Data.FinData.Base using (Fin) +open import Cubical.Data.FinData.Base using (Fin) renaming (zero to fzero) open import Wager.Grade.Algebra open import Wager.Grade.Affine using (Affine) @@ -27,8 +27,30 @@ import Wager.L1.Syntax import Wager.L1.Conversion import Wager.L1.Eval import Wager.L1.Normal +import Wager.L1.Kinding import Wager.L2.Signature import Wager.L2.Typing +open import Cubical.Relation.Nullary using (¬_) +open import Cubical.Data.Bool.Base using (true) +open import Wager.Role.Role +open import Wager.Role.Role4 using (Role4; role4Ops; mul4; nom4; ph4) +open import Wager.Role.Table +open import Wager.Role.Signature +import Wager.Role.RepEq +import Wager.Role.Validity +import Wager.Role.Classic +open import Wager.FC.Signature +import Wager.FC.Types +import Wager.FC.Coercion +import Wager.FC.Term +import Wager.FC.Classic +import Wager.Erased.Untyped +import Wager.Erased.LogRel +import Wager.FC.Tagged +import Wager.Trans.Scheme +import Wager.Trans.Target +import Wager.Trans.Coercion +import Wager.Trans.TwoState ------------------------------------------------------------------------ -- STAGE 1 @@ -104,3 +126,443 @@ module T0-Statements T0-Progress = ∀ {γ : Usage 0} {Γ : Cx 0} {t : Tm 0} {A : Ty [] ★} → γ ▸ Γ ⊢ t ∶ A → Value t ⊎ (Σ[ t' ∈ Tm 0 ] (t ⟶ t')) + +------------------------------------------------------------------------ +-- STAGE 2 +------------------------------------------------------------------------ + +-- T1: roles as a grade structure. Role = {ph, rep, nom}, 𝟘 = ph, +-- 𝟙 = rep, + = maximum, · = composition (outer · inner). There are two +-- composition tables. They differ in the entry nominal · phantom. +module T1-Statements where + + -- English: with the lawful table (nominal · phantom = phantom), all + -- 15 law fields hold. + T1-Lawful : Type + T1-Lawful = GradeLaws roleZOps + + -- English: with the GHC table (nominal · phantom = nominal), the 14 + -- law fields other than `a · 𝟘 = 𝟘` hold. + T1-GHC-Other-Laws : Type + T1-GHC-Other-Laws = GradeLawsExceptMulZero roleGOps + + -- English: with the GHC table, the law `a · 𝟘 = 𝟘` is false. + T1-GHC-MulZero-Fails : Type + T1-GHC-MulZero-Fails = ¬ (∀ a → mulG a ph ≡ ph) + + -- English: with the GHC table, `a · 𝟘 = 𝟘` holds at phantom and at + -- representational, and it fails at nominal. + T1-GHC-Fails-At-Nominal-Only : Type + T1-GHC-Fails-At-Nominal-Only = + (mulG ph ph ≡ ph) × (mulG rep ph ≡ ph) × (¬ (mulG nom ph ≡ ph)) + +-- Noninterference for a role signature RS and a composition table T. +-- The kinding judgement is the generic one, with the operations of T. +module Noninterference-Statements (RS : RoleSig) (T : RoleTable) where + open RoleTable T using (mul) + open Wager.L1.Syntax (toSig RS) + open Wager.L1.Eval (toSig RS) + open Wager.L1.Kinding (toSig RS) (tableOps T) + open Wager.Role.Validity RS mul + + -- English: let each constant and each primitive of the signature + -- respect its declared grade (`Valid`). Let F be a closed type + -- function with the parameter grade r. Then, for each observer ρ: + -- two arguments that the observer `ρ · r` cannot tell apart give + -- results that the observer ρ cannot tell apart. + Noninterference : Type + Noninterference = + Valid → + ∀ {r : Role} (F : Ty [] (★ ⇒[ r ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + (ρ : Role) (A B : Ty [] ★) → + R★ (mul ρ r) (nf A) (nf B) → R★ ρ (nf (app F A)) (nf (app F B)) + +-- T2: role soundness as noninterference, with the lawful table. +module T2-Statements (RS : RoleSig) where + open Wager.L1.Syntax (toSig RS) + open Wager.L1.Eval (toSig RS) + open Wager.L1.Kinding (toSig RS) (tableOps tableZ) + open Wager.Role.RepEq RS + open Wager.Role.Validity RS mulZ + + -- English: let the signature respect its declared grades. If F has a + -- parameter grade r ≤ representational, and A ≈ B, then + -- nf (F A) ≈ nf (F B). + T2-Representational : Type + T2-Representational = + Valid → + ∀ {r : Role} (F : Ty [] (★ ⇒[ r ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + leR r rep ≡ true → + (A B : Ty [] ★) → nf A ≈ nf B → nf (app F A) ≈ nf (app F B) + + -- English: let the signature respect its declared grades. If F has + -- the parameter grade phantom, then nf (F A) ≡ nf (F B) for all + -- A and B. + T2-Phantom : Type + T2-Phantom = + Valid → + (F : Ty [] (★ ⇒[ ph ] ★)) {γ : KUsage []} → γ ⊢ᵏ F → + (A B : Ty [] ★) → nf (app F A) ≡ nf (app F B) + +-- T4: the classic unsound program, at the type level. The signature is +-- `classicSig rep` of Wager.Role.Classic. +module T4-Statements where + open Wager.Role.Classic + open Types rep + private S = toSig (classicSig rep) + open Wager.L1.Syntax S + open Wager.L1.Eval S + open Wager.L1.Kinding S (tableOps tableZ) + open Wager.Role.RepEq (classicSig rep) + + -- English: the function `classicF` (it maps Age to Char and Int to + -- Bool) has no kinding derivation at the grade representational, and + -- none at the grade phantom. + T4-Kinding-Rejects : Type + T4-Kinding-Rejects = + (g : Role) → leR g rep ≡ true → (γ : KUsage []) → ¬ (γ ⊢ᵏ classicF g) + + -- English: Age ≈ Int, and the results of `classicF` on Age and on + -- Int are not representationally equivalent. + T4-Not-Equivalent : Type + T4-Not-Equivalent = + (nf {Γ = []} Age ≈ nf Int) + × ((g : Role) → ¬ (nf (app (classicF g) Age) ≈ nf (app (classicF g) Int))) + +-- The test of Stage 2, step 3: a generative constant with a parameter +-- that is declared phantom (`Proxy a`), below a type-level function that +-- inspects its argument. +module Proxy-Statements where + open Wager.Role.Classic + + -- Part A. Lawful table, `proxy` declared phantom. + module A where + open Types ph + private S = toSig (classicSig ph) + open Wager.L1.Syntax S + open Wager.L1.Eval S + open Wager.L1.Kinding S (tableOps tableZ) + open Wager.Role.RepEq (classicSig ph) + open Wager.Role.Validity (classicSig ph) mulZ + + -- English: kinding accepts the grade phantom for + -- `deepF = λa. deep (Proxy a)`, and the results of deepF on Age and + -- on Int are not equivalent. The lawful table is thus NOT sound for + -- a signature with a generative phantom constant. + Lawful-Unsound-With-Phantom-Constant : Type + Lawful-Unsound-With-Phantom-Constant = + (Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ deepF ph)) + × (¬ (nf (app (deepF ph) Age) ≈ nf (app (deepF ph) Int))) + + -- English: the conclusion of T2-Phantom is false for `λa. Proxy a`. + T2-Phantom-Fails-Without-Valid : Type + T2-Phantom-Fails-Without-Valid = + (Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ proxyF ph)) + × (¬ (nf (app (proxyF ph) Int) ≡ nf (app (proxyF ph) Bool'))) + + -- English: this signature does not respect its declared grades. + Phantom-Constant-Not-Valid : Type + Phantom-Constant-Not-Valid = ¬ Valid + + -- Part B. Lawful table, `proxy` declared representational. + module B where + open Types rep + private S = toSig (classicSig rep) + open Wager.L1.Syntax S + open Wager.L1.Eval S + open Wager.Role.RepEq (classicSig rep) + open Wager.Role.Validity (classicSig rep) mulZ + + -- English: this signature respects its declared grades, so T2 + -- holds for it. + Rep-Constant-Valid : Type + Rep-Constant-Valid = Valid + + -- English: `Proxy Int` and `Proxy Bool` are not representationally + -- equivalent. A coercion between them (GHC accepts it, because the + -- parameter of Proxy is phantom) has no counterpart here. + No-Phantom-Coercion : Type + No-Phantom-Coercion = ¬ (nf {Γ = []} (Proxy Int) ≈ nf (Proxy Bool')) + + -- Part C. GHC table, `proxy` declared phantom. + module C where + open Types ph + private S = toSig (classicSig ph) + open Wager.L1.Syntax S + private + module KZ = Wager.L1.Kinding S (tableOps tableZ) + module KG = Wager.L1.Kinding S (tableOps tableG) + + -- English: the GHC table rejects each grade below nominal for + -- `deepF`. On this program it is sound. + GHC-Rejects-Deep : Type + GHC-Rejects-Deep = + (g : Role) → leR g rep ≡ true → (γ : KG.KUsage []) → ¬ (γ KG.⊢ᵏ deepF g) + + -- English: `constF = λa. isAge Int` does not use its parameter. + -- The lawful table accepts the grade phantom for it. The GHC table + -- rejects the grade phantom for it: with the GHC table as a grade + -- structure, a nominal function makes each unused variable nominal. + GHC-Rejects-Unused-Parameter : Type + GHC-Rejects-Unused-Parameter = + (Σ[ γ ∈ KZ.KUsage [] ] (γ KZ.⊢ᵏ constF ph)) + × ((γ : KG.KUsage []) → ¬ (γ KG.⊢ᵏ constF ph)) + +-- A finding outside T1: a 4-point structure with a separate grade +-- "absent" for 𝟘. +module Role4-Statements where + + -- English: the 4-point role structure satisfies all 15 law fields. + Role4-Lawful : Type + Role4-Lawful = GradeLaws role4Ops + + -- English: in the 4-point structure the GHC rule holds: + -- nominal · phantom = nominal. + Role4-Has-GHC-Rule : Type + Role4-Has-GHC-Rule = mul4 nom4 ph4 ≡ nom4 + +------------------------------------------------------------------------ +-- STAGE 3: the source calculus (a fragment of System FC with roles) +------------------------------------------------------------------------ + +-- The statements of this stage are about the SOURCE calculus only. +-- They have no T number. They show that the source calculus is the +-- calculus of Breitner et al. for this fragment: the role check makes +-- zero-cost coercions safe, and without the check the classic program +-- is unsound. +module Source-Statements (SS : SSig) where + open Wager.FC.Types SS + open Wager.FC.Coercion SS + open Wager.FC.Term SS + open Wager.Erased.Untyped.Typing litTy + + -- English: a nominal coercion relates two types with the same + -- nominal value. (This part needs no role check.) + Source-Nominal-Soundness : Type + Source-Nominal-Soundness = (τ σ : STy) → Co nom τ σ → ev τ ≡ ev σ + + -- English: in a signature that passes the role check, a + -- representational coercion relates two types with the same erased + -- type. + Source-Role-Soundness : Type + Source-Role-Soundness = + WellRoled → (τ σ : STy) → Co rep τ σ → er τ ≡ er σ + + -- English: erasure removes each cast. + Cast-Vanishes : Type + Cast-Vanishes = + ∀ {n} {Γ : SCx n} {τ σ} (γ : Co rep τ σ) (e : STm Γ τ) → + eraseTm (cast γ e) ≡ eraseTm e + + -- English: `coerce` erases to the identity function. + Coerce-Erases-To-Identity : Type + Coerce-Erases-To-Identity = + ∀ {n} {Γ : SCx n} {τ σ} (γ : Co rep τ σ) → + eraseTm (coerce {Γ = Γ} γ) ≡ ulam (uvar fzero) + + -- English: in a signature that passes the role check, the erasure of + -- a term of the type τ has the erased type `er τ`. + Erasure-Preserves-Typing : Type + Erasure-Preserves-Typing = + WellRoled → ∀ {n} {Γ : SCx n} {τ} (e : STm Γ τ) → + (λ i → er (Γ i)) ⊢ᵉ eraseTm e ∶ er τ + +-- The classic unsound program: +-- newtype Age = MkAge Int +-- type family F a where { F Int = Bool ; F Age = Char } +-- newtype T a = MkT (F a) +-- `classicS d` is this signature with the declared role d for the +-- parameter of T. +module Classic-Source-Statements where + open Wager.FC.Classic + + -- English: the source role check rejects the declaration + -- "representational" and the declaration "phantom" for the parameter + -- of T. + Classic-Rejected : Type + Classic-Rejected = + (d : Role) → leR d rep ≡ true → ¬ SSig.WellRoled (classicS d) + + -- The signature with the wrong declaration (representational). + module Bad where + open STypes rep + open Wager.FC.Types (classicS rep) + open Wager.FC.Coercion (classicS rep) + open Wager.FC.Term (classicS rep) + open Wager.Erased.Untyped.Typing litTy + + -- English: with the wrong declaration, `T Age` and `T Int` are + -- representationally equal. + Classic-Bad-Coercion : Type + Classic-Bad-Coercion = Co rep (sT sAge) (sT sInt) + + -- English: with the wrong declaration, there is a closed term of + -- the type Bool whose erasure is a Char literal. The erased term + -- evaluates to the Char literal, and it does not have the erased + -- type Bool. + Classic-Unsound-If-Accepted : Type + Classic-Unsound-If-Accepted = + Σ[ e ∈ STm ∅ˢ sBool ] + (eraseTm e ≡ ulit ℓchar) + × (∅ᵉ ⊢ eraseTm e ⇓ vlit ℓchar) + × (¬ (∅ᶜ ⊢ᵉ eraseTm e ∶ er sBool)) + + -- The signature with the correct declaration (nominal). + module Good where + open STypes nom + open Wager.FC.Types (classicS nom) + open Wager.FC.Coercion (classicS nom) + + -- English: the source role check accepts the declaration "nominal". + Classic-Nominal-Accepted : Type + Classic-Nominal-Accepted = WellRoled + + -- English: with the correct declaration, Age and Int are + -- representationally equal, and `T Age` and `T Int` are not. + -- The source calculus thus rejects `coerce : T Age → T Int`. + Classic-Nominal-No-Coercion : Type + Classic-Nominal-No-Coercion = + Co rep sAge sInt × (¬ Co rep (sT sAge) (sT sInt)) + +------------------------------------------------------------------------ +-- STAGE 4: translation and simulation (theorems T3 and T5) +------------------------------------------------------------------------ + +-- The translation of Wager.Trans, for a source signature SS, a state +-- scheme Sc and a grade algebra A for the term grades. +-- T the translation of a type +-- coerceT the translation of a representational coercion, as a +-- function of the target +-- tr the translation of a term +-- eraseT the erasure of a target term (a trope transition vanishes) +-- `𝒱 a` is observational equality of untyped values at the erased +-- type a (Wager.Erased.LogRel). +module Translation-Statements + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (A : GradeAlgebra R) where + private + ops = GradeAlgebra.ops A + open GradeOps ops using (𝟘; 𝟙; _+_; _≤_) + open Wager.FC.Types SS + open Wager.FC.Coercion SS + open Wager.FC.Term SS + open Wager.Trans.Target SS Sc ops using (tSig; tTSig; tRoleSig; T; bodyFun; arr; []) + open Wager.Trans.Coercion SS Sc ops using (coerceT; tr; eraseT; coI; fwd; tvar) + open Wager.L2.Typing tSig tTSig ops using (Cx; _▸_⊢_∶_; 0ᵘ) + open Wager.Erased.LogRel litTy + open Wager.Erased.Untyped using (earr) + + -- English: a representational coercion becomes an ordinary term of + -- the target: a function from the translation of τ to the + -- translation of σ. The term uses no variable of the context, and + -- its parameter has the grade 𝟙. This holds in EACH grade algebra. + Coercion-Is-A-Term : Type + Coercion-Is-A-Term = + WellRoled → ∀ {τ σ} (γ : Co rep τ σ) {n} (Γ : Cx n) → + 0ᵘ ▸ Γ ⊢ coerceT γ ∶ arr 𝟙 (T τ) (T σ) + + -- English (T3): the erasure of each translated coercion evaluates to + -- a function value, and this value is observationally equal to the + -- identity function, at the erased type of τ. + T3 : Type + T3 = + WellRoled → ∀ {τ σ} (γ : Co rep τ σ) → + Σ[ f ∈ UVal ] (∅ᵉ ⊢ eraseT (coerceT γ) ⇓ f) + × 𝒱 (earr (er τ) (er τ)) (vclo ∅ᵉ (uvar fzero)) f + + -- English (T3 at a first-order type): the body of the erased + -- coercion, with its argument bound to the value v, evaluates to v. + T3-First-Order : Type + T3-First-Order = + WellRoled → ∀ {τ σ} (γ : Co rep τ σ) → FO (er τ) → + ∀ v → 𝒱 (er τ) v v → + Σ[ w ∈ UVal ] ((v ∷ᵉ ∅ᵉ) ⊢ eraseT (fwd (coI rep γ) (tvar fzero)) ⇓ w) × (w ≡ v) + + -- English (T5, typing): the translation of a term of the type τ has + -- the type `T τ`, with the usage 𝟙 for each variable. This holds in + -- each grade algebra in which the grade 𝟙 is unrestricted: 𝟘 ≤ 𝟙 and + -- 𝟙 + 𝟙 ≤ 𝟙. + T5-Typing : Type + T5-Typing = + WellRoled → 𝟘 ≤ 𝟙 → (𝟙 + 𝟙) ≤ 𝟙 → + ∀ {n} {Γ : SCx n} {τ} (e : STm Γ τ) → + (λ _ → 𝟙) ▸ (λ i → T (Γ i)) ⊢ tr e ∶ T τ + + -- English (T5, behaviour): for a closed source term, the erased + -- source term and the erased translation evaluate, and the two + -- values are observationally equal at the erased type. + T5-Behaviour : Type + T5-Behaviour = + WellRoled → ∀ {τ} (e : STm ∅ˢ τ) → + Σ[ v ∈ UVal ] Σ[ w ∈ UVal ] + (∅ᵉ ⊢ eraseTm e ⇓ v) × (∅ᵉ ⊢ eraseT (tr e) ⇓ w) × 𝒱 (er τ) v w + + -- English (T5 at a first-order type): the two erased programs + -- evaluate to one value. + T5-Behaviour-First-Order : Type + T5-Behaviour-First-Order = + WellRoled → ∀ {τ} (e : STm ∅ˢ τ) → FO (er τ) → + Σ[ v ∈ UVal ] (∅ᵉ ⊢ eraseTm e ⇓ v) × (∅ᵉ ⊢ eraseT (tr e) ⇓ v) + + -- English: the target signature of the translation respects its + -- declared grades. The hypothesis of T2 thus holds for it. + Target-Signature-Valid : Type + Target-Signature-Valid = Wager.Role.Validity.Valid tRoleSig mulZ + + module _ where + open Wager.L1.Kinding tSig (tableOps tableZ) + + -- English (role correspondence): the body of a newtype N is a + -- type-level function of the target. Target kinding accepts the + -- grade g for its parameter exactly when the inferred source role + -- of the parameter is at most g. The inferred role is thus the + -- least grade that kinding accepts. + Role-Correspondence : Type + Role-Correspondence = + (N : N₁) (g : Role) → + ((leR (roleOf (body N)) g ≡ true) → Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun N g)) + × ((γ : KUsage []) → γ ⊢ᵏ bodyFun N g → leR (roleOf (body N)) g ≡ true) + + -- English: the source role check holds exactly when target kinding + -- accepts the declared role of each newtype. + Role-Check-Is-Kinding : Type + Role-Check-Is-Kinding = + (WellRoled → (N : N₁) → Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun N (role N))) + × (((N : N₁) → Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun N (role N))) → WellRoled) + +-- `Translation` and `TwoState` are in Wager.Trans.TwoState. +-- `Translation` says what a translation of types must keep. +-- `TwoState` says that each newtype with a parameter is ONE trope state +-- on its representation, as in Stage 2 (`Int@age`, `Int@raw`). +module Two-State-Statements where + + module _ (SS : SSig) {R : Type} (ops : GradeOps R) where + open Wager.FC.Types SS + open Wager.Trans.Scheme SS + open Wager.Trans.TwoState SS + private + tgt : StateScheme → Sig + tgt Sc = Wager.Trans.Target.tSig SS Sc ops + + -- English: for each source signature, the translation with the row + -- scheme meets the conditions of `Translation`. + Row-Translation-Exists : Type + Row-Translation-Exists = Translation (tgt rowScheme) + + -- English: when no type-level function looks at the argument of a + -- newtype, the translation with two-state tropes exists. + Two-State-Translation-Exists : Type + Two-State-Translation-Exists = + (c : Fam → N₁ → Base) (h : ∀ F N → fNt₁ F N ≡ inl (c F N)) → + Σ[ t ∈ Translation (tgt (twoState c h)) ] TwoState (tgt (twoState c h)) t + + -- The source signature `taggedS rep` has the phantom newtype + -- `newtype Tag a = MkTag Int` and the type-level function F with + -- `F (Tag a) = G a`, `G Int = Bool`, `G Bool = Char`. + -- + -- English: this source program has NO translation with two-state + -- tropes. This holds for each target signature. + No-Two-State-Translation : Type₁ + No-Two-State-Translation = + (S : Sig) (t : Translation S) → ¬ TwoState S t + where open Wager.Trans.TwoState (Wager.FC.Tagged.taggedS rep) diff --git a/verification/proofs/agda/Wager/TOOLCHAIN.adoc b/verification/proofs/agda/Wager/TOOLCHAIN.adoc index 500e378..628e34d 100644 --- a/verification/proofs/agda/Wager/TOOLCHAIN.adoc +++ b/verification/proofs/agda/Wager/TOOLCHAIN.adoc @@ -1,7 +1,7 @@ // SPDX-License-Identifier: CC-BY-SA-4.0 // SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) = Wager: toolchain record -Status: Stage 0 record. Checked on 2026-11-10. +Status: toolchain record, with the gate watch of each stage. Checked on 2026-11-10. :toc: left :sectnums: @@ -75,9 +75,11 @@ git clone --depth 1 --branch v0.9 https://github.com/agda/cubical /opt/agda/cubi git -C /opt/agda/cubical-0.9 rev-parse HEAD # b150186d2544e7efeddd31e5d14a8b9ecbb100f7 mkdir -p "$(agda --print-agda-app-dir)" -echo "/opt/agda/cubical-0.9/cubical.agda-lib" > "$(agda --print-agda-app-dir)/libraries" +echo "/opt/agda/cubical-0.9/cubical.agda-lib" >> "$(agda --print-agda-app-dir)/libraries" ---- +The last command adds one line to the file `libraries`. It does not replace the libraries that a developer has there. + The project library file is `verification/proofs/agda/wager.agda-lib`. It names the dependency `cubical-0.9` and has no `flags:` line. @@ -115,7 +117,7 @@ Importing module Cubical.Foundations.Prelude using the Thus the rule "add `--guardedness` only in a file that needs coinduction" cannot hold with the stock library. Stage 0 uses a second pragma line, `{-# OPTIONS --guardedness #-}`, in each file. -This is provisional. The owner decides (see `DESIGN-CHOICES.adoc`, DC-0.2). +The owner accepted this on 2026-11-10 (see `DESIGN-CHOICES.adoc`, DC-0.2). One alternative was tested. A copy of the library tree with `--guardedness` removed from its `flags:` line lets a `--cubical --safe` file import `Cubical.Foundations.Prelude` and `Cubical.Data.List`. @@ -210,4 +212,83 @@ A clean build of `Wager/Everything.agda` (29 modules) takes about 20 seconds and |=== The third test shows that the Boolean law checker of `Wager.Grade.Finite` rejects a structure that fails a law. -The status-drift gate now asks for the line `// gate:agda gated=29 quarantined=0`. +At the end of Stage 1 the status-drift gate asked for the line `// gate:agda gated=29 quarantined=0`. + +=== Gate watch at the end of Stage 2 + +A clean build of `Wager/Everything.agda` (41 modules) takes about 25 seconds and prints no warning. + +[cols="3,3,1",options="header"] +|=== +| Change | Error from Agda | Gate + +| `Wager/Role/Role.agda`: the lawful table gets the GHC entry (`nom · ph = nom`) +| `[UnequalTerms] false != true of type Bool` at the law check +| FAIL + +| `Wager/Proofs.agda`: a false lemma (the GHC table has all the laws), with the proof `refl` for `a · 0 = 0` +| `[UnequalTerms] mulG a … != ph of type Role` +| FAIL + +| `Wager/Proofs.agda`: `postulate ghc-lawful-by-fiat : GradeLaws roleGOps` +| `[SafeFlagPostulate] Cannot postulate ghc-lawful-by-fiat with safe flag`. `scan-dangerous.sh` also fails. +| FAIL + +| All changes removed +| None +| PASS, 41 files +|=== + +=== Gate watch at the end of Stage 3 + +A clean build of `Wager/Everything.agda` (51 modules) takes about 28 seconds and prints no warning. + +[cols="3,3,1",options="header"] +|=== +| Change | Error from Agda | Gate + +| `Wager/FC/ClassicProofs.agda`: a false lemma (the wrong declaration passes the role check), with the proof `refl` +| `[UnequalTerms] false != true of type Bool` +| FAIL + +| `Wager/FC/ClassicProofs.agda`: `postulate s3-by-fiat : SSig.WellRoled (classicS rep)` +| `[SafeFlagPostulate] Cannot postulate s3-by-fiat with safe flag`. `scan-dangerous.sh` also fails. +| FAIL + +| `Wager/FC/Classic.agda`: the equation `F Age = Char` changed to `F Age = Bool` +| `[UnequalTerms] bBool != bChar of type BaseName` in the proof of the classic program +| FAIL + +| All changes removed +| None +| PASS, 51 files +|=== + +The third test shows that the proofs for the classic program depend on the function `F`, which maps `Age` and `Int` to different types. + +=== Gate watch at the end of Stage 4 + +A clean build of `Wager/Everything.agda` (64 modules) takes about 35 seconds and prints no warning. + +[cols="3,3,1",options="header"] +|=== +| Change | Error from Agda | Gate + +| `Wager/Trans/TwoStateProofs.agda`: a false lemma (no function of the tagged signature looks at the argument of a newtype), with the proof `refl` +| `[UnequalTerms] fNt₁E F N != inl bUnit` +| FAIL + +| `Wager/Trans/TwoStateProofs.agda`: `postulate s4-by-fiat : …` +| `[SafeFlagPostulate] Cannot postulate s4-by-fiat with safe flag`. `scan-dangerous.sh` also fails. +| FAIL + +| `Wager/Trans/Coercion.agda`: the map of a sum exchanges the two injections +| `[UnequalTerms] uinl … != uinr …` in `Wager/Trans/Simulation.agda`. `Wager/Trans/Typing.agda` also fails. +| FAIL + +| All changes removed +| None +| PASS, 64 files +|=== + +The third test shows that the proofs of T3 and T5 depend on the terms that the translation gives. diff --git a/verification/proofs/agda/Wager/Trans/Coercion.agda b/verification/proofs/agda/Wager/Trans/Coercion.agda new file mode 100644 index 0000000..1b12a6d --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/Coercion.agda @@ -0,0 +1,163 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on coercions and on typed terms. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The translation of coercions and of terms (Stage 4). +-- +-- A representational coercion becomes a pair of term transformers +-- (forwards and backwards). A transformer is built from: +-- trope transitions wrap and unwrap of a newtype instance; +-- functorial maps for a function, a pair and a sum; +-- composition and the identity. +-- A nominal coercion becomes the identity transformer: the two +-- translated types are convertible, and no term remains. +-- +-- There is no cast in the target. The translation of `cast γ e` is the +-- transformer of γ on the translation of e. +open import Cubical.Foundations.Prelude +open import Wager.FC.Signature +open import Wager.Grade.Algebra +import Wager.Trans.Scheme + +module Wager.Trans.Coercion + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (ops : GradeOps R) where + +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) +open import Cubical.Data.Sigma using (_×_; _,_) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Role.Role +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +open import Wager.FC.Term SS +open import Wager.Trans.Target SS Sc ops +open import Wager.L2.Term tSig tTSig hiding (Lit; litTy) public +open GradeOps ops using (𝟙) + +private + variable + n : ℕ + τ σ : STy + +-- A term transformer works in each scope. +Tr : Type +Tr = ∀ {n} → Tm n → Tm n + +record Iso : Type where + constructor iso + field + fwd : Tr + bwd : Tr +open Iso public + +idIso : Iso +idIso = iso (λ t → t) (λ t → t) + +swapIso : Iso → Iso +swapIso i = iso (bwd i) (fwd i) + +compIso : Iso → Iso → Iso +compIso i j = iso (λ t → fwd j (fwd i t)) (λ t → bwd i (bwd j t)) + +-- The map of a function: (λf. λx. g (f (h x))) t. +-- X is the type of t, and A is the type of x. +arrMap : (X A : Ty [] ★) → Tr → Tr → Tr +arrMap X A h g t = + tapp (tlam 𝟙 X (tlam 𝟙 A (g (tapp (tvar (suc zero)) (h (tvar zero)))))) t + +arrIso : (A A' B B' : Ty [] ★) → Iso → Iso → Iso +arrIso A A' B B' i j = + iso (arrMap (arr 𝟙 A B) A' (bwd i) (fwd j)) + (arrMap (arr 𝟙 A' B') A (fwd i) (bwd j)) + +-- The map of a pair: let (x, y) = t in (f x, g y). +prodMap : Tr → Tr → Tr +prodMap f g t = letp t (pair (f (tvar (suc zero))) (g (tvar zero))) + +prodIso : Iso → Iso → Iso +prodIso i j = iso (prodMap (fwd i) (fwd j)) (prodMap (bwd i) (bwd j)) + +-- The map of a sum: case t of { inl x → inl (f x) ; inr y → inr (g y) }. +sumMap : Tr → Tr → Tr +sumMap f g t = case t (inj₁ (f (tvar zero))) (inj₂ (g (tvar zero))) + +sumIso : Iso → Iso → Iso +sumIso i j = iso (sumMap (fwd i) (fwd j)) (sumMap (bwd i) (bwd j)) + +-- The two trope transitions of a newtype instance. +-- Forwards is unwrap: from the newtype to its representation. +stepIso : Inst → Iso +stepIso x = iso (λ t → step (unwrap , x) t) (λ t → step (wrap , x) t) + +-- The map of a body, from the map of its parameter. X and Y are the +-- two types of the parameter. +bodyIso : Body Base Fam → (X Y : Ty [] ★) → Iso → Iso +bodyIso bvar X Y i = i +bodyIso (bbase b) X Y i = idIso +bodyIso (barr β γ) X Y i = + arrIso (TB β X) (TB β Y) (TB γ X) (TB γ Y) (bodyIso β X Y i) (bodyIso γ X Y i) +bodyIso (bprod β γ) X Y i = prodIso (bodyIso β X Y i) (bodyIso γ X Y i) +bodyIso (bsum β γ) X Y i = sumIso (bodyIso β X Y i) (bodyIso γ X Y i) +bodyIso (bfam F β) X Y i = idIso + +-- Congruence for a newtype: unwrap, map the body, wrap. +ntIso : (N : N₁) (τ σ : STy) → Iso → Iso +ntIso N τ σ i = + iso (λ t → step (wrap , inr (N , σ)) (fwd b (step (unwrap , inr (N , τ)) t))) + (λ t → step (wrap , inr (N , τ)) (bwd b (step (unwrap , inr (N , σ)) t))) + where b = bodyIso (body N) (T τ) (T σ) i + +-- The translation of a coercion. Only the role representational gives +-- a term. +coI : (r : Role) → Co r τ σ → Iso +coI nom γ = idIso +coI ph γ = idIso +coI rep (c-sym γ) = swapIso (coI rep γ) +coI rep (c-trans γ δ) = compIso (coI rep γ) (coI rep δ) +coI rep (c-sub γ) = idIso +coI rep (c-arr {τ = τ} {τ' = τ'} {σ = σ} {σ' = σ'} γ δ) = + arrIso (T τ) (T τ') (T σ) (T σ') (coI rep γ) (coI rep δ) +coI rep (c-prod γ δ) = prodIso (coI rep γ) (coI rep δ) +coI rep (c-sum γ δ) = sumIso (coI rep γ) (coI rep δ) +coI rep (c-nt₁ {τ = τ} {σ = σ} N γ) = ntIso N τ σ (coI (mulG rep (role N)) γ) +coI rep (c-ax₀ N) = stepIso (inl N) +coI rep (c-ax₁ N τ) = stepIso (inr (N , τ)) + +-- The translated coercion as a function of the target: λx. (coercion) x. +coerceT : Co rep τ σ → Tm n +coerceT {τ = τ} γ = tlam 𝟙 (T τ) (fwd (coI rep γ) (tvar zero)) + +------------------------------------------------------------------------ +-- The translation of terms. + +tr : ∀ {Γ : SCx n} → STm Γ τ → Tm n +tr (svar i) = tvar i +tr (slam {τ = τ} b) = tlam 𝟙 (T τ) (tr b) +tr (sapp f a) = tapp (tr f) (tr a) +tr (spair s t) = pair (tr s) (tr t) +tr (sletp s b) = letp (tr s) (tr b) +tr (sinl t) = inj₁ (tr t) +tr (sinr t) = inj₂ (tr t) +tr (scase s l r) = case (tr s) (tr l) (tr r) +tr (slit ℓ) = lit ℓ +tr (cast γ e) = fwd (coI rep γ) (tr e) + +------------------------------------------------------------------------ +-- Erasure of the target: a trope transition vanishes. + +eraseT : Tm n → UTm n +eraseT (tvar i) = uvar i +eraseT (tlam q A b) = ulam (eraseT b) +eraseT (tapp f a) = uapp (eraseT f) (eraseT a) +eraseT (pair s t) = upair (eraseT s) (eraseT t) +eraseT (letp s b) = uletp (eraseT s) (eraseT b) +eraseT (inj₁ t) = uinl (eraseT t) +eraseT (inj₂ t) = uinr (eraseT t) +eraseT (case s l r) = ucase (eraseT s) (eraseT l) (eraseT r) +eraseT (lit ℓ) = ulit ℓ +eraseT (step o t) = eraseT t diff --git a/verification/proofs/agda/Wager/Trans/Nominal.agda b/verification/proofs/agda/Wager/Trans/Nominal.agda new file mode 100644 index 0000000..cb93ecf --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/Nominal.agda @@ -0,0 +1,116 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Nominal equality of the source becomes conversion in the target +-- (Stage 4, a lemma for the typing of translated casts). +-- +-- The normal form of a translated type is a function of the nominal +-- value of the source type. Two source types with one nominal value +-- thus have translations with one normal form. +open import Cubical.Foundations.Prelude +open import Wager.FC.Signature +open import Wager.Grade.Algebra +import Wager.Trans.Scheme + +module Wager.Trans.Nominal + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (ops : GradeOps R) where + +open import Cubical.Data.Sigma using (_×_; _,_; fst; snd) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Role.Role +open import Wager.Erased.Untyped using (ETy; ebase; earr; eprod; esum) +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +open import Wager.FC.RoleSoundness SS using (nom-sound) +open import Wager.Trans.Target SS Sc ops +open import Wager.L1.Conversion tSig +open import Wager.L1.Normal tSig +open import Wager.L1.Eval tSig +open import Wager.L1.Equality tSig +open GradeOps ops using (𝟙) + +-- The normal form of the translated body, from the value of the +-- parameter and the normal form of the translated parameter. +TVB : Body Base Fam → VTy → Nf [] ★ → Nf [] ★ +TVB bvar v n = n +TVB (bbase b) v n = nbase b +TVB (barr β γ) v n = narr 𝟙 (TVB β v n) (TVB γ v n) +TVB (bprod β γ) v n = TVB β v n n⊗ TVB γ v n +TVB (bsum β γ) v n = TVB β v n n⊕ TVB γ v n +TVB (bfam F β) v n = nbase (applyF F (evB β v)) + +-- The normal form of the translation, from the nominal value. +TV : VTy → Nf [] ★ +TV (vbase b) = nbase b +TV (varr v w) = narr 𝟙 (TV v) (TV w) +TV (vprod v w) = TV v n⊗ TV w +TV (vsum v w) = TV v n⊕ TV w +TV (vnt₀ N) = ncapp (inl N) (nf (TE (rep₀ N))) +TV (vnt₁ N v) = ncapp (inr (N , idx N v)) (TVB (body N) v (TV v)) + +-- A target primitive computes the source function. +insp-V : ∀ F v → inspect F (TV v) ≡ nbase (applyF F v) +insp-V F (vbase b) = refl +insp-V F (varr v w) = refl +insp-V F (vprod v w) = refl +insp-V F (vsum v w) = refl +insp-V F (vnt₀ N) = refl +insp-V F (vnt₁ N v) = cong nbase (obs-ok F N v) + +insp-B : ∀ F β v → inspect F (TVB β v (TV v)) ≡ nbase (applyF F (evB β v)) +insp-B F bvar v = insp-V F v +insp-B F (bbase b) v = refl +insp-B F (barr β γ) v = refl +insp-B F (bprod β γ) v = refl +insp-B F (bsum β γ) v = refl +insp-B F (bfam G β) v = refl + +nf-TB : ∀ β v (A : Ty [] ★) → nf A ≡ TV v → nf (TB β A) ≡ TVB β v (TV v) +nf-TB bvar v A h = h +nf-TB (bbase b) v A h = refl +nf-TB (barr β γ) v A h = cong₂ (narr 𝟙) (nf-TB β v A h) (nf-TB γ v A h) +nf-TB (bprod β γ) v A h = cong₂ _n⊗_ (nf-TB β v A h) (nf-TB γ v A h) +nf-TB (bsum β γ) v A h = cong₂ _n⊕_ (nf-TB β v A h) (nf-TB γ v A h) +nf-TB (bfam F β) v A h = cong (inspect F) (nf-TB β v A h) ∙ insp-B F β v + +nf-T : ∀ τ → nf (T τ) ≡ TV (ev τ) +nf-T (sbase b) = refl +nf-T (τ ⇒ˢ σ) = cong₂ (narr 𝟙) (nf-T τ) (nf-T σ) +nf-T (τ ×ˢ σ) = cong₂ _n⊗_ (nf-T τ) (nf-T σ) +nf-T (τ +ˢ σ) = cong₂ _n⊕_ (nf-T τ) (nf-T σ) +nf-T (nt₀ N) = refl +nf-T (nt₁ N τ) = cong (ncapp (inr (N , idx N (ev τ)))) (nf-TB (body N) (ev τ) (T τ) (nf-T τ)) +nf-T (fam F τ) = cong (inspect F) (nf-T τ) ∙ insp-V F (ev τ) + +-- Two source types with one nominal value: the translations have one +-- normal form, so they are convertible. +value→nf : ∀ {τ σ} → ev τ ≡ ev σ → nf (T τ) ≡ nf (T σ) +value→nf {τ} {σ} p = nf-T τ ∙ cong TV p ∙ sym (nf-T σ) + +nominal-nf : ∀ {τ σ} → Co nom τ σ → nf (T τ) ≡ nf (T σ) +nominal-nf γ = value→nf (nom-sound γ) + +nominal-defeq : ∀ {τ σ} → Co nom τ σ → DefEq (T τ) (T σ) +nominal-defeq γ = nf→defEq (nominal-nf γ) + +------------------------------------------------------------------------ +-- The translation commutes with the instance of a body and with the +-- embedding of an erased type. + +T-inst : ∀ β τ → T (inst β τ) ≡ TB β (T τ) +T-inst bvar τ = refl +T-inst (bbase b) τ = refl +T-inst (barr β γ) τ = cong₂ (arr 𝟙) (T-inst β τ) (T-inst γ τ) +T-inst (bprod β γ) τ = cong₂ _⊗_ (T-inst β τ) (T-inst γ τ) +T-inst (bsum β γ) τ = cong₂ _⊕_ (T-inst β τ) (T-inst γ τ) +T-inst (bfam F β) τ = cong (papp F) (T-inst β τ) + +T-embE : ∀ a → T (embE a) ≡ TE a +T-embE (ebase b) = refl +T-embE (earr a b) = cong₂ (arr 𝟙) (T-embE a) (T-embE b) +T-embE (eprod a b) = cong₂ _⊗_ (T-embE a) (T-embE b) +T-embE (esum a b) = cong₂ _⊕_ (T-embE a) (T-embE b) diff --git a/verification/proofs/agda/Wager/Trans/RoleCorrespondence.agda b/verification/proofs/agda/Wager/Trans/RoleCorrespondence.agda new file mode 100644 index 0000000..58ed1bd --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/RoleCorrespondence.agda @@ -0,0 +1,116 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinded syntax. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Role correspondence (Stage 4). +-- +-- The body of a source newtype is a type-level function of the target. +-- Graded kinding of the target, with the lawful role table, accepts the +-- grade g for the parameter exactly when the inferred source role of +-- the parameter is at most g. +-- +-- The target signature of the translation also respects its declared +-- grades (`Valid`), so the hypothesis of T2 holds for it. +open import Cubical.Foundations.Prelude +open import Wager.FC.Signature +open import Wager.Grade.Algebra +import Wager.Trans.Scheme + +module Wager.Trans.RoleCorrespondence + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (ops : GradeOps R) where + +open import Cubical.Data.Bool.Base using (true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_; _,_; fst; snd; Σ-syntax) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Role.Role +open import Wager.Role.Table +open import Wager.FC.Types SS +open import Wager.Trans.Target SS Sc ops +open import Wager.L1.Kinding tSig (tableOps tableZ) +open import Wager.L1.KindingInversion tSig (tableOps tableZ) leR-refl leR-trans +import Wager.Role.Validity +import Wager.Role.Lawful + +private + -- The usage vector of the one type variable of a body. + only : Role → KUsage (★ ∷ []) + only g k vz = g + + ε : KUsage [] + ε k () + + only-≼ : ∀ {γ : KUsage (★ ∷ [])} g → leR (γ ★ vz) g ≡ true → γ ≼ᵏ only g + only-≼ g le k vz = le + + -- The laws of the lawful role structure that the proofs use. + module L = GradeLaws roleZLaws + + open-ty : Body Base Fam → Ty (★ ∷ []) ★ + open-ty β = TB β (var vz) + +-- Kinding accepts the inferred role. +kind-body : ∀ β → only (roleOf β) ⊢ᵏ open-ty β +kind-body bvar = k-sub (k-var vz) (only-≼ rep refl) +kind-body (bbase b) = k-sub (k-base b) (only-≼ {γ = 0ᵏ} ph refl) +kind-body (barr β γ) = + k-sub (k-arr (kind-body β) (kind-body γ)) (only-≼ _ (leR-refl _)) +kind-body (bprod β γ) = + k-sub (k-prod (kind-body β) (kind-body γ)) (only-≼ _ (leR-refl _)) +kind-body (bsum β γ) = + k-sub (k-sum (kind-body β) (kind-body γ)) (only-≼ _ (leR-refl _)) +kind-body (bfam F β) = k-sub (k-papp F (kind-body β)) (only-≼ _ (leR-refl _)) + +-- Each kinding derivation uses the parameter at the inferred role or above. +kind-body-inv : ∀ β {δ : KUsage (★ ∷ [])} → δ ⊢ᵏ open-ty β → leR (roleOf β) (δ ★ vz) ≡ true +kind-body-inv bvar d = inv-k-var d ★ vz +kind-body-inv (bbase b) d = refl +kind-body-inv (barr β γ) d = + let (δ₁ , δ₂ , d₁ , d₂ , le) = inv-k-arr d + in leR-trans _ _ _ + (L.add-mono _ _ _ _ (kind-body-inv β d₁) (kind-body-inv γ d₂)) (le ★ vz) +kind-body-inv (bprod β γ) d = + let (δ₁ , δ₂ , d₁ , d₂ , le) = inv-k-prod d + in leR-trans _ _ _ + (L.add-mono _ _ _ _ (kind-body-inv β d₁) (kind-body-inv γ d₂)) (le ★ vz) +kind-body-inv (bsum β γ) d = + let (δ₁ , δ₂ , d₁ , d₂ , le) = inv-k-sum d + in leR-trans _ _ _ + (L.add-mono _ _ _ _ (kind-body-inv β d₁) (kind-body-inv γ d₂)) (le ★ vz) +kind-body-inv (bfam F β) d = + let (δ' , d' , le) = inv-k-papp d + in leR-trans _ _ _ + (L.mul-mono nom nom _ _ refl (kind-body-inv β d')) (le ★ vz) + +-- THE CORRESPONDENCE. +role-correspondence : (N : N₁) (g : Role) → + ((leR (roleOf (body N)) g ≡ true) → Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun N g)) + × ((γ : KUsage []) → γ ⊢ᵏ bodyFun N g → leR (roleOf (body N)) g ≡ true) +role-correspondence N g = + (λ le → ε , k-lam (k-sub (kind-body (body N)) (λ { k vz → le }))) + , (λ γ d → let (γ' , d' , _) = inv-k-lam d in kind-body-inv (body N) d') + +role-check-is-kinding : + (WellRoled → (N : N₁) → Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun N (role N))) + × (((N : N₁) → Σ[ γ ∈ KUsage [] ] (γ ⊢ᵏ bodyFun N (role N))) → WellRoled) +role-check-is-kinding = + (λ wr N → fst (role-correspondence N (role N)) (wr N)) + , (λ h N → snd (role-correspondence N (role N)) (fst (h N)) (snd (h N))) + +------------------------------------------------------------------------ +-- The target signature respects its declared grades. + +private + IsRep : Role → Type + IsRep rep = Unit + IsRep _ = ⊥ + +target-valid : Wager.Role.Validity.Valid tRoleSig mulZ +target-valid = + Wager.Role.Lawful.valid-lawful tRoleSig (λ c p → subst IsRep p tt) (λ p → refl) diff --git a/verification/proofs/agda/Wager/Trans/Scheme.agda b/verification/proofs/agda/Wager/Trans/Scheme.agda new file mode 100644 index 0000000..73b2bb5 --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/Scheme.agda @@ -0,0 +1,51 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- State schemes for the translation of newtypes (Stage 4). +-- +-- The translation makes a newtype `N τ` a trope state on the +-- representation of `N τ`. A state scheme says how many states the +-- newtype N needs. The state of `N τ` is the pair of N and an index. +-- The index keeps what a type-level function can see of the argument τ. +-- +-- obs F N i the result of the function F on `N τ`, read from the +-- index i of `N τ`. +-- +-- Two schemes are given: +-- rowScheme the index is the row of the results of all the +-- functions. It exists for each signature. +-- twoState one index. The newtype is a two-state trope (raw and +-- wrapped), as in Stage 2. It exists when no function +-- looks at the argument of a newtype. +open import Wager.FC.Signature + +module Wager.Trans.Scheme (SS : SSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.FC.Types SS + +record StateScheme : Type₁ where + field + Idx : Type + idx : N₁ → VTy → Idx + obs : Fam → N₁ → Idx → Base + obs-ok : ∀ F N v → obs F N (idx N v) ≡ applyF F (vnt₁ N v) + +rowScheme : StateScheme +rowScheme = record + { Idx = Fam → Base + ; idx = λ N v F → applyF F (vnt₁ N v) + ; obs = λ F N i → i F + ; obs-ok = λ F N v → refl } + +twoState : (c : Fam → N₁ → Base) → (∀ F N → fNt₁ F N ≡ inl (c F N)) → StateScheme +twoState c h = record + { Idx = Unit + ; idx = λ N v → tt + ; obs = λ F N i → c F N + ; obs-ok = λ F N v → sym (cong (λ x → resB x (λ G → applyF G v)) (h F N)) } diff --git a/verification/proofs/agda/Wager/Trans/Simulation.agda b/verification/proofs/agda/Wager/Trans/Simulation.agda new file mode 100644 index 0000000..a186c22 --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/Simulation.agda @@ -0,0 +1,240 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on coercions, terms and values. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The erased translation behaves as the erased source (Stage 4: T3 and +-- the behaviour part of T5). +-- +-- 1. The transformer of a coercion does not change the erased +-- behaviour: if the erasure of t evaluates to a value related to +-- v, then the erasure of the transformed t also does (`CoRel`). +-- A trope transition vanishes in the erasure, so only the +-- functorial maps need an argument. +-- 2. The erasure of a source term and the erasure of its translation +-- evaluate to related values (`fund`). +open import Cubical.Foundations.Prelude +open import Wager.FC.Signature +open import Wager.Grade.Algebra +import Wager.Trans.Scheme + +module Wager.Trans.Simulation + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (ops : GradeOps R) where + +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) +open import Cubical.Data.Sigma using (_×_; _,_; fst; snd; Σ-syntax) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Role.Role +open import Wager.Erased.Untyped using (ETy; ebase; earr; eprod; esum) +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +open import Wager.FC.Term SS +open import Wager.FC.RoleSoundness SS using (rep-sound) +open import Wager.Trans.Target SS Sc ops using (T; TB; Inst; wrap; unwrap; arr) +open GradeOps ops using (𝟙) +open import Wager.Trans.Coercion SS Sc ops +open import Wager.Erased.LogRel litTy + +private + variable + n : ℕ + +-- A transformer keeps the erased behaviour at the erased type a. +CoRel : ETy Base → Tr → Type +CoRel a f = ∀ {n} (v : UVal) {ρ : UEnv n} (t : Tm n) → + 𝒞 a v ρ (eraseT t) → 𝒞 a v ρ (eraseT (f t)) + +CoRelIso : ETy Base → Iso → Type +CoRelIso a i = CoRel a (fwd i) × CoRel a (bwd i) + +------------------------------------------------------------------------ +-- Each building block keeps the erased behaviour. + +id-rel : ∀ {a} → CoRelIso a idIso +id-rel = (λ v t h → h) , (λ v t h → h) + +swap-rel : ∀ {a i} → CoRelIso a i → CoRelIso a (swapIso i) +swap-rel (f , g) = g , f + +comp-rel : ∀ {a i j} → CoRelIso a i → CoRelIso a j → CoRelIso a (compIso i j) +comp-rel {i = i} {j = j} (f , g) (f' , g') = + (λ v t h → f' v (fwd i t) (f v t h)) + , (λ v t h → g v (bwd j t) (g' v t h)) + +-- A trope transition vanishes in the erasure. +step-rel : ∀ {a} (x : Inst) → CoRelIso a (stepIso x) +step-rel x = (λ v t h → h) , (λ v t h → h) + +arrMap-rel : ∀ {a b} X A (h g : Tr) → CoRel a h → CoRel b g → + CoRel (earr a b) (arrMap X A h g) +arrMap-rel X A h g ch cg _ {ρ = ρ} t (_ , dt , r-clo {ρ' = ρg} hfg) = + _ , ⇓-app ⇓-lam dt ⇓-lam + , r-clo (λ v w hvw → + let (w' , dw' , hvw') = ch v (tvar zero) (w , ⇓-var zero , hvw) + (r , s , dr , ds , hrs) = hfg v w' hvw' + (s' , ds' , hrs') = cg r (tapp (tvar (suc zero)) (h (tvar zero))) + (s , ⇓-app (⇓-var (suc zero)) dw' ds , hrs) + in r , s' , dr , ds' , hrs') + +arrIso-rel : ∀ {a b} A A' B B' i j → CoRelIso a i → CoRelIso b j → + CoRelIso (earr a b) (arrIso A A' B B' i j) +arrIso-rel A A' B B' i j (f , g) (f' , g') = + arrMap-rel (arr 𝟙 A B) A' (bwd i) (fwd j) g f' + , arrMap-rel (arr 𝟙 A' B') A (fwd i) (bwd j) f g' + +prodMap-rel : ∀ {a b} {f g : Tr} → CoRel a f → CoRel b g → CoRel (eprod a b) (prodMap f g) +prodMap-rel cf cg _ t (_ , dt , r-pair {v₁ = v₁} {v₂ = v₂} {w₁ = w₁} {w₂ = w₂} h₁ h₂) = + let (w₁' , d₁ , h₁') = cf v₁ (tvar (suc zero)) (w₁ , ⇓-var (suc zero) , h₁) + (w₂' , d₂ , h₂') = cg v₂ (tvar zero) (w₂ , ⇓-var zero , h₂) + in vpair w₁' w₂' , ⇓-letp dt (⇓-pair d₁ d₂) , r-pair h₁' h₂' + +prodIso-rel : ∀ {a b i j} → CoRelIso a i → CoRelIso b j → CoRelIso (eprod a b) (prodIso i j) +prodIso-rel {i = i} {j = j} (f , g) (f' , g') = + prodMap-rel {f = fwd i} {g = fwd j} f f' + , prodMap-rel {f = bwd i} {g = bwd j} g g' + +sumMap-rel : ∀ {a b} {f g : Tr} → CoRel a f → CoRel b g → CoRel (esum a b) (sumMap f g) +sumMap-rel cf cg _ t (_ , dt , r-inl {v = v} {w = w} h) = + let (w' , d , h') = cf v (tvar zero) (w , ⇓-var zero , h) + in vinl w' , ⇓-casel dt (⇓-inl d) , r-inl h' +sumMap-rel cf cg _ t (_ , dt , r-inr {v = v} {w = w} h) = + let (w' , d , h') = cg v (tvar zero) (w , ⇓-var zero , h) + in vinr w' , ⇓-caser dt (⇓-inr d) , r-inr h' + +sumIso-rel : ∀ {a b i j} → CoRelIso a i → CoRelIso b j → CoRelIso (esum a b) (sumIso i j) +sumIso-rel {i = i} {j = j} (f , g) (f' , g') = + sumMap-rel {f = fwd i} {g = fwd j} f f' + , sumMap-rel {f = bwd i} {g = bwd j} g g' + +-- The map of a body, at the erased type of the body. +body-rel : ∀ β v {e} X Y i → CoRelIso e i → CoRelIso (erB β v e) (bodyIso β X Y i) +body-rel bvar v X Y i c = c +body-rel (bbase b) v X Y i c = id-rel +body-rel (barr β γ) v X Y i c = + arrIso-rel (TB β X) (TB β Y) (TB γ X) (TB γ Y) (bodyIso β X Y i) (bodyIso γ X Y i) + (body-rel β v X Y i c) (body-rel γ v X Y i c) +body-rel (bprod β γ) v X Y i c = + prodIso-rel {i = bodyIso β X Y i} {j = bodyIso γ X Y i} (body-rel β v X Y i c) (body-rel γ v X Y i c) +body-rel (bsum β γ) v X Y i c = + sumIso-rel {i = bodyIso β X Y i} {j = bodyIso γ X Y i} (body-rel β v X Y i c) (body-rel γ v X Y i c) +body-rel (bfam F β) v X Y i c = id-rel + +------------------------------------------------------------------------ +-- The transformer of a coercion keeps the erased behaviour. The role +-- check is used to compare the erased types of the two sides. + +module _ (wr : WellRoled) where + + co-rel : ∀ r {τ σ} (γ : Co r τ σ) → CoRelIso (er τ) (coI r γ) + co-rel nom γ = id-rel + co-rel ph γ = id-rel + co-rel rep (c-sym {τ = τ} {σ = σ} γ) = + subst (λ a → CoRelIso a (swapIso (coI rep γ))) (rep-sound wr γ) (swap-rel {i = coI rep γ} (co-rel rep γ)) + co-rel rep (c-trans {τ = τ} γ δ) = + comp-rel {i = coI rep γ} {j = coI rep δ} (co-rel rep γ) + (subst (λ a → CoRelIso a (coI rep δ)) (sym (rep-sound wr γ)) (co-rel rep δ)) + co-rel rep (c-sub γ) = id-rel + co-rel rep (c-arr {τ = τ} {τ' = τ'} {σ = σ} {σ' = σ'} γ δ) = + arrIso-rel (T τ) (T τ') (T σ) (T σ') (coI rep γ) (coI rep δ) (co-rel rep γ) (co-rel rep δ) + co-rel rep (c-prod γ δ) = prodIso-rel {i = coI rep γ} {j = coI rep δ} (co-rel rep γ) (co-rel rep δ) + co-rel rep (c-sum γ δ) = sumIso-rel {i = coI rep γ} {j = coI rep δ} (co-rel rep γ) (co-rel rep δ) + co-rel rep (c-nt₁ {τ = τ} {σ = σ} N γ) = + let (f , g) = body-rel (body N) (ev τ) (T τ) (T σ) (coI (mulG rep (role N)) γ) + (co-rel (mulG rep (role N)) γ) + in (λ v t h → f v (step (unwrap , inr (N , τ)) t) h) + , (λ v t h → g v (step (unwrap , inr (N , σ)) t) h) + co-rel rep (c-ax₀ N) = step-rel (inl N) + co-rel rep (c-ax₁ N τ) = step-rel (inr (N , τ)) + + ---------------------------------------------------------------------- + -- T3. + + private + idV : UVal + idV = vclo ∅ᵉ (uvar zero) + + -- The erased coercion function is related to the identity function. + coerce-identity : ∀ {τ σ} (γ : Co rep τ σ) → + Σ[ f ∈ UVal ] (∅ᵉ ⊢ eraseT (coerceT γ) ⇓ f) × 𝒱 (earr (er τ) (er τ)) idV f + coerce-identity γ = + _ , ⇓-lam + , r-clo (λ v w h → + let (w' , d , h') = fst (co-rel rep γ) v (tvar zero) (w , ⇓-var zero , h) + in v , w' , ⇓-var zero , d , h') + + -- At a first-order type the erased coercion gives its argument back. + coerce-identity-fo : ∀ {τ σ} (γ : Co rep τ σ) → FO (er τ) → ∀ v → 𝒱 (er τ) v v → + Σ[ w ∈ UVal ] ((v ∷ᵉ ∅ᵉ) ⊢ eraseT (fwd (coI rep γ) (tvar zero)) ⇓ w) × (w ≡ v) + coerce-identity-fo γ fo v h = + let (w , d , h') = fst (co-rel rep γ) v (tvar zero) (v , ⇓-var zero , h) + in w , d , sym (𝒱-fo fo h') + + ---------------------------------------------------------------------- + -- T5, behaviour. + + private + EnvRel : SCx n → UEnv n → UEnv n → Type + EnvRel Γ ρ ρ' = ∀ i → 𝒱 (er (Γ i)) (ρ i) (ρ' i) + + env-ext : ∀ {Γ : SCx n} {ρ ρ' : UEnv n} {v w} τ → + EnvRel Γ ρ ρ' → 𝒱 (er τ) v w → EnvRel (Γ ▹ˢ τ) (v ∷ᵉ ρ) (w ∷ᵉ ρ') + env-ext τ h hvw zero = hvw + env-ext τ h hvw (suc i) = h i + + fund : ∀ {Γ : SCx n} {τ} (e : STm Γ τ) {ρ ρ' : UEnv n} → EnvRel Γ ρ ρ' → + ℰ (er τ) ρ (eraseTm e) ρ' (eraseT (tr e)) + fund (svar i) h = _ , ⇓-var i , _ , ⇓-var i , h i + fund (slam {τ = τ} b) h = + _ , ⇓-lam , _ , ⇓-lam + , r-clo (λ v w hvw → + let (r , dr , s , ds , hrs) = fund b (env-ext τ h hvw) + in r , s , dr , ds , hrs) + fund (sapp f a) h with fund f h | fund a h + ... | _ , df , _ , df' , r-clo hf | va , da , wa , da' , ha = + let (r , s , dr , ds , hrs) = hf va wa ha + in r , ⇓-app df da dr , s , ⇓-app df' da' ds , hrs + fund (spair s t) h = + let (v₁ , d₁ , w₁ , d₁' , h₁) = fund s h + (v₂ , d₂ , w₂ , d₂' , h₂) = fund t h + in vpair v₁ v₂ , ⇓-pair d₁ d₂ , vpair w₁ w₂ , ⇓-pair d₁' d₂' , r-pair h₁ h₂ + fund (sletp {τ = τ} {σ = σ} s b) h with fund s h + ... | _ , ds , _ , ds' , r-pair h₁ h₂ = + let (r , dr , r' , dr' , hr) = fund b (env-ext σ (env-ext τ h h₁) h₂) + in r , ⇓-letp ds dr , r' , ⇓-letp ds' dr' , hr + fund (sinl t) h = + let (v , d , w , d' , hv) = fund t h + in vinl v , ⇓-inl d , vinl w , ⇓-inl d' , r-inl hv + fund (sinr t) h = + let (v , d , w , d' , hv) = fund t h + in vinr v , ⇓-inr d , vinr w , ⇓-inr d' , r-inr hv + fund (scase {τ = τ} {σ = σ} s l r) h with fund s h + ... | _ , ds , _ , ds' , r-inl hv = + let (x , dx , x' , dx' , hx) = fund l (env-ext τ h hv) + in x , ⇓-casel ds dx , x' , ⇓-casel ds' dx' , hx + ... | _ , ds , _ , ds' , r-inr hv = + let (x , dx , x' , dx' , hx) = fund r (env-ext σ h hv) + in x , ⇓-caser ds dx , x' , ⇓-caser ds' dx' , hx + fund (slit ℓ) h = vlit ℓ , ⇓-lit , vlit ℓ , ⇓-lit , r-lit ℓ refl + fund (cast {τ = τ} {σ = σ} γ e) {ρ' = ρ'} h = + let (v , d , c) = fund e h + in v , d , subst (λ a → 𝒞 a v ρ' (eraseT (tr (cast γ e)))) (rep-sound wr γ) + (fst (co-rel rep γ) v (tr e) c) + + -- A closed program. + behaviour : ∀ {τ} (e : STm ∅ˢ τ) → + Σ[ v ∈ UVal ] Σ[ w ∈ UVal ] + (∅ᵉ ⊢ eraseTm e ⇓ v) × (∅ᵉ ⊢ eraseT (tr e) ⇓ w) × 𝒱 (er τ) v w + behaviour e = + let (v , d , w , d' , h) = fund e {ρ = ∅ᵉ} {ρ' = ∅ᵉ} (λ ()) + in v , w , d , d' , h + + behaviour-fo : ∀ {τ} (e : STm ∅ˢ τ) → FO (er τ) → + Σ[ v ∈ UVal ] (∅ᵉ ⊢ eraseTm e ⇓ v) × (∅ᵉ ⊢ eraseT (tr e) ⇓ v) + behaviour-fo e fo = + let (v , w , d , d' , h) = behaviour e + in v , d , subst (λ x → ∅ᵉ ⊢ eraseT (tr e) ⇓ x) (sym (𝒱-fo fo h)) d' diff --git a/verification/proofs/agda/Wager/Trans/Target.agda b/verification/proofs/agda/Wager/Trans/Target.agda new file mode 100644 index 0000000..c82777f --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/Target.agda @@ -0,0 +1,136 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The target signature of the translation, and the translation of +-- types (Stage 4). +-- +-- source target +-- base type b base b +-- τ → σ arr 𝟙 (T τ) (T σ) +-- pair, sum ⊗, ⊕ +-- newtype N (no parameter) capp (state of N) (representation) +-- newtype N τ capp (state of N at the index of τ) +-- (the translated body of N at τ) +-- type-level function F τ papp F (T τ) +-- +-- A newtype is thus a type in a trope state: `A@s` is `capp s A`, and +-- the carrier A is the representation. Each state has the grade +-- representational, and each primitive has the grade nominal. +-- +-- The trope operations are `wrap` and `unwrap`, for each instance of a +-- newtype. No other operation exists, and no rule is added. +open import Cubical.Foundations.Prelude +open import Wager.FC.Signature +open import Wager.Grade.Algebra +import Wager.Trans.Scheme + +module Wager.Trans.Target + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (ops : GradeOps R) where + +open import Cubical.Data.Bool.Base using (true) +open import Cubical.Data.Sigma using (_×_; _,_; fst; snd) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Role.Role +open import Wager.Role.Signature +open import Wager.L1.Signature +open import Wager.Erased.Untyped using (ETy; ebase; earr; eprod; esum) +open import Wager.FC.Types SS +open Wager.Trans.Scheme SS +open StateScheme Sc public +open GradeOps ops using (𝟙) +import Wager.L1.Syntax +import Wager.L2.Signature + +-- The states: one for each newtype with no parameter, and one for each +-- newtype with a parameter and each index. +State : Type +State = N₀ ⊎ (N₁ × Idx) + +private + onConT : Fam → State → Base ⊎ Fam + onConT F (inl N) = inl (fNt₀ F N) + onConT F (inr (N , i)) = inl (obs F N i) + +tRoleSig : RoleSig +tRoleSig = record + { TG = R ; Base = Base + ; Con₁ = State ; cgrade = λ _ → rep ; isNewtype = λ _ → true + ; Prim = Fam ; pgrade = λ _ → nom + ; onBase = fBase ; onCon = onConT ; onOther = fOther } + +tSig : Sig +tSig = toSig tRoleSig + +open Wager.L1.Syntax tSig hiding (Base) public +open Wager.L2.Signature tSig public + +------------------------------------------------------------------------ +-- The translation of types. + +TE : ETy Base → Ty [] ★ +TE (ebase b) = base b +TE (earr a b) = arr 𝟙 (TE a) (TE b) +TE (eprod a b) = TE a ⊗ TE b +TE (esum a b) = TE a ⊕ TE b + +-- The body of a newtype, at a type for the parameter. The context is +-- general: with a type variable for the parameter, the body is a +-- type-level function of the target. +TB : ∀ {Γ} → Body Base Fam → Ty Γ ★ → Ty Γ ★ +TB bvar A = A +TB (bbase b) A = base b +TB (barr β γ) A = arr 𝟙 (TB β A) (TB γ A) +TB (bprod β γ) A = TB β A ⊗ TB γ A +TB (bsum β γ) A = TB β A ⊕ TB γ A +TB (bfam F β) A = papp F (TB β A) + +T : STy → Ty [] ★ +T (sbase b) = base b +T (τ ⇒ˢ σ) = arr 𝟙 (T τ) (T σ) +T (τ ×ˢ σ) = T τ ⊗ T σ +T (τ +ˢ σ) = T τ ⊕ T σ +T (nt₀ N) = capp (inl N) (TE (rep₀ N)) +T (nt₁ N τ) = capp (inr (N , idx N (ev τ))) (TB (body N) (T τ)) +T (fam F τ) = papp F (T τ) + +-- The body of the newtype N as a type-level function of the target, +-- with the grade g for its parameter. +bodyFun : N₁ → (g : Role) → Ty [] (★ ⇒[ g ] ★) +bodyFun N g = lam (TB (body N) (var vz)) + +------------------------------------------------------------------------ +-- The trope operations. + +data Dir : Type where + wrap unwrap : Dir + +-- An instance of a newtype. +Inst : Type +Inst = N₀ ⊎ (N₁ × STy) + +stateOf : Inst → State +stateOf (inl N) = inl N +stateOf (inr (N , τ)) = inr (N , idx N (ev τ)) + +carrierOf : Inst → Ty [] ★ +carrierOf (inl N) = TE (rep₀ N) +carrierOf (inr (N , τ)) = TB (body N) (T τ) + +private + fromOp toOp : Dir × Inst → Maybe State + fromOp (wrap , x) = nothing + fromOp (unwrap , x) = just (stateOf x) + toOp (wrap , x) = just (stateOf x) + toOp (unwrap , x) = nothing + +-- wrap: carrier → carrier @ state +-- unwrap: carrier @ state → carrier +tTSig : TSig +tTSig = record + { Lit = Lit ; litTy = litTy + ; Op = Dir × Inst ; carrier = λ o → carrierOf (snd o) + ; from = fromOp ; to = toOp } diff --git a/verification/proofs/agda/Wager/Trans/TwoState.agda b/verification/proofs/agda/Wager/Trans/TwoState.agda new file mode 100644 index 0000000..0de90e7 --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/TwoState.agda @@ -0,0 +1,53 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- What a translation of types must do, and what "two-state trope" +-- means (Stage 4, definitions only). +-- +-- `Translation S` is a translation of the types of the source +-- signature SS into the target signature S that keeps three properties: +-- a nominal coercion becomes conversion; +-- a type-level function becomes a type-level function of the target; +-- two different base types stay different. +-- `TwoState` adds: each newtype with a parameter is ONE trope state on +-- its representation (the state does not depend on the parameter). +-- This is the form of Stage 2: `Int@age` and `Int@raw`. +open import Wager.FC.Signature + +module Wager.Trans.TwoState (SS : SSig) where + +open import Cubical.Foundations.Prelude +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Role.Role +open import Wager.L1.Signature +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +import Wager.L1.Syntax +import Wager.L1.Conversion + +module _ (S : Sig) where + open Wager.L1.Syntax S hiding (Base) + open Wager.L1.Conversion S + + record Translation : Type where + field + T : STy → Ty [] ★ + -- A nominal coercion becomes conversion. + T-nom : ∀ {τ σ} → Co nom τ σ → DefEq (T τ) (T σ) + -- A type-level function becomes a type-level function of the target. + FunG : Fam → KG + Fun : (f : Fam) → Ty [] (★ ⇒[ FunG f ] ★) + T-fam : ∀ f τ → DefEq (T (fam f τ)) (app (Fun f) (T τ)) + -- Two different base types stay different. + T-base : ∀ b b' → ¬ (b ≡ b') → ¬ DefEq (T (sbase b)) (T (sbase b')) + + record TwoState (t : Translation) : Type where + open Translation t + field + -- One state for each newtype with a parameter. + state : N₁ → Con₁ + -- The newtype is that state on the translation of its representation. + T-nt : ∀ N τ → DefEq (T (nt₁ N τ)) (capp (state N) (T (inst (body N) τ))) diff --git a/verification/proofs/agda/Wager/Trans/TwoStateProofs.agda b/verification/proofs/agda/Wager/Trans/TwoStateProofs.agda new file mode 100644 index 0000000..619bee7 --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/TwoStateProofs.agda @@ -0,0 +1,130 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on kinded syntax. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- Two-state tropes are not enough (Stage 4). +-- +-- 1. The translation of Wager.Trans meets the conditions of +-- `Translation`, for each state scheme. +-- 2. With the two-state scheme it is also a two-state translation. +-- 3. The signature `taggedS rep` has NO two-state translation, into +-- any target signature. The reason: `Tag Int` and `Tag Bool` have +-- one representation, so a two-state translation gives them one +-- target type. The function F tells them apart, so Bool and Char +-- become convertible. +module Wager.Trans.TwoStateProofs where + +open import Cubical.Foundations.Prelude +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Sigma using (_×_; _,_; Σ-syntax) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) +open import Cubical.Relation.Nullary using (¬_) + +open import Wager.Role.Role +open import Wager.Grade.Algebra +open import Wager.L1.Signature +open import Wager.FC.Signature +open import Wager.FC.Tagged +import Wager.FC.Types +import Wager.FC.Coercion +import Wager.L1.Conversion +import Wager.L1.Normal +import Wager.L1.Eval +import Wager.L1.Equality +import Wager.Trans.Scheme +import Wager.Trans.Target +import Wager.Trans.Nominal +import Wager.Trans.TwoState + +------------------------------------------------------------------------ +-- Parts 1 and 2. + +module _ (SS : SSig) {R : Type} (ops : GradeOps R) where + open Wager.FC.Types SS + open Wager.Trans.Scheme SS + open Wager.Trans.TwoState SS + + module _ (Sc : StateScheme) where + open Wager.Trans.Target SS Sc ops + open Wager.Trans.Nominal SS Sc ops + open Wager.L1.Conversion tSig + open Wager.L1.Normal tSig + open Wager.L1.Equality tSig + + private + getB : Base → Nf [] ★ → Base + getB d (nbase b) = b + getB d _ = d + + scheme-translation : Translation tSig + scheme-translation = record + { T = T + ; T-nom = nominal-defeq + ; FunG = λ _ → nom + ; Fun = λ f → lam (papp f (var vz)) + ; T-fam = λ f τ → d-sym (d-beta (papp f (var vz)) (T τ)) + ; T-base = λ b b' ne e → ne (cong (getB b) (defEq→nf e)) } + + row-translation : Translation (Wager.Trans.Target.tSig SS rowScheme ops) + row-translation = scheme-translation rowScheme + + two-state-translation : + (c : Fam → N₁ → Base) (h : ∀ F N → fNt₁ F N ≡ inl (c F N)) → + Σ[ t ∈ Translation (Wager.Trans.Target.tSig SS (twoState c h) ops) ] + TwoState (Wager.Trans.Target.tSig SS (twoState c h) ops) t + two-state-translation c h = + scheme-translation Sc + , record { state = λ N → inr (N , tt) + ; T-nt = λ N τ → ≡→DefEq (cong (capp (inr (N , tt))) (sym (T-inst (body N) τ))) } + where + Sc = twoState c h + open Wager.Trans.Target SS Sc ops + open Wager.Trans.Nominal SS Sc ops + open Wager.L1.Conversion tSig + +------------------------------------------------------------------------ +-- Part 3. + +private + SS₀ = taggedS rep + + IsBool : BaseName → Type + IsBool bBool = Unit + IsBool _ = ⊥ + + bBool≢bChar : ¬ (bBool ≡ bChar) + bBool≢bChar p = subst IsBool p tt + +module _ (S : Sig) where + open Wager.FC.Types SS₀ + open Wager.FC.Coercion SS₀ + open Wager.Trans.TwoState SS₀ + open Wager.L1.Conversion S + open TTypes rep + + private + -- F (Tag Int) ~N Bool and F (Tag Bool) ~N Char. + f-tag-int : Co nom (F (Tag sInt)) sBool + f-tag-int = c-trans (c-fnt₁ fE tagE sInt) (c-fbase gE bInt) + + f-tag-bool : Co nom (F (Tag sBool)) sChar + f-tag-bool = c-trans (c-fnt₁ fE tagE sBool) (c-fbase gE bBool) + + no-two-state : (t : Translation S) → ¬ TwoState S t + no-two-state t ts = + T-base bBool bChar bBool≢bChar + (d-trans (d-sym (T-nom f-tag-int)) + (d-trans (T-fam fE (Tag sInt)) + (d-trans (d-app d-refl tag-eq) + (d-trans (d-sym (T-fam fE (Tag sBool))) + (T-nom f-tag-bool))))) + where + open Translation t + open TwoState ts + -- The two-state form gives `Tag Int` and `Tag Bool` one target type. + tag-eq : DefEq (T (Tag sInt)) (T (Tag sBool)) + tag-eq = d-trans (T-nt tagE sInt) (d-sym (T-nt tagE sBool)) diff --git a/verification/proofs/agda/Wager/Trans/Typing.agda b/verification/proofs/agda/Wager/Trans/Typing.agda new file mode 100644 index 0000000..cd16fbd --- /dev/null +++ b/verification/proofs/agda/Wager/Trans/Typing.agda @@ -0,0 +1,283 @@ +{-# OPTIONS --cubical --safe #-} +-- Forced by cubical-0.9 (InfectiveImport). No coinduction is used. +{-# OPTIONS --guardedness #-} +-- DESIGN-CHOICES.adoc, DC-0.3: matches on coercions and on typed terms. +{-# OPTIONS -WnoUnsupportedIndexedMatch #-} +-- SPDX-License-Identifier: MPL-2.0 +-- +-- The translation preserves typing (Stage 4, the typing part of T5). +-- +-- 1. The transformer of a representational coercion maps a term of +-- the type `T τ` to a term of the type `T σ`, with the same usage +-- vector. This holds in each grade algebra: a coercion uses each +-- variable one time. +-- 2. The translation of a source term of the type τ has the type +-- `T τ`. This holds in each grade algebra in which the grade 𝟙 is +-- unrestricted (𝟘 ≤ 𝟙 and 𝟙 + 𝟙 ≤ 𝟙), because a source term has no +-- usage discipline. +open import Cubical.Foundations.Prelude +open import Wager.FC.Signature +open import Wager.Grade.Algebra +import Wager.Trans.Scheme + +module Wager.Trans.Typing + (SS : SSig) (Sc : Wager.Trans.Scheme.StateScheme SS) + {R : Type} (A : GradeAlgebra R) where + +open import Cubical.Data.Bool.Base using (true; false) +open import Cubical.Data.Empty as ⊥ using (⊥) +open import Cubical.Data.Unit using (Unit; tt) +open import Cubical.Data.Nat.Base using (ℕ; zero; suc) +open import Cubical.Data.FinData.Base using (Fin; zero; suc) +open import Cubical.Data.Sigma using (_×_; _,_; fst; snd) +open import Cubical.Data.Sum.Base using (_⊎_; inl; inr) + +open import Wager.Grade.Finite using (false≢true) +open import Wager.Role.Role +open GradeAlgebra A +open import Wager.FC.Types SS +open import Wager.FC.Coercion SS +open import Wager.FC.Term SS +open import Wager.FC.RoleSoundness SS using (nomZ-l; nomZ-r; nomZ-idem) +open import Wager.Trans.Target SS Sc ops +open import Wager.Trans.Nominal SS Sc ops +open import Wager.Trans.Coercion SS Sc ops +open import Wager.L1.Conversion tSig +open import Wager.L2.Typing tSig tTSig ops + using ( Usage; 0ᵘ; _+ᵘ_; _·ᵘ_; _≤ᵘ_; _▹_; unit; Cx; _▹ᶜ_; _▸_⊢_∶_ + ; t-var; t-lam; t-app; t-pair; t-letp; t-inj₁; t-inj₂; t-case + ; t-lit; t-step; t-conv; t-sub ) +open import Wager.L2.Renaming tSig tTSig A using (castU; castT) + +private + variable + n : ℕ + X Y Z X' Y' : Ty [] ★ + +-- A transformer that maps a term of the type X to a term of the type +-- Y, with the same usage vector. +TyTr : (X Y : Ty [] ★) → Tr → Type +TyTr X Y f = ∀ {n} {γ : Usage n} {Γ : Cx n} {t : Tm n} → + γ ▸ Γ ⊢ t ∶ X → γ ▸ Γ ⊢ f t ∶ Y + +IsoTyped : Ty [] ★ → Ty [] ★ → Iso → Type +IsoTyped X Y i = TyTr X Y (fwd i) × TyTr Y X (bwd i) + +------------------------------------------------------------------------ +-- The typing of each building block. + +id-typed : DefEq X Y → IsoTyped X Y idIso +id-typed e = (λ d → t-conv d e) , (λ d → t-conv d (d-sym e)) + +swap-typed : ∀ {i} → IsoTyped X Y i → IsoTyped Y X (swapIso i) +swap-typed (f , g) = g , f + +comp-typed : ∀ {i j} → IsoTyped X Y i → IsoTyped Y Z j → IsoTyped X Z (compIso i j) +comp-typed (f , g) (f' , g') = (λ d → f' (f d)) , (λ d → g (g' d)) + +arrMap-typed : ∀ {h g : Tr} → TyTr X' X h → TyTr Y Y' g → + TyTr (arr 𝟙 X Y) (arr 𝟙 X' Y') (arrMap (arr 𝟙 X Y) X' h g) +arrMap-typed th tg {γ = γ} d = + castU (funExt λ i → zero-add (𝟙 · γ i) ∙ one-mul (γ i)) + (t-app + (t-lam {γ = 0ᵘ} + (t-lam {γ = 0ᵘ ▹ 𝟙} + (castU eq (tg (t-app (t-var (suc zero)) (th (t-var zero))))))) + d) + where + eq : ∀ {n} → (unit {n = suc (suc n)} (suc zero) +ᵘ (𝟙 ·ᵘ unit zero)) ≡ (0ᵘ ▹ 𝟙 ▹ 𝟙) + eq = funExt λ { zero → zero-add (𝟙 · 𝟙) ∙ one-mul 𝟙 + ; (suc zero) → cong (𝟙 +_) (mul-zero 𝟙) ∙ add-zero 𝟙 + ; (suc (suc i)) → cong (𝟘 +_) (mul-zero 𝟙) ∙ add-zero 𝟘 } + +arrIso-typed : ∀ {i j} → IsoTyped X X' i → IsoTyped Y Y' j → + IsoTyped (arr 𝟙 X Y) (arr 𝟙 X' Y') (arrIso X X' Y Y' i j) +arrIso-typed (f , g) (f' , g') = arrMap-typed g f' , arrMap-typed f g' + +prodMap-typed : ∀ {f g : Tr} → TyTr X X' f → TyTr Y Y' g → + TyTr (X ⊗ Y) (X' ⊗ Y') (prodMap f g) +prodMap-typed tf tg {γ = γ} d = + castU (funExt λ i → add-zero (γ i)) + (t-letp {δ = 0ᵘ} d + (castU eq (t-pair (tf (t-var (suc zero))) (tg (t-var zero))))) + where + eq : ∀ {n} → (unit {n = suc (suc n)} (suc zero) +ᵘ unit zero) ≡ (0ᵘ ▹ 𝟙 ▹ 𝟙) + eq = funExt λ { zero → zero-add 𝟙 + ; (suc zero) → add-zero 𝟙 + ; (suc (suc i)) → add-zero 𝟘 } + +prodIso-typed : ∀ {i j} → IsoTyped X X' i → IsoTyped Y Y' j → + IsoTyped (X ⊗ Y) (X' ⊗ Y') (prodIso i j) +prodIso-typed (f , g) (f' , g') = prodMap-typed f f' , prodMap-typed g g' + +sumMap-typed : ∀ {f g : Tr} → TyTr X X' f → TyTr Y Y' g → + TyTr (X ⊕ Y) (X' ⊕ Y') (sumMap f g) +sumMap-typed tf tg {γ = γ} d = + castU (funExt λ i → add-zero (γ i)) + (t-case {δ = 0ᵘ} d (t-inj₁ (tf (t-var zero))) (t-inj₂ (tg (t-var zero)))) + +sumIso-typed : ∀ {i j} → IsoTyped X X' i → IsoTyped Y Y' j → + IsoTyped (X ⊕ Y) (X' ⊕ Y') (sumIso i j) +sumIso-typed (f , g) (f' , g') = sumMap-typed f f' , sumMap-typed g g' + +-- The two trope transitions of a newtype instance, by rule `t-step`. +step-typed : (x : Inst) → IsoTyped (capp (stateOf x) (carrierOf x)) (carrierOf x) (stepIso x) +step-typed x = (λ d → t-step (unwrap , x) d) , (λ d → t-step (wrap , x) d) + +------------------------------------------------------------------------ +-- The map of a body, for a parameter that is used at the role d. + +module _ {d : Role} (hn : leR nom d ≡ true → DefEq X Y) where + + -- Below a type-level function the two instances are convertible. + body-defeq : ∀ β → leR (mulZ nom (roleOf β)) d ≡ true → DefEq (TB β X) (TB β Y) + body-defeq bvar le = hn le + body-defeq (bbase b) le = d-refl + body-defeq (barr β γ) le = + d-arr (body-defeq β (leR-trans _ _ _ (nomZ-l (roleOf β) (roleOf γ)) le)) + (body-defeq γ (leR-trans _ _ _ (nomZ-r (roleOf β) (roleOf γ)) le)) + body-defeq (bprod β γ) le = + d-prod (body-defeq β (leR-trans _ _ _ (nomZ-l (roleOf β) (roleOf γ)) le)) + (body-defeq γ (leR-trans _ _ _ (nomZ-r (roleOf β) (roleOf γ)) le)) + body-defeq (bsum β γ) le = + d-sum (body-defeq β (leR-trans _ _ _ (nomZ-l (roleOf β) (roleOf γ)) le)) + (body-defeq γ (leR-trans _ _ _ (nomZ-r (roleOf β) (roleOf γ)) le)) + body-defeq (bfam F β) le = + d-papp (body-defeq β (subst (λ r → leR r d ≡ true) (nomZ-idem (roleOf β)) le)) + + module _ {i : Iso} (hv : leR rep d ≡ true → IsoTyped X Y i) where + + body-typed : ∀ β → leR (roleOf β) d ≡ true → + IsoTyped (TB β X) (TB β Y) (bodyIso β X Y i) + body-typed bvar le = hv le + body-typed (bbase b) le = id-typed d-refl + body-typed (barr β γ) le = + arrIso-typed (body-typed β (leR-trans _ _ _ (max-upper-l (roleOf β) (roleOf γ)) le)) + (body-typed γ (leR-trans _ _ _ (max-upper-r (roleOf β) (roleOf γ)) le)) + body-typed (bprod β γ) le = + prodIso-typed (body-typed β (leR-trans _ _ _ (max-upper-l (roleOf β) (roleOf γ)) le)) + (body-typed γ (leR-trans _ _ _ (max-upper-r (roleOf β) (roleOf γ)) le)) + body-typed (bsum β γ) le = + sumIso-typed (body-typed β (leR-trans _ _ _ (max-upper-l (roleOf β) (roleOf γ)) le)) + (body-typed γ (leR-trans _ _ _ (max-upper-r (roleOf β) (roleOf γ)) le)) + body-typed (bfam F β) le = id-typed (d-papp (body-defeq β le)) + +------------------------------------------------------------------------ +-- The typing of a translated coercion. + +-- What the translation of a coercion at the role r gives. +SemTy : Role → STy → STy → Iso → Type +SemTy nom τ σ i = DefEq (T τ) (T σ) +SemTy rep τ σ i = IsoTyped (T τ) (T σ) i +SemTy ph τ σ i = Unit + +module _ (wr : WellRoled) where + + private + nt-wrap : ∀ N {τ σ i} → + IsoTyped (TB (body N) (T τ)) (TB (body N) (T σ)) (bodyIso (body N) (T τ) (T σ) i) → + IsoTyped (T (nt₁ N τ)) (T (nt₁ N σ)) (ntIso N τ σ i) + nt-wrap N {τ} {σ} (f , g) = + (λ d → t-step (wrap , inr (N , σ)) (f (t-step (unwrap , inr (N , τ)) d))) + , (λ d → t-step (wrap , inr (N , τ)) (g (t-step (unwrap , inr (N , σ)) d))) + + -- Congruence for a newtype. The role check gives: the inferred + -- role of the body is at most the role d of the premise. + nt-typed : ∀ N d {τ σ} → leR (roleOf (body N)) d ≡ true → + (γ : Co d τ σ) → SemTy d τ σ (coI d γ) → + IsoTyped (T (nt₁ N τ)) (T (nt₁ N σ)) (ntIso N τ σ (coI d γ)) + nt-typed N rep le γ sem = + nt-wrap N (body-typed (λ p → ⊥.rec (false≢true p)) {i = coI rep γ} (λ _ → sem) (body N) le) + nt-typed N nom le γ sem = + nt-wrap N (body-typed (λ _ → sem) {i = idIso} (λ _ → id-typed sem) (body N) le) + nt-typed N ph le γ sem = + nt-wrap N (body-typed (λ p → ⊥.rec (false≢true p)) {i = idIso} + (λ p → ⊥.rec (false≢true p)) (body N) le) + + coI-typed : ∀ r {τ σ} (γ : Co r τ σ) → SemTy r τ σ (coI r γ) + coI-typed nom γ = nominal-defeq γ + coI-typed ph γ = tt + coI-typed rep (c-sym γ) = swap-typed (coI-typed rep γ) + coI-typed rep (c-trans γ δ) = comp-typed (coI-typed rep γ) (coI-typed rep δ) + coI-typed rep (c-sub γ) = id-typed (nominal-defeq γ) + coI-typed rep (c-arr γ δ) = arrIso-typed (coI-typed rep γ) (coI-typed rep δ) + coI-typed rep (c-prod γ δ) = prodIso-typed (coI-typed rep γ) (coI-typed rep δ) + coI-typed rep (c-sum γ δ) = sumIso-typed (coI-typed rep γ) (coI-typed rep δ) + coI-typed rep (c-nt₁ N γ) = + nt-typed N (mulG rep (role N)) (wr N) γ (coI-typed (mulG rep (role N)) γ) + coI-typed rep (c-ax₀ N) = + subst (λ Z → IsoTyped (T (nt₀ N)) Z (stepIso (inl N))) + (sym (T-embE (rep₀ N))) (step-typed (inl N)) + coI-typed rep (c-ax₁ N τ) = + subst (λ Z → IsoTyped (T (nt₁ N τ)) Z (stepIso (inr (N , τ)))) + (sym (T-inst (body N) τ)) (step-typed (inr (N , τ))) + + -- A representational coercion is an ordinary function of the target. + coerce-typed : ∀ {τ σ} (γ : Co rep τ σ) {n} (Γ : Cx n) → + 0ᵘ ▸ Γ ⊢ coerceT γ ∶ arr 𝟙 (T τ) (T σ) + coerce-typed γ Γ = t-lam {γ = 0ᵘ} (fst (coI-typed rep γ) (t-var zero)) + + ---------------------------------------------------------------------- + -- The typing of a translated term, when the grade 𝟙 is unrestricted. + + module _ (u0 : 𝟘 ≤ 𝟙) (u2 : (𝟙 + 𝟙) ≤ 𝟙) where + + private + Ones : Usage n → Type + Ones γ = ∀ i → γ i ≡ 𝟙 + + ones-ext : {γ : Usage n} → Ones γ → Ones (γ ▹ 𝟙) + ones-ext o zero = refl + ones-ext o (suc i) = o i + + unit-le : (i : Fin n) (γ : Usage n) → Ones γ → unit i ≤ᵘ γ + unit-le zero γ o zero = subst (𝟙 ≤_) (sym (o zero)) (le-refl 𝟙) + unit-le zero γ o (suc j) = subst (𝟘 ≤_) (sym (o (suc j))) u0 + unit-le (suc i) γ o zero = subst (𝟘 ≤_) (sym (o zero)) u0 + unit-le (suc i) γ o (suc j) = unit-le i (λ k → γ (suc k)) (λ k → o (suc k)) j + + zero-le : {γ : Usage n} → Ones γ → 0ᵘ ≤ᵘ γ + zero-le o i = subst (𝟘 ≤_) (sym (o i)) u0 + + dup-le : {γ : Usage n} → Ones γ → (γ +ᵘ γ) ≤ᵘ γ + dup-le o i = subst (λ x → (x + x) ≤ x) (sym (o i)) u2 + + app-le : {γ : Usage n} → Ones γ → (γ +ᵘ (𝟙 ·ᵘ γ)) ≤ᵘ γ + app-le o i = + subst (λ x → (x + 𝟙 · x) ≤ x) (sym (o i)) + (subst (λ y → (𝟙 + y) ≤ 𝟙) (sym (one-mul 𝟙)) u2) + + Agree : Cx n → SCx n → Type + Agree Δ Γ = ∀ i → Δ i ≡ T (Γ i) + + agree-ext : ∀ {Δ : Cx n} {Γ : SCx n} τ → Agree Δ Γ → Agree (Δ ▹ᶜ T τ) (Γ ▹ˢ τ) + agree-ext τ h zero = refl + agree-ext τ h (suc i) = h i + + tr-typed′ : ∀ {Γ : SCx n} {τ} (e : STm Γ τ) (γ : Usage n) (Δ : Cx n) → + Ones γ → Agree Δ Γ → γ ▸ Δ ⊢ tr e ∶ T τ + tr-typed′ (svar i) γ Δ o h = t-sub (castT (h i) (t-var i)) (unit-le i γ o) + tr-typed′ (slam {τ = τ} b) γ Δ o h = + t-lam (tr-typed′ b (γ ▹ 𝟙) (Δ ▹ᶜ T τ) (ones-ext o) (agree-ext τ h)) + tr-typed′ (sapp f a) γ Δ o h = + t-sub (t-app (tr-typed′ f γ Δ o h) (tr-typed′ a γ Δ o h)) (app-le o) + tr-typed′ (spair s t) γ Δ o h = + t-sub (t-pair (tr-typed′ s γ Δ o h) (tr-typed′ t γ Δ o h)) (dup-le o) + tr-typed′ (sletp {τ = τ} {σ = σ} s b) γ Δ o h = + t-sub (t-letp {δ = γ} (tr-typed′ s γ Δ o h) + (tr-typed′ b (γ ▹ 𝟙 ▹ 𝟙) (Δ ▹ᶜ T τ ▹ᶜ T σ) + (ones-ext (ones-ext o)) (agree-ext σ (agree-ext τ h)))) + (dup-le o) + tr-typed′ (sinl t) γ Δ o h = t-inj₁ (tr-typed′ t γ Δ o h) + tr-typed′ (sinr t) γ Δ o h = t-inj₂ (tr-typed′ t γ Δ o h) + tr-typed′ (scase {τ = τ} {σ = σ} s l r) γ Δ o h = + t-sub (t-case {δ = γ} (tr-typed′ s γ Δ o h) + (tr-typed′ l (γ ▹ 𝟙) (Δ ▹ᶜ T τ) (ones-ext o) (agree-ext τ h)) + (tr-typed′ r (γ ▹ 𝟙) (Δ ▹ᶜ T σ) (ones-ext o) (agree-ext σ h))) + (dup-le o) + tr-typed′ (slit ℓ) γ Δ o h = t-sub (t-lit ℓ) (zero-le o) + tr-typed′ (cast γ' e) γ Δ o h = fst (coI-typed rep γ') (tr-typed′ e γ Δ o h) + + tr-typed : ∀ {Γ : SCx n} {τ} (e : STm Γ τ) → + (λ _ → 𝟙) ▸ (λ i → T (Γ i)) ⊢ tr e ∶ T τ + tr-typed {Γ = Γ} e = tr-typed′ e (λ _ → 𝟙) (λ i → T (Γ i)) (λ i → refl) (λ i → refl) diff --git a/verification/proofs/agda/Wager/VERDICT.adoc b/verification/proofs/agda/Wager/VERDICT.adoc index 60f1368..af9d8e3 100644 --- a/verification/proofs/agda/Wager/VERDICT.adoc +++ b/verification/proofs/agda/Wager/VERDICT.adoc @@ -1,7 +1,7 @@ // SPDX-License-Identifier: CC-BY-SA-4.0 // SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) = Wager: verdict -Status: DRAFT after Stage 1. This file becomes final after the last stage. +Status: DRAFT after Stage 4. This file becomes final after the last stage. :toc: left :sectnums: @@ -17,26 +17,177 @@ Status: DRAFT after Stage 1. This file becomes final after the last stage. Each holds for each signature, each term signature and each `GradeAlgebra` on the term grades. The statements are in `Wager.Statements.T0-Statements`. No statement changed. -| T1 | NOT ATTEMPTED | Stage 2 is not started. -| T2 | NOT ATTEMPTED | Stage 2 is not started. -| T3 | NOT ATTEMPTED | Stage 4 is not started. -| T4 | NOT ATTEMPTED | Stage 2 is not started. -| T5 | NOT ATTEMPTED | Stage 4 is not started. -| T6 | NOT ATTEMPTED | Stage 5 is not started. +| T1 +| PROVED +| Lawful table (`nominal · phantom = phantom`): all 15 law fields hold, `Wager.Proofs.t1-lawful`. + GHC table (`nominal · phantom = nominal`): 14 law fields hold, `Wager.Proofs.t1-ghc-other-laws`. + The law `a · 0 = 0` is false, `Wager.Proofs.t1-ghc-mul-zero-fails`, and it fails at `nominal` only, `Wager.Proofs.t1-ghc-fails-at-nominal-only`. + The two results of the preliminary check are confirmed. + +| T2 +| PROVED WITH CHANGE (class: signature primitive) +| `Wager.Proofs.t2-representational`, `Wager.Proofs.t2-phantom`, from `Wager.Proofs.noninterference`. + The change: T2 has the hypothesis `Valid`. Each constant and each primitive of the signature must respect its declared grade. + The signature of Stage 2 with `proxy` declared representational satisfies the hypothesis (`Wager.Proofs.rep-constant-valid`). + Without the hypothesis T2 is false: `Wager.Proofs.t2-phantom-fails-without-valid` is a checked counterexample. + +| T3 +| PROVED +| `Wager.Proofs.t3`: for a signature that passes the role check, the erasure of each translated coercion evaluates to a function value, and this value is observationally equal to the identity function at the erased type. + `Wager.Proofs.t3-first-order`: at a first-order type the erased coercion gives its argument back. + `Wager.Proofs.coercion-is-a-term`: the translated coercion is an ordinary typed term of the target, in each grade algebra. No cast judgement exists. + "Observationally equal" is the logical relation `𝒱` of `Wager.Erased.LogRel` (DC-4.6). + +| T4 +| PROVED +| `Wager.Proofs.t4-kinding-rejects`: the classic function has no kinding derivation at the grade representational, and none at the grade phantom. + `Wager.Proofs.t4-not-equivalent`: `Age ≈ Int`, and the results of the function on `Age` and on `Int` are not equivalent. + +| T5 +| PROVED WITH CHANGE (class: signature primitive) +| `Wager.Proofs.t5-typing`: the translation of a term of the type τ has the type `T τ`. + `Wager.Proofs.t5-behaviour`: the erased source program and the erased translation evaluate to observationally equal values. `Wager.Proofs.t5-behaviour-first-order`: at a first-order type they evaluate to one value. + Each holds for each source signature that passes the role check, and for each state scheme. + + *The change.* A newtype with a parameter is not a two-state trope. It needs one wrapped state for each index of a state scheme (DC-4.1). + With two-state tropes, one program of the fragment has no translation of types that keeps the three properties of `Translation` (DC-4.8): `Wager.Proofs.no-two-state-translation` is the checked counterexample. + One of the three properties is "a nominal coercion becomes conversion", the content of T6. Agda did not prove that the typing part of T5 alone fails for each two-state translation. + The row scheme exists for each signature (`Wager.Proofs.row-translation-exists`). The two-state scheme exists when no type-level function looks at the argument of a newtype (`Wager.Proofs.two-state-translation-exists`). + + *A condition on the grade algebra.* `t5-typing` needs a grade algebra in which the grade `𝟙` is unrestricted: `𝟘 ≤ 𝟙` and `𝟙 + 𝟙 ≤ 𝟙` (DC-4.5). System FC has no usage discipline. + In `Affine` the translation of the source function `λx. 5`, which drops its argument, has no type (`Wager.Examples.Stage4.Coercions-In-Affine.const-rejected`). Agda checked this one function. + +| T6 | NOT ATTEMPTED | Stage 5 is not started. The lemma that T6 needs is proved, because T5 uses it: `Wager.Trans.Nominal.nominal-defeq` (DC-4.4). Stage 5 states T6. | T7 | NOT ATTEMPTED | Stage 6 is not started. |=== Stage 1 also proved the L1 equivalence that the task asks for: `Wager.Proofs.l1-equality` : `DefEq t u ↔ nf t ≡ nf u`, for each signature. +== Results of Stage 3: the source calculus + +Stage 3 has no T number. It defines the source calculus of claim W, a small fragment of System FC with roles (`Wager.FC`, DC-3.1 to DC-3.6). +Its results are about the source calculus only. They are properties that Breitner et al. state for their calculus, checked here for this fragment. +This development has no formal comparison of the fragment with the calculus of the paper. + +[cols="3,1,5",options="header"] +|=== +| Statement (`Wager.Statements`) | Status | Evidence and reading + +| `Source-Nominal-Soundness` +| PROVED +| `Wager.Proofs.source-nominal-soundness`. A nominal coercion relates two types with the same nominal value. This needs no role check. + +| `Source-Role-Soundness` +| PROVED +| `Wager.Proofs.source-role-soundness`. In a signature that passes the role check, a representational coercion relates two types with the same erased type. + +| `Cast-Vanishes`, `Coerce-Erases-To-Identity` +| PROVED +| `Wager.Proofs.cast-vanishes`, `Wager.Proofs.coerce-erases-to-identity`. Each proof is `refl`: erasure removes each cast, and `coerce` erases to `λx. x`. + +| `Erasure-Preserves-Typing` +| PROVED +| `Wager.Proofs.erasure-preserves-typing`. In a signature that passes the role check, the erasure of a term of the type τ has the erased type of τ. + +| `Classic-Rejected` +| PROVED +| `Wager.Proofs.classic-rejected`. The source role check rejects the declarations "representational" and "phantom" for the parameter of `T` in `newtype T a = MkT (F a)`. + +| `Classic-Bad-Coercion`, `Classic-Unsound-If-Accepted` +| PROVED +| `Wager.Proofs.classic-bad-coercion`, `Wager.Proofs.classic-unsound-if-accepted`. With the wrong declaration, `T Age` and `T Int` are representationally equal. + A closed term of the type Bool then exists whose erasure is a Char literal. The erased term evaluates to that literal and has no erased type Bool. + +| `Classic-Nominal-Accepted`, `Classic-Nominal-No-Coercion` +| PROVED +| `Wager.Proofs.classic-nominal-accepted`, `Wager.Proofs.classic-nominal-no-coercion`. The check accepts the declaration "nominal". + Then `Age` and `Int` are representationally equal, and `T Age` and `T Int` are not: the source calculus rejects `coerce : T Age → T Int`. +|=== + +The limits of the fragment are in DC-3.1 and DC-3.2. Two limits matter most for the strength of W: + +* A type is closed, and a term has no type variable. +* The body of a newtype cannot mention a declared newtype. + +Not proved in Stage 3: evaluation of a typed erased term gives a value of its erased type (DC-3.6). +Stage 4 proves a part of it: in a signature that passes the role check, the erasure of each closed source term evaluates to a value (`Wager.Proofs.t5-behaviour`). + +== Results of Stage 4: the translation + +Stage 4 defines the translation of the source calculus into the target calculus (`Wager.Trans`, DC-4.1 to DC-4.8). T3 and T5 are in the table of theorems. The other results: + +[cols="3,1,5",options="header"] +|=== +| Statement (`Wager.Statements`) | Status | Evidence and reading + +| `Role-Correspondence` +| PROVED +| `Wager.Proofs.role-correspondence`. The body of a newtype is a type-level function of the target. + Graded kinding, with the lawful role table, accepts the grade `g` for its parameter exactly when the inferred source role is at most `g`. + +| `Role-Check-Is-Kinding` +| PROVED +| `Wager.Proofs.role-check-is-kinding`. The source role check holds exactly when target kinding accepts the declared role of each newtype. + +| `Target-Signature-Valid` +| PROVED +| `Wager.Proofs.target-signature-valid`. Each target signature that the translation gives respects its declared grades. The hypothesis of T2 holds for it. + +| `Row-Translation-Exists` +| PROVED +| `Wager.Proofs.row-translation-exists`. For each source signature, the translation with the row scheme keeps the three properties of `Translation` (DC-4.8). + +| `Two-State-Translation-Exists` +| PROVED +| `Wager.Proofs.two-state-translation-exists`. When no type-level function looks at the argument of a newtype, the translation with two-state tropes exists. + +| `No-Two-State-Translation` +| PROVED +| `Wager.Proofs.no-two-state-translation`. The checked counterexample: the signature `taggedS rep` has no translation with two-state tropes, into any target signature. + "Translation" has the sense of DC-4.8: a translation of types that keeps the three properties of `Translation`. +|=== + +=== The source program with no two-state translation + +[source,haskell] +---- +newtype Tag a = MkTag Int +type family G a where { G Int = Bool ; G Bool = Char } +type family F a where { F (Tag a) = G a } +---- + +`Tag Int` and `Tag Bool` have one representation, `Int`. A two-state translation gives them one target type, `Int@tag`. +The function `F` gives `Bool` on the first type and `Char` on the second type. A nominal coercion becomes conversion, so `Bool` and `Char` become convertible. +The source role check accepts this program (`Wager.Examples.Stage3.Role-Check.wr-rep`). The three declarations are written as Haskell with type families. This development did not run GHC on them. + +The translation with the row scheme gives the two types two states of the carrier `Int`. The two target types are not convertible, and the phantom coercion between them is a typed term with two trope transitions (`Wager.Examples.Stage4.Coercions-In-Affine.tag-typed`, `tag-states-differ`). + +=== Not proved in Stage 4 + +* Contextual equivalence is not defined. "Observationally equal" is the logical relation `𝒱` (DC-4.6). +* No theorem relates the reduction of the target (`_⟶_`) to the evaluation of the erased target term. +* No theorem says that a role-rejected `coerce` has no translation. The source calculus has no term for such a `coerce` (DC-3.5), and the role correspondence is about kinding. +* The row scheme has a finite index type for a finite signature. Agda did not check this sentence (DC-4.1). + == Overall result -Not available. W is not decided after Stage 1. +Not available. W is not decided after Stage 4. T6 and T7 are not attempted. + +Results that bear on W after Stage 4: -== Ledgers after Stage 1 +* Parts (a) and (b) of W hold for the fragment, for each source signature that passes the role check: T5. They hold with one change (a newtype with a parameter needs more than one wrapped state) and one condition (an unrestricted grade `𝟙` for whole programs). +* Part (c) of W holds in the sense of T3: each erased coercion is observationally the identity. It is not the empty term (finding F14). +* Part (d) of W has the form of the role correspondence (DC-4.7). +* The target calculus has the judgement forms of Stage 1 only. No relation is added and no rule is added. +* T2 is "PROVED WITH CHANGE", so the condition "T2 to T6 are PROVED" of the task does not hold as written. The hypothesis of T2 holds for each signature that the translation gives (`target-signature-valid`). -* `RELATION-LEDGER.adoc`: no ADDED entry. One entry is "baseline, changed": the kinding judgement has a graded context (R1). -* `RULE-DIFF-LEDGER.adoc`: empty. +== Ledgers after Stage 4 + +* `RELATION-LEDGER.adoc`: no ADDED entry. One entry is "baseline, changed": the kinding judgement has a graded context (R1). Stage 2 added two "specification only" entries (`≈`, and the observers with `Valid`). + Stage 3 added the relations of the source calculus with the class "source" (the coercion relation `Co` is one of them), and the evaluation and the typing of erased terms as "specification only". + Stage 4 added observational equality (`𝒱`) and the definition of a translation as "specification only". Stage 3 and Stage 4 added nothing to the target calculus. +* `RULE-DIFF-LEDGER.adoc`: empty. Stages 2, 3 and 4 added no rule to the target calculus. == Answers of Stage 1 @@ -46,13 +197,57 @@ Yes, for the declarative judgement. Rule `t-case` gives the two branches one usage vector, and rule `t-sub` raises each branch to that vector. The rule has no join. T0 is proved with this rule. -The proofs of substitution and preservation use 14 of the 15 law fields. They do not use `le-antisym`. -The proof of progress uses no law. +The proofs of substitution and preservation do not use `le-antisym`: the name does not occur in the proof files of `Wager/L2`. This is a text search. Agda does not check it. +The module of progress takes the operations only (`GradeOps`), so Agda checks that progress uses no law. A checker that computes a usage vector is a different matter. For `case` it must find one vector that is above the two branch vectors. The law set has no operation for this. This development has no such checker and proves nothing about one. +== Answers of Stage 2 + +=== Which role table is sound in systemet? + +The question has three parts. + +*Part 1: a signature that respects its grades.* +Noninterference holds for the lawful table and for the GHC table (`Wager.Proofs.noninterference`). +The proof does not use the law `a · 0 = 0`. +The two tables then differ in three points. + +[cols="2,3,3",options="header"] +|=== +| Point | Lawful table | GHC table + +| Law set +| All 15 law fields. T0 applies. +| `a · 0 = 0` fails. The structure is not a grade algebra. + +| A parameter that does not occur, under a nominal function +| The grade phantom is accepted. +| The grade phantom is rejected (`Wager.Proofs.ghc-rejects-unused-parameter`). The role inference of GHC gives phantom to a parameter that does not occur. This development did not run GHC. + +| What the grade phantom gives +| Equal normal forms for all arguments (`t2-phantom`). +| Equivalent normal forms (`Wager.Examples.Stage2.GHC-Examples.ghc-phantom`). This development has no proof of equal normal forms for the GHC table. +|=== + +*Part 2: a generative constant with a parameter that is declared phantom (`Proxy`).* +With the lawful table such a signature does not respect its grades (`Wager.Proofs.phantom-constant-not-valid`). Agda did not check this sentence for the GHC table. +With the lawful table the result is unsound: kinding accepts the grade phantom for `λa. deep (Proxy a)`, and this function maps `Age` and `Int` to types that are not equivalent (`Wager.Proofs.lawful-unsound-with-phantom-constant`). +With the GHC table the same function is rejected at each grade below nominal (`Wager.Proofs.ghc-rejects-deep`). + +*Part 3: the decision.* +The lawful table is the sound table for systemet, for a signature that satisfies `Valid`: each constant and each primitive respects its declared grade. +`Wager.Role.Lawful.valid-lawful` gives a sufficient condition with 2 parts: no generative constant has a phantom parameter, and each primitive has the grade nominal. +The first part alone is not proved to be sufficient, because `Valid` also has a condition on each primitive. +Conversion sees the argument of a generative constant, so the parameter is used. The grade `0` means "not used". +With `Proxy` declared representational, `Proxy Int` and `Proxy Bool` are not related by `≈` (finding F8). + +The law set does not need a change. +The third finding that the task names, two notions of use, is a candidate for the phantom coercions (finding F9). +Stage 2 proved the laws of the candidate only. It did not prove that the candidate gives the phantom coercions back, and it did not prove that no smaller change exists. + == Findings [cols="1,8",options="header"] @@ -65,11 +260,12 @@ The law set has no operation for this. This development has no such checker and | F2 | The systemet order of `Affine` has `0 ≤ ω` and `1 ≤ ω`, and `0` and `1` are not comparable. With this order a binder of grade `1` that is not used is rejected (`Wager.Examples.Stage1.T0-Affine.drop-rejected`). - The grade `1` is thus linear, not affine. The anytype kernel uses the order `0 ≤ 1 ≤ ω`, which accepts the same term. + The grade `1` is thus linear, not affine. The anytype kernel has the total order `0 ≤ 1 ≤ ω` (`src/kernel/Anytype/Grade/Affine.idr` in the anytype repository). + This development did not run the anytype checker on the term. | F3 | T0 uses the law `a · 0 = 0` (`mul-zero`), in the product of a usage vector with a matrix. - A structure that fails this law is outside T0. Stage 2 examines such a structure. + The GHC role table fails this law (T1), so T0 does not apply to it. | F4 | The stock cubical v0.9 library forces `--guardedness` on each importer (DC-0.2). @@ -77,18 +273,75 @@ The law set has no operation for this. This development has no such checker and | F5 | Resolved on 2026-11-10. The owner asked for the repository update, so `docs/status/PROOF-STATUS.adoc` now has the marker line for Agda and a section for the experiment. `scripts/check-proof-status.sh` passes. The proofs workflow has an `agda` job, so CI runs the Agda gate. + +| F6 +| Noninterference needs `a ≤ a + b`. This holds for roles, because `+` is the maximum. It is not one of the 15 law fields. + It is false in `Affine` with the systemet order: `0 + 1` is `1`, and `0 ≤ 1` is false (`Wager.Examples.Stage4.Coercions-In-Affine.affine-not-unrestricted`). + +| F7 +| The signature of Stage 2 with `Proxy` declared phantom does not respect its grades (`Wager.Proofs.phantom-constant-not-valid`). + A nominal observer tells `Proxy Int` from `Proxy Bool`. + The same argument applies to each generative constant with a phantom parameter. Agda checked this one signature only. + +| F8 +| With `Proxy` declared representational the signature is valid, and `Proxy Age ≈ Proxy Int` holds. + But `Proxy Int` and `Proxy Bool` are not related by `≈` (`Wager.Proofs.no-phantom-coercion`). In Haskell a phantom parameter allows a coercion between them. This development did not run GHC. + This result is about the relation `≈` only. It does not show that no term of the target calculus can do this coercion. + Stage 4 shows a related result (finding F12): with the row scheme, a phantom coercion between two instances of a source newtype is a typed term of the target. + Stage 4 does not translate the constant `Proxy` of the Stage 2 signature. The question stays open for that signature. + +| F9 +| Two notions of use. A 4-point structure with a separate grade "absent" for `0` has all 15 law fields and the GHC rule `nominal · phantom = nominal` (`Wager.Proofs.role4-lawful`, `Wager.Proofs.role4-has-ghc-rule`). + This is a candidate for the phantom coercions without a change of the law set. Stage 2 did not prove that it gives them back. + It would need a larger `≈` (a constant with a phantom parameter ignores its argument) and a weaker phantom part of T2 (`≈` in place of `≡`). This development did not check these two points. + Stage 2 proved the laws only. It did not build kinding or noninterference for this structure. The owner decides. + +| F10 +| The source calculus uses the GHC entry `nominal · phantom = nominal` in its congruence rule for a newtype (DC-3.3): a newtype is generative. + `Tag Int` and `Tag Bool` are not nominally equal, though the parameter of `Tag` is phantom (`Wager.Examples.Stage3.Nominal-Soundness-Examples.tag-nominal-rejected`). + A type-level function tells them apart (`f-sees-phantom` in the same module), and they are representationally equal (`Wager.Examples.Stage3.Role-Soundness-Examples.tag-co`). + This is the source side of findings F7 and F8. + +| F11 +| Role inference of the source (`roleOf`) uses the lawful entry `nominal · phantom = phantom`: a parameter that does not occur below a type-level function is phantom. `Source-Role-Soundness` is proved with it. + This is sound only because a body of this fragment cannot mention a declared newtype (DC-3.2). The fragment cannot declare `newtype N a = MkN (F (Tag a))`. + For that body the lawful entry gives phantom, and example `f-sees-phantom` shows that phantom is wrong there. Stage 3 has no Agda proof about such a body. + +| F12 +| Two-state tropes are not enough for the signature `taggedS rep`: a newtype with a phantom parameter and a type-level function that looks at that parameter (`Wager.Proofs.no-two-state-translation`, in the sense of DC-4.8). Agda checked this one signature. + One wrapped state for each row of function results is enough (`rowScheme`, T5). + The phantom parameter is then in the name of the state. It is not a type argument of a constant, so findings F7 and F8 do not apply to it. + The phantom coercion is two trope transitions: unwrap from one state, wrap to the other state. + +| F13 +| A source program has no usage discipline. Its translation is typed in each grade algebra in which the grade `𝟙` is unrestricted (DC-4.5). This development does not prove that the condition is necessary. + The rules of Stage 1 bind the components of a pair and the variable of a `case` branch at the grade `𝟙`. In `Affine` the translation of the source function `λx. 5` has no type (`const-rejected`). Agda checked this one function. + A translated coercion is different: it uses each variable one time, and it is typed in each grade algebra. + +| F14 +| After erasure a translated coercion is not the empty term. The trope transitions vanish, and the maps of functions, pairs and sums stay (`Wager.Examples.Stage4.Programs.prog-erased`). + The coercion is observationally the identity (T3). By the definition of `eraseT`, a trope transition leaves no term, and a map of a function, of a pair or of a sum leaves a term. + This development has no optimisation that removes such a map. + +| F15 +| In this fragment the result of a type-level function is a base type. For a signature with a finite number of base types and of type-level functions, a finite number of states for each newtype is then enough (DC-4.1). Agda did not check this sentence. + A function that returns a part of its argument is outside the fragment, in the source and in the target. This development proves nothing about it. |=== == Changes to theorem statements -None. +None after a statement was put in `Statements.agda`. + +T2 was written with the hypothesis `Valid` from the start of Stage 2. The task text has no such hypothesis. The status of T2 records this. Process note: the statement `L1-Equality` was put in `Statements.agda` after its proof was complete. It is the statement that the task gives. -The three T0 statements were put in `Statements.agda`, and committed, before their proofs. +The statements of T0, T1, T2 and T4 were put in `Statements.agda`, and committed, before their proofs. +The statements of Stage 3 were put in `Statements.agda`, and committed, before their proofs. +The statements of Stage 4 were put in `Statements.agda`, and committed, before their proofs. One proof was complete at that time: the lemma `nominal-defeq`, which is not a statement of Stage 4. == Trust base * Agda 2.8.0 with `--cubical --safe`, and `agda/cubical` v0.9 (`TOOLCHAIN.adoc`). * No `postulate`, no hole, no termination pragma, no positivity pragma. * `--guardedness` is on in each file (DC-0.2). No file uses coinduction. -* One warning is silenced, in 18 files: `UnsupportedIndexedMatch` (DC-0.3). +* One warning is silenced, in 35 of the 64 files: `UnsupportedIndexedMatch` (DC-0.3).