From 433fc4418ab7d8a05248f5f8575bc0953690b30c Mon Sep 17 00:00:00 2001 From: Cam Pedersen Date: Wed, 28 Oct 2026 13:56:59 -0400 Subject: [PATCH 1/4] feat(verify): equational proof kernel, loon prove, and Div effect Loon can now state laws and check proofs of them. - `Div` is an inferred effect: structural recursion is total, anything else (non-structural recursion, loop, mutual recursion) carries Div. E0405 when a fn annotated `#{}` may diverge. Div is not a capability. - `[law name [params] [= lhs rhs]]` and `[proof name steps...]`, checked by a small rewrite kernel in crates/loon-lang/src/verify: unfold, rewrite (:rev, :at), induction with one hypothesis per recursive field, cases on fields with inferred ADT types, refl, admit (tainting). Goals close by evaluating total definitions and canonicalizing `+` and any user operator declared `[ac op assoc comm :unit u law]` once those laws are themselves proven. - `loon prove DIR`: bounded falsification first (generic ADT enumeration on the EIR VM), kernel in dependency order, canary check, text or JSON report with the hash of the frozen defs. Unsound runs score 0. - Corpus under verify/: list laws, Hutton compiler correctness, and Peano arithmetic through mul-assoc, Gauss and sum-of-odds. 22 proven, 4 deliberately false laws falsified, sound. - Plan: docs/plans/2026-10-28-verify-autoresearch.md Co-Authored-By: Claude Fable 5.1 --- crates/loon-cli/src/main.rs | 50 +- crates/loon-lang/src/check/mod.rs | 162 ++- crates/loon-lang/src/check/termination.rs | 428 +++++++ crates/loon-lang/src/effects/mod.rs | 6 + crates/loon-lang/src/errors/codes.rs | 6 +- crates/loon-lang/src/errors/tutorials.rs | 39 + crates/loon-lang/src/lib.rs | 1 + crates/loon-lang/src/verify/bounded.rs | 641 ++++++++++ crates/loon-lang/src/verify/infer.rs | 306 +++++ crates/loon-lang/src/verify/kernel.rs | 1166 ++++++++++++++++++ crates/loon-lang/src/verify/mod.rs | 923 ++++++++++++++ crates/loon-lang/src/verify/tests.rs | 738 +++++++++++ crates/loon-lang/tests/effect_rows.rs | 13 +- docs/plans/2026-10-28-verify-autoresearch.md | 386 ++++++ verify/builtins.oo | 13 + verify/canary.oo | 4 + verify/defs.oo | 82 ++ verify/laws/compiler.oo | 11 + verify/laws/list.oo | 22 + verify/laws/nat.oo | 28 + verify/proofs/compiler.oo | 15 + verify/proofs/list.oo | 41 + verify/proofs/nat.oo | 61 + 23 files changed, 5133 insertions(+), 9 deletions(-) create mode 100644 crates/loon-lang/src/check/termination.rs create mode 100644 crates/loon-lang/src/verify/bounded.rs create mode 100644 crates/loon-lang/src/verify/infer.rs create mode 100644 crates/loon-lang/src/verify/kernel.rs create mode 100644 crates/loon-lang/src/verify/mod.rs create mode 100644 crates/loon-lang/src/verify/tests.rs create mode 100644 docs/plans/2026-10-28-verify-autoresearch.md create mode 100644 verify/builtins.oo create mode 100644 verify/canary.oo create mode 100644 verify/defs.oo create mode 100644 verify/laws/compiler.oo create mode 100644 verify/laws/list.oo create mode 100644 verify/laws/nat.oo create mode 100644 verify/proofs/compiler.oo create mode 100644 verify/proofs/list.oo create mode 100644 verify/proofs/nat.oo diff --git a/crates/loon-cli/src/main.rs b/crates/loon-cli/src/main.rs index c3fbc26..64501fc 100644 --- a/crates/loon-cli/src/main.rs +++ b/crates/loon-cli/src/main.rs @@ -139,6 +139,21 @@ enum Command { /// the trace and report FIXED (exit 0), REPRODUCED (exit 10), or /// DIVERGED (exit 11). With no arguments, verifies package cache /// integrity against lockfile hashes. + /// Check laws in a verify directory: bounded falsification, then the + /// rewrite kernel on proof objects. Prints a report (JSON with --json). + Prove { + /// Verify directory (default: verify/) + dir: Option, + /// Emit a single JSON report + #[arg(long)] + json: bool, + /// Bounded-evaluation input size + #[arg(long, default_value = "6")] + bound: usize, + /// Seed for generated Int inputs + #[arg(long)] + seed: Option, + }, Verify { /// Trace file written by `loon run --record` trace: Option, @@ -252,6 +267,12 @@ fn main() { Command::Update { ref source } => pkg_update(source.as_deref()), Command::Why { ref source } => pkg_why(source), Command::Audit { capabilities } => pkg_audit(capabilities), + Command::Prove { + ref dir, + json, + bound, + seed, + } => prove_dir(dir.as_deref(), json, bound, seed), Command::Verify { ref trace, ref file, @@ -1358,6 +1379,32 @@ fn new_project(name: &str) { println!(" {} cd {name} && loon run src/main.oo", "->".dimmed()); } +fn prove_dir(dir: Option<&std::path::Path>, json: bool, bound: usize, seed: Option) { + let dir = dir.unwrap_or_else(|| std::path::Path::new("verify")); + let mut opts = loon_lang::verify::Options { + bound, + ..Default::default() + }; + if let Some(s) = seed { + opts.seed = s; + } + let report = match loon_lang::verify::run_dir(dir, &opts) { + Ok(r) => r, + Err(e) => { + eprintln!("{} {e}", "error".red().bold()); + std::process::exit(1); + } + }; + if json { + println!("{}", report.to_json()); + } else { + print!("{}", report.to_text()); + } + if !report.sound { + std::process::exit(2); + } +} + fn test_file(path: &PathBuf) { let source = match std::fs::read_to_string(path) { Ok(s) => s, @@ -1640,6 +1687,7 @@ fn explain_error(code: &str) { "E0401" => Some(ErrorCode::E0401), "E0403" => Some(ErrorCode::E0403), "E0404" => Some(ErrorCode::E0404), + "E0405" => Some(ErrorCode::E0405), "E0500" => Some(ErrorCode::E0500), "E0501" => Some(ErrorCode::E0501), "E0502" => Some(ErrorCode::E0502), @@ -1652,7 +1700,7 @@ fn explain_error(code: &str) { eprintln!(" E01xx: parse errors (E0100-E0103)"); eprintln!(" E02xx: type errors (E0200-E0207)"); eprintln!(" E03xx: ownership errors (E0300-E0302)"); - eprintln!(" E04xx: effect errors (E0400-E0401)"); + eprintln!(" E04xx: effect errors (E0400-E0405)"); eprintln!(" E05xx: module errors (E0500-E0502)"); eprintln!("Legacy codes: E0001 -> E0300, E0002 -> E0301, E0003 -> E0302, E0010 -> E0200, E0020 -> E0400"); std::process::exit(1); diff --git a/crates/loon-lang/src/check/mod.rs b/crates/loon-lang/src/check/mod.rs index 58fc650..d14cfeb 100644 --- a/crates/loon-lang/src/check/mod.rs +++ b/crates/loon-lang/src/check/mod.rs @@ -1,5 +1,6 @@ pub mod kernel; pub mod ownership; +pub mod termination; use crate::ast::{Expr, ExprKind, NodeId}; use crate::errors::codes::ErrorCode; @@ -66,6 +67,10 @@ pub struct RefInfo { pub node_id: NodeId, } +/// Effect label for possible nontermination. Not a capability: never +/// grantable, never part of `AMBIENT_EFFECTS`. +pub const DIV: &str = "Div"; + // ── Checker ────────────────────────────────────────────────────────── pub struct Checker { @@ -130,6 +135,11 @@ pub struct Checker { /// after desugaring; this is what remembers that they promised to stay /// inside the placeable subset. pub kernels: HashSet, + /// Top-level fns on a mutual-recursion cycle (they get `Div`). + mutual_rec: HashSet, + /// Top-level fns that may diverge by a syntactic over-approximation; + /// used only for forward references, whose rows are not linked yet. + may_diverge: HashSet, } /// Split a param list at a `&` marker: returns the fixed params and the @@ -157,6 +167,8 @@ impl Checker { errors: Vec::new(), fn_param_modes: HashMap::new(), kernels: HashSet::new(), + mutual_rec: HashSet::new(), + may_diverge: HashSet::new(), constructors: HashMap::new(), type_constructors: HashMap::new(), type_of: HashMap::new(), @@ -303,6 +315,25 @@ impl Checker { let _ = unify_effect_rows(&mut self.subst, &ambient, &want); } + /// Is the named function total (its inferred row has no `Div`)? + /// + /// Valid after `check_program`. Returns false for unknown names. An + /// effect-polymorphic higher-order fn (open row tail) counts as total + /// relative to its arguments: `Div` from a callback shows up at the call + /// site, not here. + pub fn is_total(&self, name: &str) -> bool { + self.fn_effects + .get(name) + .is_some_and(|row| !row.labels.contains(DIV)) + } + + /// Add `Div` to the current row when `diverges`. + fn mark_div(&mut self, diverges: bool) { + if diverges { + self.perform_effect(DIV); + } + } + /// Absorb a callee's effect row into the ambient row of the current /// function body. /// @@ -3266,6 +3297,17 @@ impl Checker { self.infer_fn_clause(&items[2], &items[3..]); return Type::Unit; } + // [law name [params] [= lhs rhs]] — check like a test clause. + // [proof name step*] is kernel data, not code. + "law" + if items.len() >= 3 + && matches!(items[1].kind, ExprKind::Symbol(_)) + && matches!(items[2].kind, ExprKind::List(_)) => + { + self.infer_fn_clause(&items[2], &items[3..]); + return Type::Unit; + } + "proof" => return Type::Unit, "test" | "mut" => { if items.len() > 1 { return self.infer_list(&items[1..], span); @@ -3395,6 +3437,10 @@ impl Checker { } } } + // Async.loop calls its step fn forever. + if effect == "Async" && op == "loop" { + self.perform_effect(DIV); + } // Return declared return type or fresh return match &op_def.return_type { Some(ty_name) => self.resolve_type_name(ty_name), @@ -3754,6 +3800,9 @@ impl Checker { } self.recur_params.pop(); self.pop_scope(); + // `recur` re-entering this lambda non-structurally may diverge. + let ps = termination::param_names(fixed_params); + self.mark_div(termination::recursion_diverges("", &ps, &args[1..])); let row = std::mem::replace(&mut self.current_fn_effects, saved_effects); return Type::Fn(param_types, Box::new(body_ty), row); @@ -3796,6 +3845,9 @@ impl Checker { } self.multi_arity_schemes .insert(name.clone(), clause_schemes); + // Multi-arity clauses dispatch by name; stay conservative. + let d = termination::fn_self_diverges(&name, args) || self.mutual_rec.contains(&name); + self.mark_div(d); // Store inferred effects and restore let inferred = std::mem::replace(&mut self.current_fn_effects, saved_effects); let inferred = self.subst.resolve_effect_row(&inferred); @@ -3878,6 +3930,20 @@ impl Checker { for body_expr in &args[body_start..] { body_ty = self.infer(body_expr); } + // Div: non-structural self recursion, mutual recursion, a + // forward reference to a may-diverge fn (its row is not linked + // yet), or an explicit `#{Div}` annotation. + let body = &args[body_start..]; + let diverges = termination::recursion_diverges( + &name, + &termination::param_names(fixed_params), + body, + ) || self.mutual_rec.contains(&name) + || termination::referenced_symbols(body).iter().any(|r| { + r != &name && self.may_diverge.contains(r) && !self.fn_effects.contains_key(r) + }) + || declared_effects.as_ref().is_some_and(|d| d.contains(DIV)); + self.mark_div(diverges); self.recur_params.pop(); if let Err(e) = unify(&mut self.subst, &temp_ret, &body_ty) { @@ -3929,7 +3995,17 @@ impl Checker { if let Some(ref declared) = declared_effects { { for eff in &inferred.labels { - if !declared.contains(eff) { + if eff == DIV && !declared.contains(eff) { + self.errors.push( + LoonDiagnostic::new( + ErrorCode::E0405, + format!("function `{name}` is annotated total but may not terminate"), + ) + .with_why("its recursion is not structural (or it calls something that may diverge), so the checker infers `Div`") + .with_fix("recurse on a strict subterm bound by `match` (e.g. `[Cons x rest]` → `[f rest]`), or add `Div` to the annotation: #{Div}") + .with_label(span, "may not terminate", true), + ); + } else if !declared.contains(eff) { self.errors.push( LoonDiagnostic::new( ErrorCode::E0401, @@ -4472,6 +4548,19 @@ impl Checker { body_ty = self.infer(e); } self.recur_params.pop(); + // A `loop` whose `recur` is not structural on a binding may diverge. + if let ExprKind::List(bindings) = &args[0].kind { + let names: Vec = bindings + .chunks(2) + .map(|p| match &p[0].kind { + ExprKind::Symbol(s) => s.clone(), + _ => String::new(), + }) + .collect(); + self.mark_div(termination::recursion_diverges("", &names, &args[1..])); + } else { + self.mark_div(true); + } self.pop_scope(); body_ty } @@ -5885,6 +5974,9 @@ impl Checker { // the same path. Only the promise they made is kept aside. let (expanded, kernels) = kernel::desugar(&expanded); self.kernels = kernels; + let facts = termination::program_facts(&expanded); + self.mutual_rec = facts.mutual; + self.may_diverge = facts.may_diverge; // Phase 2a: Pre-declare top-level functions so forward references // (including mutual recursion across definitions) resolve. Each name @@ -6480,7 +6572,7 @@ mod tests { 0 [handle [+ [A.a] [weird [- n 1]]] [A.a] [resume 1]]]] - [fn main [] #{} [println [weird 3]]] + [fn main [] #{Div} [println [weird 3]]] "#, ); assert!(errors.is_empty(), "errors: {:?}", errors); @@ -7529,4 +7621,70 @@ mod tests { assert!(errors.is_empty(), "errors: {:?}", errors); assert_eq!(ty, Type::Int); } + + // ── Div (nontermination) ───────────────────────────────────────── + + fn check_div(src: &str) -> (Checker, Vec) { + let exprs = parse(src).unwrap(); + let mut checker = Checker::new(); + let errs = checker.check_program(&exprs); + (checker, errs) + } + + #[test] + fn div_structural_adt_recursion_is_total() { + let (c, errs) = check_div( + "[type L [Cons Int L] Nil] + [fn len [xs] [match xs [Cons _ rest] [+ 1 [len rest]] Nil 0]] + [fn len2 [xs] [match xs #[] 0 #[_ & rest] [+ 1 [recur rest]]]]", + ); + assert!(errs.is_empty(), "{errs:?}"); + assert!(c.is_total("len"), "{:?}", c.fn_effects.get("len")); + assert!(c.is_total("len2"), "{:?}", c.fn_effects.get("len2")); + } + + #[test] + fn div_nonstructural_recursion_is_div() { + let (c, _) = check_div( + "[fn collatz [n] [if [<= n 1] 0 [+ 1 [collatz [if [= 0 [% n 2]] [/ n 2] [+ 1 [* 3 n]]]]]]] + [fn spin [] [loop [i 0] [recur [+ i 1]]]] + [fn ev [n] [if [= n 0] true [od [- n 1]]]] + [fn od [n] [if [= n 0] false [ev [- n 1]]]]", + ); + for f in ["collatz", "spin", "ev", "od"] { + assert!(!c.is_total(f), "{f} should be Div: {:?}", c.fn_effects.get(f)); + } + } + + #[test] + fn div_pure_annotation_on_div_fn_is_e0405() { + let (_, errs) = check_div("[fn f [n] #{} [f [+ n 1]]]"); + assert!(errs.iter().any(|e| e.code == ErrorCode::E0405), "{errs:?}"); + let (c, errs) = check_div("[fn g [n] #{Div} [g [+ n 1]]]"); + assert!(errs.is_empty(), "{errs:?}"); + assert!(!c.is_total("g")); + } + + #[test] + fn div_propagates_through_call() { + let (c, _) = check_div( + "[fn spin [n] [spin [+ n 1]]] + [fn caller [x] [spin x]] + [fn early [x] [later x]] + [fn later [n] [later [+ n 1]]]", + ); + assert!(!c.is_total("caller")); + assert!(!c.is_total("early"), "forward ref to a Div fn"); + } + + #[test] + fn div_propagates_through_map_callback() { + let (c, _) = check_div( + "[fn spin [n] [spin [+ n 1]]] + [fn all [xs] [map spin xs]] + [fn ok [xs] [map [fn [x] [+ x 1]] xs]]", + ); + assert!(!c.is_total("all"), "{:?}", c.fn_effects.get("all")); + assert!(c.is_total("ok")); + } } diff --git a/crates/loon-lang/src/check/termination.rs b/crates/loon-lang/src/check/termination.rs new file mode 100644 index 0000000..d1e4b88 --- /dev/null +++ b/crates/loon-lang/src/check/termination.rs @@ -0,0 +1,428 @@ +//! Syntactic termination analysis backing the `Div` effect. +//! +//! `Div` (possible nontermination) is inferred like any other effect label. +//! This module only answers the syntactic questions the checker needs: +//! +//! - does a recursive body recurse *structurally* (every self-call / `recur` +//! passes, in one fixed argument position, a variable bound as a strict +//! subterm of the corresponding parameter by a `match` constructor +//! pattern)? +//! - which top-level functions are mutually recursive (call-graph cycles of +//! length ≥ 2)? +//! +//! Everything it cannot prove is reported as diverging; the analysis is +//! deliberately simple and conservative. + +use crate::ast::{Expr, ExprKind}; +use std::collections::{HashMap, HashSet}; + +#[derive(Clone, Default)] +struct Ctx { + /// Unshadowed parameter names → position. + params: HashMap, + /// Variables known to be strict subterms of parameter `i`. + subterm: HashMap, + /// Inside a nested fn / loop: `recur` no longer targets us. + inner: bool, +} + +impl Ctx { + fn unbind(&mut self, name: &str) { + self.params.remove(name); + self.subterm.remove(name); + } +} + +struct Walk<'a> { + name: &'a str, + /// Argument positions decreasing in every recursive call seen so far + /// (`None` = no recursive call yet). + candidates: Option>, + /// A self-reference we cannot reason about (escaping, wrong shape). + bad: bool, +} + +/// True when `body` — the body of a function (or `loop`) named `name` with +/// positional `params` — recurses (by name or via `recur`) in a way that is +/// not provably structural. Non-recursive bodies return false. Pass `""` as +/// `name` for anonymous fns and `loop`, where only `recur` re-enters. +pub fn recursion_diverges(name: &str, params: &[String], body: &[Expr]) -> bool { + let mut ctx = Ctx::default(); + for (i, p) in params.iter().enumerate() { + if !p.is_empty() { + ctx.params.insert(p.clone(), i); + } + } + let mut w = Walk { + name, + candidates: None, + bad: false, + }; + for e in body { + w.expr(e, &mut ctx); + } + w.bad || w.candidates.is_some_and(|c| c.is_empty()) +} + +impl Walk<'_> { + fn call(&mut self, args: &[Expr], ctx: &mut Ctx) { + let dec: HashSet = args + .iter() + .enumerate() + .filter(|(i, a)| match &a.kind { + ExprKind::Symbol(s) => ctx.subterm.get(s) == Some(i), + _ => false, + }) + .map(|(i, _)| i) + .collect(); + self.candidates = Some(match self.candidates.take() { + None => dec, + Some(c) => c.intersection(&dec).copied().collect(), + }); + for a in args { + self.expr(a, ctx); + } + } + + fn expr(&mut self, e: &Expr, ctx: &mut Ctx) { + match &e.kind { + ExprKind::Symbol(s) => { + if !self.name.is_empty() && s == self.name { + // The function escapes as a value: its calls are invisible. + self.bad = true; + } + } + ExprKind::List(items) if !items.is_empty() => { + let head = match &items[0].kind { + ExprKind::Symbol(h) => h.as_str(), + _ => "", + }; + match head { + h if !self.name.is_empty() && h == self.name => self.call(&items[1..], ctx), + "recur" if !ctx.inner => self.call(&items[1..], ctx), + "match" if items.len() >= 2 => self.match_form(&items[1..], ctx), + "fn" => self.fn_form(&items[1..], ctx), + "loop" if items.len() >= 2 => { + let mut inner = ctx.clone(); + inner.inner = true; + if let ExprKind::List(binds) = &items[1].kind { + for pair in binds.chunks(2) { + if let Some(v) = pair.get(1) { + self.expr(v, ctx); + } + for s in pattern_vars(&pair[0]) { + inner.unbind(&s); + } + } + } + for b in &items[2..] { + self.expr(b, &mut inner); + } + } + "let" => { + for it in items.iter().skip(2) { + self.expr(it, ctx); + } + // Conservative: whatever `let` binds stops being a + // known param/subterm for the rest of this scope. + if let Some(p) = items.get(1) { + for s in pattern_vars(p) { + ctx.unbind(&s); + } + } + } + _ => { + for it in items { + self.expr(it, ctx); + } + } + } + } + ExprKind::List(items) + | ExprKind::Vec(items) + | ExprKind::Set(items) + | ExprKind::Tuple(items) => { + for it in items { + self.expr(it, ctx); + } + } + ExprKind::Map(pairs) => { + for (k, v) in pairs { + self.expr(k, ctx); + self.expr(v, ctx); + } + } + ExprKind::Quote(x) | ExprKind::Unquote(x) | ExprKind::UnquoteSplice(x) => { + self.expr(x, ctx) + } + ExprKind::DotAccess(x, _) => self.expr(x, ctx), + _ => {} + } + } + + fn fn_form(&mut self, rest: &[Expr], ctx: &Ctx) { + let mut inner = ctx.clone(); + inner.inner = true; + let mut rest = rest; + if let Some(ExprKind::Symbol(n)) = rest.first().map(|e| &e.kind) { + if n == self.name { + // A nested definition shadowing us: not our recursion. + return; + } + inner.unbind(n); + rest = &rest[1..]; + } + for part in rest { + match &part.kind { + ExprKind::List(ps) => { + for p in ps { + for s in pattern_vars(p) { + inner.unbind(&s); + } + } + } + ExprKind::Tuple(cl) => { + // multi-arity clause: ([params] body...) + let mut c = inner.clone(); + if let Some(ExprKind::List(ps)) = cl.first().map(|e| &e.kind) { + for p in ps { + for s in pattern_vars(p) { + c.unbind(&s); + } + } + } + for b in cl.iter().skip(1) { + self.expr(b, &mut c); + } + continue; + } + _ => {} + } + self.expr(part, &mut inner); + } + } + + fn match_form(&mut self, rest: &[Expr], ctx: &mut Ctx) { + let scrut = &rest[0]; + self.expr(scrut, ctx); + let source = match &scrut.kind { + ExprKind::Symbol(s) => ctx.params.get(s).or(ctx.subterm.get(s)).copied(), + _ => None, + }; + let arms = &rest[1..]; + let mut i = 0; + while i < arms.len() { + let pat = &arms[i]; + let mut arm = ctx.clone(); + for s in pattern_vars(pat) { + arm.unbind(&s); + } + if let Some(p) = source { + for s in strict_subterm_vars(pat) { + arm.subterm.insert(s, p); + } + } + let guard = arms.get(i + 1).filter(|g| is_when(g)).is_some() && i + 2 < arms.len(); + if guard { + self.expr(&arms[i + 1], &mut arm); + self.expr(&arms[i + 2], &mut arm); + i += 3; + } else { + if let Some(b) = arms.get(i + 1) { + self.expr(b, &mut arm); + } + i += 2; + } + } + } +} + +fn is_when(e: &Expr) -> bool { + matches!(&e.kind, ExprKind::List(xs) + if matches!(xs.first().map(|h| &h.kind), Some(ExprKind::Symbol(s)) if s == "when")) +} + +fn is_binder(s: &str) -> bool { + s != "_" && s != "&" && s.starts_with(|c: char| c.is_lowercase() || c == '_') +} + +/// Every variable a pattern binds. +fn pattern_vars(p: &Expr) -> Vec { + let mut out = Vec::new(); + collect(p, true, &mut out); + out +} + +/// Variables bound strictly *inside* a constructor / vector pattern. +fn strict_subterm_vars(p: &Expr) -> Vec { + let mut out = Vec::new(); + match &p.kind { + ExprKind::List(items) => { + for it in items.iter().skip(1) { + collect(it, true, &mut out); + } + } + ExprKind::Vec(items) => { + for it in items { + collect(it, true, &mut out); + } + } + _ => {} + } + out +} + +fn collect(p: &Expr, top: bool, out: &mut Vec) { + match &p.kind { + ExprKind::Symbol(s) if is_binder(s) => out.push(s.clone()), + ExprKind::List(items) => { + // Head is the constructor name; skip it. + for it in items.iter().skip(1) { + collect(it, false, out); + } + } + ExprKind::Vec(items) | ExprKind::Tuple(items) | ExprKind::Set(items) => { + for it in items { + collect(it, false, out); + } + } + ExprKind::Map(pairs) => { + for (_, v) in pairs { + collect(v, false, out); + } + } + _ => {} + } + let _ = top; +} + +/// All symbols mentioned anywhere in `exprs` (a cheap call-graph edge set). +pub fn referenced_symbols(exprs: &[Expr]) -> HashSet { + fn go(e: &Expr, out: &mut HashSet) { + match &e.kind { + ExprKind::Symbol(s) => { + out.insert(s.clone()); + } + ExprKind::List(xs) | ExprKind::Vec(xs) | ExprKind::Set(xs) | ExprKind::Tuple(xs) => { + xs.iter().for_each(|x| go(x, out)) + } + ExprKind::Map(ps) => ps.iter().for_each(|(k, v)| { + go(k, out); + go(v, out) + }), + ExprKind::Quote(x) | ExprKind::Unquote(x) | ExprKind::UnquoteSplice(x) => go(x, out), + ExprKind::DotAccess(x, field) => { + if let ExprKind::Symbol(obj) = &x.kind { + out.insert(format!("{obj}.{field}")); + } + go(x, out) + } + _ => {} + } + } + let mut out = HashSet::new(); + exprs.iter().for_each(|e| go(e, &mut out)); + out +} + +/// Top-level function facts used to make forward references conservative. +pub struct ProgramFacts { + /// Functions on a call-graph cycle through at least one other function. + pub mutual: HashSet, + /// Functions that may diverge by a purely syntactic over-approximation + /// (non-structural self recursion, mutual recursion, a `loop`, or + /// referencing another such function). + pub may_diverge: HashSet, +} + +/// Analyse the top-level `[fn name ...]` forms of a program. +pub fn program_facts(exprs: &[Expr]) -> ProgramFacts { + let mut defs: Vec<(String, &[Expr])> = Vec::new(); + for e in exprs { + if let ExprKind::List(items) = &e.kind { + if let (Some(ExprKind::Symbol(h)), Some(ExprKind::Symbol(n))) = + (items.first().map(|x| &x.kind), items.get(1).map(|x| &x.kind)) + { + if h == "fn" && items.len() >= 3 { + defs.push((n.clone(), &items[2..])); + } + } + } + } + let names: HashSet = defs.iter().map(|(n, _)| n.clone()).collect(); + let mut edges: HashMap> = HashMap::new(); + let mut may_diverge = HashSet::new(); + for (n, rest) in &defs { + let refs = referenced_symbols(rest); + if refs.contains("loop") || refs.contains("Async.loop") || fn_self_diverges(n, rest) { + may_diverge.insert(n.clone()); + } + edges.insert( + n.clone(), + refs.into_iter().filter(|r| names.contains(r) && r != n).collect(), + ); + } + let reach = |from: &str| -> HashSet { + let mut seen = HashSet::new(); + let mut stack = vec![from.to_string()]; + while let Some(x) = stack.pop() { + for y in edges.get(&x).into_iter().flatten() { + if seen.insert(y.clone()) { + stack.push(y.clone()); + } + } + } + seen + }; + let mut mutual = HashSet::new(); + for (n, _) in &defs { + if reach(n).contains(n) { + mutual.insert(n.clone()); + } + } + may_diverge.extend(mutual.iter().cloned()); + loop { + let before = may_diverge.len(); + for (n, es) in &edges { + if es.iter().any(|g| may_diverge.contains(g)) { + may_diverge.insert(n.clone()); + } + } + if may_diverge.len() == before { + break; + } + } + ProgramFacts { + mutual, + may_diverge, + } +} + +/// Self-recursion check over the tail of a `[fn name ...]` form (params, +/// optional effect annotation, body — or multi-arity clauses). +pub fn fn_self_diverges(name: &str, rest: &[Expr]) -> bool { + match rest.first().map(|e| &e.kind) { + Some(ExprKind::List(params)) => { + let ps = param_names(params); + let mut body = &rest[1..]; + if matches!(body.first().map(|e| &e.kind), Some(ExprKind::Set(_))) && body.len() > 1 { + body = &body[1..]; + } + recursion_diverges(name, &ps, body) + } + // Multi-arity: clauses call each other by name; stay conservative. + _ => referenced_symbols(rest).contains(name) || referenced_symbols(rest).contains("recur"), + } +} + +/// Positional parameter names (`""` for destructuring params, stopping at `&`). +pub fn param_names(params: &[Expr]) -> Vec { + params + .iter() + .take_while(|p| !matches!(&p.kind, ExprKind::Symbol(s) if s == "&")) + .map(|p| match &p.kind { + ExprKind::Symbol(s) => s.clone(), + _ => String::new(), + }) + .collect() +} diff --git a/crates/loon-lang/src/effects/mod.rs b/crates/loon-lang/src/effects/mod.rs index cf9d64d..7071e42 100644 --- a/crates/loon-lang/src/effects/mod.rs +++ b/crates/loon-lang/src/effects/mod.rs @@ -102,6 +102,12 @@ impl EffectRegistry { op("exec", &["command"]), ], }); + // Possible nontermination. Inferred by the checker, never performed + // explicitly and never granted: it has no operations. + reg.register(EffectDecl { + name: "Div".to_string(), + operations: vec![], + }); reg.register(EffectDecl { name: "Async".to_string(), operations: vec![ diff --git a/crates/loon-lang/src/errors/codes.rs b/crates/loon-lang/src/errors/codes.rs index 5d62b01..7590b01 100644 --- a/crates/loon-lang/src/errors/codes.rs +++ b/crates/loon-lang/src/errors/codes.rs @@ -36,6 +36,7 @@ pub enum ErrorCode { E0402, // unknown effect operation E0403, // effect mismatch E0404, // effect not granted (pkg.oo capability violation) + E0405, // annotated total but may diverge (Div) // Module errors E0500, // unresolved module @@ -76,6 +77,7 @@ impl ErrorCode { ErrorCode::E0402 => "E0402", ErrorCode::E0403 => "E0403", ErrorCode::E0404 => "E0404", + ErrorCode::E0405 => "E0405", ErrorCode::E0600 => "E0600", ErrorCode::E0601 => "E0601", ErrorCode::E0602 => "E0602", @@ -108,7 +110,8 @@ impl ErrorCode { | ErrorCode::E0401 | ErrorCode::E0402 | ErrorCode::E0403 - | ErrorCode::E0404 => "effect", + | ErrorCode::E0404 + | ErrorCode::E0405 => "effect", ErrorCode::E0500 | ErrorCode::E0501 | ErrorCode::E0502 => "module", ErrorCode::E0600 | ErrorCode::E0601 | ErrorCode::E0602 => "placement", ErrorCode::W0100 => "warning", @@ -139,6 +142,7 @@ impl ErrorCode { ErrorCode::E0402 => "unknown effect operation", ErrorCode::E0403 => "effect mismatch", ErrorCode::E0404 => "effect not granted", + ErrorCode::E0405 => "may not terminate", ErrorCode::E0600 => "not allowed inside a kernel", ErrorCode::E0601 => "kernel signature is not placeable", ErrorCode::E0602 => "kernel writes outside its own work item", diff --git a/crates/loon-lang/src/errors/tutorials.rs b/crates/loon-lang/src/errors/tutorials.rs index 337775b..ae9c841 100644 --- a/crates/loon-lang/src/errors/tutorials.rs +++ b/crates/loon-lang/src/errors/tutorials.rs @@ -48,6 +48,7 @@ pub fn get_tutorial(code: ErrorCode) -> Option { ErrorCode::E0402 => None, ErrorCode::E0403 => Some(tutorial_effect_mismatch()), ErrorCode::E0404 => None, + ErrorCode::E0405 => Some(tutorial_may_diverge()), ErrorCode::E0500 => Some(tutorial_unresolved_module()), ErrorCode::E0501 => Some(tutorial_private_symbol()), ErrorCode::E0502 => Some(tutorial_circular_dependency()), @@ -656,6 +657,44 @@ fn tutorial_unhandled_effect() -> Tutorial { } } +fn tutorial_may_diverge() -> Tutorial { + Tutorial { + code: ErrorCode::E0405, + title: "Annotated total, but may not terminate".to_string(), + steps: vec![ + TutorialStep::Text( + "Nontermination is an effect: `Div`. The checker infers it like \ + IO. Structural recursion (every recursive call is on a strict \ + subterm bound by a `match` pattern, e.g. `rest` in \ + `[Cons x rest]`) is total; any other recursion, `loop`, \ + mutual recursion, or a call to a `Div` function adds `Div`. \ + An explicit `#{}` claims the function is pure and total, so \ + an inferred `Div` is an error. `Div` is not a capability: it \ + is never granted in pkg.oo." + .to_string(), + ), + TutorialStep::Demo { + code: r#"[fn collatz [n] / #{} + [if [<= n 1] 0 [+ 1 [collatz [if [= 0 [% n 2]] [/ n 2] [+ 1 [* 3 n]]]]]]]"# + .to_string(), + explanation: "`n` is not a subterm of a matched constructor, so `Div` is inferred." + .to_string(), + }, + TutorialStep::Fix { + before: r#"[fn collatz [n] / #{} ...]"#.to_string(), + after: r#"[fn collatz [n] / #{Div} ...]"#.to_string(), + explanation: "Admit possible divergence, or rewrite as structural recursion." + .to_string(), + }, + TutorialStep::Try { + prompt: "Write a total length function over a vector.".to_string(), + hint: "Try: [fn len [xs] [match xs #[] 0 #[_ & rest] [+ 1 [len rest]]]]".to_string(), + expected_output: None, + }, + ], + } +} + fn tutorial_undeclared_effect() -> Tutorial { Tutorial { code: ErrorCode::E0401, diff --git a/crates/loon-lang/src/lib.rs b/crates/loon-lang/src/lib.rs index ba70e2b..9c2aa3e 100644 --- a/crates/loon-lang/src/lib.rs +++ b/crates/loon-lang/src/lib.rs @@ -15,3 +15,4 @@ pub mod pkg; pub mod prelude; pub mod syntax; pub mod types; +pub mod verify; diff --git a/crates/loon-lang/src/verify/bounded.rs b/crates/loon-lang/src/verify/bounded.rs new file mode 100644 index 0000000..103acae --- /dev/null +++ b/crates/loon-lang/src/verify/bounded.rs @@ -0,0 +1,641 @@ +//! Bounded falsification: evaluate both sides of a law on small inputs in the +//! EIR VM and report the smallest counterexample. +//! +//! Both sides of every input are evaluated in one generated program by the +//! same backend (`eval_eir`), printed with `str`, and compared as text. The +//! reference definitions are renamed `vref-NAME` in that program because the +//! checker resolves builtin names (`map`, `reverse`, ...) ahead of user fns; +//! `builtin-NAME` in a bridge law is rewritten to the builtin `NAME`. + +use super::kernel::{head_sym, list, subst, sym}; +use super::Defs; +use crate::ast::{Expr, ExprKind}; +use crate::syntax::Span; +use crate::types::Type; +use std::collections::HashMap; + +/// Cap on the number of inputs evaluated per law. +pub const MAX_INPUTS: usize = 1500; +const ELEMS: [i64; 3] = [0, 1, 2]; + +#[derive(Clone, Debug)] +pub enum Kind { + /// A list-shaped ADT: (type name, nil ctor, cons ctor) + List(String, String, String), + /// Any other ADT from defs.oo: (type name, [(ctor, recursive-field flags)]). + /// Values are enumerated as trees of increasing node count. + Adt(String, Vec<(String, Vec)>), + /// An ADT whose type arguments are themselves ADTs (e.g. `List Instr`): + /// the checker's type plus its values grouped by size, precomputed. + Typed(Type, Vec>), + Int, + Bool, + Fn1, + Unsupported(String), +} + +#[derive(Debug, Default)] +pub struct Bounded { + pub checked: usize, + /// (assignment, lhs value, rhs value) + pub counterexample: Option<(Vec<(String, Expr)>, String, String)>, + pub error: Option, +} + +/// Rename reference fns to `vref-NAME`, and `builtin-NAME` to `NAME`. +pub fn mangle(e: &Expr, defs: &Defs) -> Expr { + match &e.kind { + ExprKind::Symbol(s) if defs.fns.contains_key(s) => sym(&format!("vref-{s}")), + ExprKind::Symbol(s) if s.starts_with("builtin-") => sym(&s["builtin-".len()..]), + _ => { + let mut e2 = e.clone(); + mangle_children(&mut e2, defs); + e2 + } + } +} + +fn mangle_children(e: &mut Expr, defs: &Defs) { + use ExprKind::*; + match &mut e.kind { + List(v) | Vec(v) | Set(v) | Tuple(v) => { + for c in v.iter_mut() { + *c = mangle(c, defs); + } + } + Map(ps) => { + for (k, v) in ps.iter_mut() { + *k = mangle(k, defs); + *v = mangle(v, defs); + } + } + Quote(x) | Unquote(x) | UnquoteSplice(x) | DotAccess(x, _) => { + **x = mangle(x, defs); + } + _ => {} + } +} + +/// Infer each law parameter's kind by checking `[fn [params] #[lhs rhs]]` +/// against the evaluation prelude. +pub fn param_kinds(prelude_src: &str, params: &[String], lhs: &Expr, rhs: &Expr, defs: &Defs) -> Vec { + // Prefer verify's own inference (generalizes top-level fns); fall back + // to the language checker when it cannot type the law. + if let Some(ts) = super::infer::law_param_types(defs, &defs.fn_order, params, lhs, rhs) { + return ts.iter().map(|t| kind_of(&super::infer::to_checker(t), defs)).collect(); + } + let Ok(prefix) = crate::parser::parse(prelude_src) else { + return params.iter().map(|_| Kind::Unsupported("prelude parse error".into())).collect(); + }; + // Only the fns the law reaches: the checker does not generalize top-level + // fns, so an unrelated use (`append` on instructions in `compile`) would + // otherwise fix the element type of every list law. + let prefix = reachable_forms(prefix, &[mangle(lhs, defs), mangle(rhs, defs)]); + let mut checker = crate::check::Checker::new(); + checker.check_program(&prefix); + let lam = list(vec![ + sym("fn"), + list(params.iter().map(|p| sym(p)).collect()), + Expr::new(ExprKind::Vec(vec![mangle(lhs, defs), mangle(rhs, defs)]), Span::ZERO), + ]); + // Round-trip through text so the checker sees fresh node ids and spans. + let lam = crate::parser::parse(&format!("{lam}")) + .ok() + .and_then(|mut v| v.pop()) + .unwrap_or(lam); + let ty = checker.infer(&lam); + let ty = checker.resolve(&ty); + let Type::Fn(ps, _, _) = ty else { + return params.iter().map(|_| Kind::Unsupported("could not infer types".into())).collect(); + }; + let scrut: Vec> = params + .iter() + .map(|p| scrutinized_type(p, lhs, defs).or_else(|| scrutinized_type(p, rhs, defs))) + .collect(); + // A param passed to a reference fn only in a non-scrutinized position + // (e.g. `p` in `[mul [add a b] p]`) takes the law's ADT, when the law's + // scrutinized params agree on exactly one non-list ADT. + let mut adts: Vec<&String> = scrutinized_adts(&scrut, defs); + adts.dedup(); + params + .iter() + .zip(&ps) + .zip(&scrut) + .map(|((p, t), sc)| match checker.resolve(t) { + // Unconstrained by the checker: if the law scrutinizes it through + // a reference fn, it has that fn's ADT type. + Type::Var(_) => match sc { + Some(ty) => kind_of(&Type::Con(ty.clone(), vec![Type::Int]), defs), + None if adts.len() == 1 && (fn_arg(p, lhs, defs) || fn_arg(p, rhs, defs)) => { + kind_of(&Type::Con(adts[0].clone(), vec![]), defs) + } + None => Kind::Int, + }, + t => kind_of(&t, defs), + }) + .collect() +} + +fn scrutinized_adts<'a>(scrut: &'a [Option], defs: &Defs) -> Vec<&'a String> { + let mut v: Vec<&String> = scrut + .iter() + .flatten() + .filter(|t| !matches!(kind_of(&Type::Con((*t).clone(), vec![]), defs), Kind::List(..))) + .collect(); + v.sort(); + v +} + +/// Does `p` appear as a direct argument of a reference fn application? +fn fn_arg(p: &str, e: &Expr, defs: &Defs) -> bool { + let ExprKind::List(items) = &e.kind else { return false }; + if head_sym(e).is_some_and(|h| defs.fns.contains_key(h)) + && items[1..].iter().any(|a| matches!(&a.kind, ExprKind::Symbol(s) if s == p)) + { + return true; + } + items.iter().any(|a| fn_arg(p, a, defs)) +} + +/// `type` forms, plus the `fn` forms transitively referenced from `roots`. +fn reachable_forms(forms: Vec, roots: &[Expr]) -> Vec { + use std::collections::HashSet; + let fn_name = |e: &Expr| -> Option { + match (&e.kind, head_sym(e)) { + (ExprKind::List(v), Some("fn")) => match v.get(1).map(|x| &x.kind) { + Some(ExprKind::Symbol(s)) => Some(s.clone()), + _ => None, + }, + _ => None, + } + }; + let mut want = HashSet::new(); + for r in roots { + super::kernel::symbols(r, &mut want); + } + let mut keep: HashSet = HashSet::new(); + loop { + let mut grew = false; + for f in &forms { + if let Some(n) = fn_name(f) { + if want.contains(&n) && keep.insert(n) { + super::kernel::symbols(f, &mut want); + grew = true; + } + } + } + if !grew { + break; + } + } + forms + .into_iter() + .filter(|f| fn_name(f).map_or(true, |n| keep.contains(&n))) + .collect() +} + +/// The ADT of `p` if it appears as the scrutinized argument of a reference fn. +fn scrutinized_type(p: &str, e: &Expr, defs: &Defs) -> Option { + if let (Some(h), ExprKind::List(items)) = (head_sym(e), &e.kind) { + if let Some(f) = defs.fns.get(h) { + if let Some(i) = f.scrutinee { + if matches!(items.get(i + 1).map(|a| &a.kind), Some(ExprKind::Symbol(s)) if s == p) { + if let ExprKind::List(m) = &f.body.kind { + for pat in m[2..].iter().step_by(2) { + let c = match &pat.kind { + ExprKind::Symbol(c) => Some(c.as_str()), + _ => head_sym(pat), + }; + if let Some(t) = c.and_then(|c| defs.type_of_ctor(c)) { + return Some(t); + } + } + } + } + } + } + for a in &items[1..] { + if let Some(t) = scrutinized_type(p, a, defs) { + return Some(t); + } + } + } + None +} + +fn is_intish(t: &Type) -> bool { + matches!(t, Type::Int | Type::Var(_)) +} + +fn kind_of(t: &Type, defs: &Defs) -> Kind { + match t { + Type::Int | Type::Var(_) => Kind::Int, + Type::Bool => Kind::Bool, + Type::Fn(ps, r, _) if ps.len() == 1 && is_intish(&ps[0]) && is_intish(r) => Kind::Fn1, + Type::Con(name, args) if defs.types.contains_key(name) => { + if args.iter().any(|a| !is_intish(a)) { + let gs: Vec> = (0..=TYPED_MAX_SIZE).map(|n| typed_values(t, n, defs, 0)).collect(); + if gs.iter().all(|g| g.is_empty()) { + return Kind::Unsupported(format!("{name} of non-Int elements")); + } + return Kind::Typed(t.clone(), gs); + } + let ctors = &defs.types[name]; + let nil = ctors.iter().find(|c| c.recursive.is_empty()); + let cons = ctors + .iter() + .find(|c| c.recursive.len() == 2 && !c.recursive[0] && c.recursive[1]); + match (ctors.len(), nil, cons) { + (2, Some(n), Some(c)) => Kind::List(name.clone(), n.name.clone(), c.name.clone()), + _ if nil.is_some() => Kind::Adt( + name.clone(), + ctors.iter().map(|c| (c.name.clone(), c.recursive.clone())).collect(), + ), + _ => { + let gs: Vec> = (0..=TYPED_MAX_SIZE).map(|n| typed_values(t, n, defs, 0)).collect(); + Kind::Typed(t.clone(), gs) + } + } + } + other => Kind::Unsupported(format!("{other:?}")), + } +} + +const TYPED_MAX_SIZE: usize = 6; +const TYPED_CAP: usize = 200; + +/// All values (capped) of type `t` with exactly `n` non-nullary constructor +/// nodes. Ints and Bools are leaves of size 0; ints range over `ELEMS`. +/// Generic over any ADT in defs.oo, instantiating type parameters. +pub fn typed_values(t: &Type, n: usize, defs: &Defs, depth: usize) -> Vec { + if depth > 64 { + return vec![]; + } + match t { + Type::Int | Type::Var(_) => if n == 0 { ELEMS.iter().map(|e| super::kernel::int(*e)).collect() } else { vec![] }, + Type::Bool => if n == 0 { vec![Expr::new(ExprKind::Bool(false), Span::ZERO), Expr::new(ExprKind::Bool(true), Span::ZERO)] } else { vec![] }, + Type::Con(name, args) if defs.types.contains_key(name) => { + let params = defs.type_params.get(name).cloned().unwrap_or_default(); + fn conv(f: &Expr, params: &[String], args: &[Type]) -> Option { + match &f.kind { + ExprKind::Symbol(s) => match params.iter().position(|p| p == s) { + Some(i) => Some(args.get(i).cloned().unwrap_or(Type::Int)), + None if s == "Int" => Some(Type::Int), + None if s == "Bool" => Some(Type::Bool), + None => Some(Type::Con(s.clone(), vec![])), + }, + ExprKind::List(v) | ExprKind::Tuple(v) => match v.first().map(|e| &e.kind) { + Some(ExprKind::Symbol(h)) => Some(Type::Con( + h.clone(), + v[1..].iter().map(|a| conv(a, params, args)).collect::>>()?, + )), + _ => None, + }, + _ => None, + } + } + let mut out = Vec::new(); + for c in &defs.types[name] { + if c.fields.is_empty() { + if n == 0 { + out.push(sym(&c.name)); + } + continue; + } + if n == 0 { + continue; + } + let Some(ftys) = c.fields.iter().map(|f| conv(f, ¶ms, args)).collect::>>() else { + continue; + }; + // Distribute n-1 over the fields, in field order. + let mut partial: Vec<(Vec, usize)> = vec![(vec![], n - 1)]; + for (fi, ft) in ftys.iter().enumerate() { + let last = fi + 1 == ftys.len(); + let mut next = Vec::new(); + 'outer: for (vals, left) in &partial { + let sizes: Vec = if last { vec![*left] } else { (0..=*left).collect() }; + for sz in sizes { + for v in typed_values(ft, sz, defs, depth + 1) { + let mut v2 = vals.clone(); + v2.push(v); + next.push((v2, left - sz)); + if next.len() >= TYPED_CAP { + break 'outer; + } + } + } + } + partial = next; + } + for (vals, _) in partial { + if out.len() >= TYPED_CAP { + break; + } + let mut v = vec![sym(&c.name)]; + v.extend(vals); + out.push(list(v)); + } + } + out + } + _ => vec![], + } +} + +/// Values of `kind` grouped by size 0..=bound. +fn groups(kind: &Kind, bound: usize, rng: &mut u64) -> Vec> { + let mut out = Vec::new(); + match kind { + Kind::List(_, nil, cons) => { + let mut layer: Vec = vec![sym(nil)]; + out.push(layer.clone()); + for _ in 0..bound { + let mut next = Vec::new(); + for e in ELEMS { + for tail in &layer { + next.push(list(vec![sym(cons), super::kernel::int(e), tail.clone()])); + } + } + out.push(next.clone()); + layer = next; + } + } + Kind::Adt(_, ctors) => { + // by_size[n] = all trees with exactly n constructor nodes (capped). + const CAP: usize = 200; + let mut by_size: Vec> = vec![Vec::new()]; + for n in 1..=bound + 1 { + let mut layer = Vec::new(); + for (name, flags) in ctors { + let recs = flags.iter().filter(|r| **r).count(); + if recs == 0 { + if n != 1 { + continue; + } + } else if n < 1 + recs { + continue; + } + // distribute n-1 nodes over the recursive fields + let mut combos: Vec> = vec![Vec::new()]; + let mut left_opts: Vec = vec![n - 1]; + for (fi, rec) in flags.iter().enumerate() { + let last_rec = flags[fi + 1..].iter().all(|r| !r); + let mut nc = Vec::new(); + let mut nl = Vec::new(); + for (c, left) in combos.iter().zip(&left_opts) { + if *rec { + let sizes: Vec = if last_rec { vec![*left] } else { (1..=*left).collect() }; + for s in sizes { + for v in by_size.get(s).into_iter().flatten() { + let mut c2 = c.clone(); + c2.push(v.clone()); + nc.push(c2); + nl.push(left - s); + } + } + } else { + for e in ELEMS { + let mut c2 = c.clone(); + c2.push(super::kernel::int(e)); + nc.push(c2); + nl.push(*left); + } + } + if nc.len() >= CAP { + break; + } + } + combos = nc; + left_opts = nl; + } + for (c, left) in combos.into_iter().zip(left_opts) { + if left != 0 || layer.len() >= CAP { + continue; + } + layer.push(if c.is_empty() { + sym(name) + } else { + let mut v = vec![sym(name)]; + v.extend(c); + list(v) + }); + } + } + by_size.push(layer); + } + out.extend(by_size.into_iter().skip(1).filter(|g| !g.is_empty())); + } + Kind::Int => { + out.push(vec![super::kernel::int(0)]); + for k in 1..=bound as i64 { + let r = (splitmix(rng) % 41) as i64 - 20; + out.push(vec![super::kernel::int(k), super::kernel::int(-k), super::kernel::int(r)]); + } + } + Kind::Bool => { + out.push(vec![Expr::new(ExprKind::Bool(false), Span::ZERO)]); + out.push(vec![Expr::new(ExprKind::Bool(true), Span::ZERO)]); + } + Kind::Fn1 => { + let parse = |s: &str| crate::parser::parse(s).unwrap().pop().unwrap(); + out.push(vec![parse("[fn [x] [+ x 1]]")]); + out.push(vec![parse("[fn [x] [* x 2]]"), parse("[fn [x] 0]")]); + } + Kind::Typed(_, gs) => { + out.extend(gs.iter().take(bound + 1).cloned()); + } + Kind::Unsupported(_) => {} + } + out +} + +fn splitmix(state: &mut u64) -> u64 { + *state = state.wrapping_add(0x9E37_79B9_7F4A_7C15); + let mut z = *state; + z = (z ^ (z >> 30)).wrapping_mul(0xBF58_476D_1CE4_E5B9); + z = (z ^ (z >> 27)).wrapping_mul(0x94D0_49BB_1331_11EB); + z ^ (z >> 31) +} + +/// Inputs in order of increasing total size, capped at `MAX_INPUTS`. +fn inputs(kinds: &[Kind], bound: usize, seed: u64) -> Vec> { + let mut rng = seed; + let gs: Vec>> = kinds.iter().map(|k| groups(k, bound, &mut rng)).collect(); + if kinds.is_empty() { + return vec![vec![]]; + } + let max_total: usize = gs.iter().map(|g| g.len().saturating_sub(1)).sum(); + let mut out = Vec::new(); + for total in 0..=max_total { + let mut sizes = vec![0usize; kinds.len()]; + compositions(&gs, total, 0, &mut sizes, &mut |sizes| { + product(&gs, sizes, 0, &mut Vec::new(), &mut out); + }); + if out.len() >= MAX_INPUTS { + out.truncate(MAX_INPUTS); + break; + } + } + out +} + +fn compositions(gs: &[Vec>], left: usize, i: usize, sizes: &mut Vec, f: &mut dyn FnMut(&[usize])) { + if i == gs.len() { + if left == 0 { + f(sizes); + } + return; + } + for s in 0..gs[i].len().min(left + 1) { + sizes[i] = s; + compositions(gs, left - s, i + 1, sizes, f); + } +} + +fn product(gs: &[Vec>], sizes: &[usize], i: usize, cur: &mut Vec, out: &mut Vec>) { + if out.len() >= MAX_INPUTS { + return; + } + if i == gs.len() { + out.push(cur.clone()); + return; + } + for v in &gs[i][sizes[i]] { + cur.push(v.clone()); + product(gs, sizes, i + 1, cur, out); + cur.pop(); + } +} + +/// Evaluate a law on bounded inputs. +#[allow(clippy::too_many_arguments)] +pub fn check_law( + prelude_src: &str, + params: &[String], + kinds: &[Kind], + lhs: &Expr, + rhs: &Expr, + defs: &Defs, + bound: usize, + seed: u64, +) -> Bounded { + if let Some((p, Kind::Unsupported(why))) = params.iter().zip(kinds).find(|(_, k)| matches!(k, Kind::Unsupported(_))) { + return Bounded { + error: Some(format!("cannot generate `{p}`: {why}")), + ..Default::default() + }; + } + let ins = inputs(kinds, bound, seed); + let (ml, mr) = (mangle(lhs, defs), mangle(rhs, defs)); + // Each chunk returns its printed values joined by `|` (values here are + // ints, bools, vectors and ADTs, none of which print a `|`). The result + // comes back as main's value, so nothing is written to stdout. + let mut src = String::from(prelude_src); + let mut chunk_names = Vec::new(); + for (ci, chunk) in ins.chunks(100).enumerate() { + let name = format!("__law-chunk-{ci}"); + src.push_str(&format!("\n[fn {name} [] [str")); + for input in chunk { + let m: HashMap = params.iter().cloned().zip(input.iter().cloned()).collect(); + src.push_str(&format!( + "\n {} \"|\" {} \"|\"", + subst(&ml, &m, defs), + subst(&mr, &m, defs) + )); + } + src.push_str("]]"); + chunk_names.push(name); + } + src.push_str("\n[fn main [] [str"); + for n in &chunk_names { + src.push_str(&format!(" [{n}]")); + } + src.push_str("]]\n"); + let run = || -> Result { + let mut sess = crate::eir::vm::Session::new(&src, std::path::Path::new("."), Default::default())?; + sess.start()?; + Ok(sess.show(sess.value())) + }; + let out = match run() { + Ok(s) => s, + Err(e) => { + return Bounded { + error: Some(format!("evaluation failed: {e}")), + ..Default::default() + } + } + }; + let lines: Vec = out.split('|').map(str::to_string).collect(); + let lines = &lines[..lines.len().saturating_sub(1)]; + if lines.len() != ins.len() * 2 { + return Bounded { + error: Some(format!("expected {} values, got {}", ins.len() * 2, lines.len())), + ..Default::default() + }; + } + for (i, input) in ins.iter().enumerate() { + let (l, r) = (&lines[2 * i], &lines[2 * i + 1]); + if l != r { + return Bounded { + checked: i + 1, + counterexample: Some((params.iter().cloned().zip(input.iter().cloned()).collect(), l.clone(), r.clone())), + error: None, + }; + } + } + Bounded { + checked: ins.len(), + ..Default::default() + } +} + +/// Render a value term (literal input or printed output) as JSON: list-shaped +/// ADTs and vectors become arrays, ints numbers, bools booleans. +pub fn to_json(e: &Expr, defs: &Defs) -> serde_json::Value { + use serde_json::Value as J; + match &e.kind { + ExprKind::Int(n) => J::from(*n), + ExprKind::Bool(b) => J::Bool(*b), + ExprKind::Symbol(s) if defs.is_ctor(s) && is_nil(s, defs) && is_list_type(s, defs) => J::Array(vec![]), + ExprKind::Vec(v) => J::Array(v.iter().map(|x| to_json(x, defs)).collect()), + ExprKind::List(v) if v.len() == 3 && head_sym(e).is_some_and(|h| is_cons(h, defs)) => { + let mut arr = vec![to_json(&v[1], defs)]; + match to_json(&v[2], defs) { + J::Array(rest) => arr.extend(rest), + _ => return J::String(format!("{e}")), + } + J::Array(arr) + } + _ => J::String(format!("{e}")), + } +} + +/// Is `ctor` a constructor of a list-shaped ADT (rendered as a JSON array)? +fn is_list_type(ctor: &str, defs: &Defs) -> bool { + defs.types.values().any(|cs| { + cs.iter().any(|c| c.name == ctor) + && cs.len() == 2 + && cs.iter().any(|c| c.recursive.len() == 2 && !c.recursive[0] && c.recursive[1]) + }) +} + +fn is_nil(s: &str, defs: &Defs) -> bool { + defs.types.values().flatten().any(|c| c.name == s && c.recursive.is_empty()) +} + +fn is_cons(s: &str, defs: &Defs) -> bool { + defs.types + .values() + .flatten() + .any(|c| c.name == s && c.recursive.len() == 2 && c.recursive[1]) + && is_list_type(s, defs) +} + +/// Parse a printed value back to a term for JSON rendering. +pub fn value_json(printed: &str, defs: &Defs) -> serde_json::Value { + match crate::parser::parse(printed) { + Ok(mut v) if v.len() == 1 => to_json(&v.pop().unwrap(), defs), + _ => serde_json::Value::String(printed.to_string()), + } +} diff --git a/crates/loon-lang/src/verify/infer.rs b/crates/loon-lang/src/verify/infer.rs new file mode 100644 index 0000000..1bb46f7 --- /dev/null +++ b/crates/loon-lang/src/verify/infer.rs @@ -0,0 +1,306 @@ +//! A small Hindley-Milner inference for the reference prelude and laws. +//! +//! Untrusted: it only decides which ADT a law parameter ranges over (for the +//! kernel's `induction`/`cases` and for the bounded generator). The language +//! checker is not used for this because it does not generalize top-level fns +//! and shares one instantiation of a constructor across a function, so a list +//! of instructions in `compile` fixes the element type of every list law. +//! +//! Supported forms: integer/bool literals, variables, constructor +//! applications, calls to reference fns (let-polymorphic, in definition +//! order), calls of function-typed variables, `match`, `+ - *`, and `fn` +//! lambdas. Anything else makes inference fail (`None`), and callers fall +//! back to the checker. + +use super::kernel::{head_sym, Ty}; +use super::Defs; +use crate::ast::{Expr, ExprKind}; +use std::collections::HashMap; + +#[derive(Clone, Debug, PartialEq)] +pub enum T { + Var(usize), + Con(String, Vec), +} + +const ARROW: &str = "->"; + +struct Inf<'a> { + defs: &'a Defs, + subst: Vec>, + /// Generalized fn schemes: (number of quantified vars, type over Var(0..n)). + schemes: HashMap, +} + +impl Inf<'_> { + fn fresh(&mut self) -> T { + self.subst.push(None); + T::Var(self.subst.len() - 1) + } + + fn resolve(&self, t: &T) -> T { + match t { + T::Var(v) => match &self.subst[*v] { + Some(t) => self.resolve(t), + None => t.clone(), + }, + T::Con(n, a) => T::Con(n.clone(), a.iter().map(|x| self.resolve(x)).collect()), + } + } + + fn occurs(&self, v: usize, t: &T) -> bool { + match self.resolve(t) { + T::Var(w) => v == w, + T::Con(_, a) => a.iter().any(|x| self.occurs(v, x)), + } + } + + fn unify(&mut self, a: &T, b: &T) -> Option<()> { + match (self.resolve(a), self.resolve(b)) { + (T::Var(x), T::Var(y)) if x == y => Some(()), + (T::Var(x), t) | (t, T::Var(x)) => { + if self.occurs(x, &t) { + return None; + } + self.subst[x] = Some(t); + Some(()) + } + (T::Con(n, xs), T::Con(m, ys)) if n == m && xs.len() == ys.len() => { + for (x, y) in xs.iter().zip(&ys) { + self.unify(x, y)?; + } + Some(()) + } + _ => None, + } + } + + fn instantiate(&mut self, scheme: &(usize, T)) -> T { + let vars: Vec = (0..scheme.0).map(|_| self.fresh()).collect(); + fn go(t: &T, vars: &[T]) -> T { + match t { + T::Var(i) => vars[*i].clone(), + T::Con(n, a) => T::Con(n.clone(), a.iter().map(|x| go(x, vars)).collect()), + } + } + go(&scheme.1, &vars) + } + + /// Constructor `c`: (field types, result type), freshly instantiated. + fn ctor(&mut self, c: &str) -> Option<(Vec, T)> { + let ty = self.defs.type_of_ctor(c)?; + let params = self.defs.type_params.get(&ty).cloned().unwrap_or_default(); + let inst: Vec = params.iter().map(|_| self.fresh()).collect(); + let info = self.defs.types[&ty].iter().find(|k| k.name == c)?.clone(); + let fields = info.fields.iter().map(|f| self.field(f, ¶ms, &inst)).collect::>>()?; + Some((fields, T::Con(ty, inst))) + } + + fn field(&mut self, f: &Expr, params: &[String], inst: &[T]) -> Option { + match &f.kind { + ExprKind::Symbol(s) => Some(match params.iter().position(|p| p == s) { + Some(i) => inst[i].clone(), + None => T::Con(s.clone(), vec![]), + }), + ExprKind::List(v) | ExprKind::Tuple(v) => { + let Some(ExprKind::Symbol(h)) = v.first().map(|e| &e.kind) else { return None }; + let args = v[1..].iter().map(|a| self.field(a, params, inst)).collect::>>()?; + Some(T::Con(h.clone(), args)) + } + _ => None, + } + } + + fn pattern(&mut self, p: &Expr, t: &T, env: &mut HashMap) -> Option<()> { + match &p.kind { + ExprKind::Symbol(s) if s == "_" => Some(()), + ExprKind::Symbol(s) if self.defs.is_ctor(s) => { + let (fs, r) = self.ctor(s)?; + if !fs.is_empty() { + return None; + } + self.unify(&r, t) + } + ExprKind::Symbol(s) => { + env.insert(s.clone(), t.clone()); + Some(()) + } + ExprKind::Int(_) => self.unify(t, &T::Con("Int".into(), vec![])), + ExprKind::List(v) => { + let c = head_sym(p)?; + let (fs, r) = self.ctor(c)?; + if fs.len() + 1 != v.len() { + return None; + } + self.unify(&r, t)?; + for (sp, ft) in v[1..].iter().zip(&fs) { + self.pattern(sp, ft, env)?; + } + Some(()) + } + _ => None, + } + } + + fn expr(&mut self, e: &Expr, env: &HashMap, current: Option<(&str, &T)>) -> Option { + let int = T::Con("Int".into(), vec![]); + match &e.kind { + ExprKind::Int(_) => Some(int), + ExprKind::Bool(_) => Some(T::Con("Bool".into(), vec![])), + ExprKind::Symbol(s) => { + if let Some(t) = env.get(s) { + return Some(t.clone()); + } + if let Some((n, t)) = current { + if n == s { + return Some(t.clone()); + } + } + if self.defs.is_ctor(s) { + let (fs, r) = self.ctor(s)?; + return fs.is_empty().then_some(r); + } + let sc = self.schemes.get(s)?.clone(); + Some(self.instantiate(&sc)) + } + ExprKind::List(items) => { + let head = head_sym(e); + match head { + Some("match") => { + let st = self.expr(items.get(1)?, env, current)?; + let out = self.fresh(); + for pair in items[2..].chunks(2) { + let [pat, body] = pair else { return None }; + let mut inner = env.clone(); + self.pattern(pat, &st, &mut inner)?; + let bt = self.expr(body, &inner, current)?; + self.unify(&out, &bt)?; + } + Some(out) + } + Some("fn") => { + let ExprKind::List(ps) = &items.get(1)?.kind else { return None }; + if items.len() != 3 { + return None; + } + let mut inner = env.clone(); + let mut pts = Vec::new(); + for p in ps { + let ExprKind::Symbol(s) = &p.kind else { return None }; + let t = self.fresh(); + inner.insert(s.clone(), t.clone()); + pts.push(t); + } + let r = self.expr(&items[2], &inner, current)?; + pts.push(r); + Some(T::Con(ARROW.into(), pts)) + } + Some("+") | Some("-") | Some("*") if items.len() == 3 => { + for a in &items[1..] { + let t = self.expr(a, env, current)?; + self.unify(&t, &int)?; + } + Some(int) + } + Some(c) if self.defs.is_ctor(c) => { + let (fs, r) = self.ctor(c)?; + if fs.len() + 1 != items.len() { + return None; + } + for (a, ft) in items[1..].iter().zip(&fs) { + let t = self.expr(a, env, current)?; + self.unify(&t, ft)?; + } + Some(r) + } + _ => { + let ft = self.expr(items.first()?, env, current)?; + let mut args = Vec::new(); + for a in &items[1..] { + args.push(self.expr(a, env, current)?); + } + let r = self.fresh(); + args.push(r.clone()); + self.unify(&ft, &T::Con(ARROW.into(), args))?; + Some(r) + } + } + } + _ => None, + } + } + + /// Generalize every unresolved variable (top level: the env is empty). + fn generalize(&self, t: &T) -> (usize, T) { + let mut map: HashMap = HashMap::new(); + fn go(t: &T, map: &mut HashMap) -> T { + match t { + T::Var(v) => { + let n = map.len(); + T::Var(*map.entry(*v).or_insert(n)) + } + T::Con(n, a) => T::Con(n.clone(), a.iter().map(|x| go(x, map)).collect()), + } + } + let g = go(&self.resolve(t), &mut map); + (map.len(), g) + } +} + +/// Infer the types of `params` in the law `lhs = rhs`. `fn_order` lists the +/// reference fns in definition order. `None` if anything fails to type. +pub fn law_param_types(defs: &Defs, fn_order: &[String], params: &[String], lhs: &Expr, rhs: &Expr) -> Option> { + let mut inf = Inf { defs, subst: Vec::new(), schemes: HashMap::new() }; + for name in fn_order { + let Some(f) = defs.fns.get(name) else { continue }; + let mut env = HashMap::new(); + let mut pts = Vec::new(); + for p in &f.params { + let t = inf.fresh(); + env.insert(p.clone(), t.clone()); + pts.push(t); + } + let r = inf.fresh(); + pts.push(r.clone()); + let ft = T::Con(ARROW.into(), pts); + let Some(bt) = inf.expr(&f.body, &env, Some((name, &ft))) else { continue }; + if inf.unify(&bt, &r).is_none() { + continue; + } + let sc = inf.generalize(&ft); + inf.schemes.insert(name.clone(), sc); + } + let mut env = HashMap::new(); + let pts: Vec = params.iter().map(|_| inf.fresh()).collect(); + for (p, t) in params.iter().zip(&pts) { + env.insert(p.clone(), t.clone()); + } + let l = inf.expr(lhs, &env, None)?; + let r = inf.expr(rhs, &env, None)?; + inf.unify(&l, &r)?; + Some(pts.iter().map(|t| inf.resolve(t)).collect()) +} + +/// The kernel's view: unresolved variables become `?`. +pub fn to_ty(t: &T) -> Ty { + match t { + T::Var(_) => Ty::unknown(), + T::Con(n, a) => Ty::app(n, a.iter().map(to_ty).collect()), + } +} + +/// The checker's view, for the bounded generator: unresolved variables are +/// instantiated at `Int`, as the generator always did. +pub fn to_checker(t: &T) -> crate::types::Type { + use crate::types::{EffectRow, Type}; + match t { + T::Var(_) => Type::Int, + T::Con(n, a) if n == "Int" && a.is_empty() => Type::Int, + T::Con(n, a) if n == "Bool" && a.is_empty() => Type::Bool, + T::Con(n, a) if n == ARROW && !a.is_empty() => { + let ps = a[..a.len() - 1].iter().map(to_checker).collect(); + Type::Fn(ps, Box::new(to_checker(&a[a.len() - 1])), EffectRow::pure()) + } + T::Con(n, a) => Type::Con(n.clone(), a.iter().map(to_checker).collect()), + } +} diff --git a/crates/loon-lang/src/verify/kernel.rs b/crates/loon-lang/src/verify/kernel.rs new file mode 100644 index 0000000..60c448d --- /dev/null +++ b/crates/loon-lang/src/verify/kernel.rs @@ -0,0 +1,1166 @@ +//! The trusted rewrite kernel. +//! +//! Everything here operates on untyped `Expr` terms. The trusted surface is: +//! substitution, one-step unfolding of a structurally recursive definition, +//! first-order syntactic matching, constructor-`match` reduction (plus +//! constant folding of literal integer arithmetic), and the structural +//! induction scheme for the ADTs declared in `defs.oo`. +//! +//! A case closes when both sides are syntactically equal after *evaluation +//! normalization*: constructor-match reduction plus unfolding of total +//! definitions whose scrutinized argument is a constructor application. Since +//! every unfolded definition is structurally recursive, each unfold consumes a +//! constructor and normalization terminates (a fuel bound backs this up). +//! +//! Both normalizations also canonicalize associative-commutative operators: +//! the builtin `+` always, and each user fn listed in `Defs::ac` (an `ac` +//! declaration whose cited assoc/comm/unit laws were checked for shape and +//! are proven earlier in dependency order; see `verify/mod.rs`). Operands of +//! a nested application are flattened, unit operands dropped, sorted by their +//! printed form, and rebuilt right-nested. `rewrite` then matches against +//! that canonical form, so operand order in a goal is printed-form order. + +use super::{Defs, FnDef}; +use crate::ast::{Expr, ExprKind}; +use crate::syntax::Span; +use std::collections::{HashMap, HashSet}; + +// ─── Term helpers ────────────────────────────────────────────────────────── + +pub fn sym(s: &str) -> Expr { + Expr::new(ExprKind::Symbol(s.to_string()), Span::ZERO) +} + +pub fn list(items: Vec) -> Expr { + Expr::new(ExprKind::List(items), Span::ZERO) +} + +pub fn int(n: i64) -> Expr { + Expr::new(ExprKind::Int(n), Span::ZERO) +} + +fn with_kind(e: &Expr, kind: ExprKind) -> Expr { + Expr::new(kind, e.span) +} + +/// Structural equality, ignoring spans and node ids. +pub fn term_eq(a: &Expr, b: &Expr) -> bool { + use ExprKind::*; + match (&a.kind, &b.kind) { + (Int(x), Int(y)) => x == y, + (Float(x), Float(y)) => x.to_bits() == y.to_bits(), + (Bool(x), Bool(y)) => x == y, + (Str(x), Str(y)) | (Keyword(x), Keyword(y)) | (Symbol(x), Symbol(y)) => x == y, + (List(x), List(y)) | (Vec(x), Vec(y)) | (Set(x), Set(y)) | (Tuple(x), Tuple(y)) => { + x.len() == y.len() && x.iter().zip(y).all(|(p, q)| term_eq(p, q)) + } + (Map(x), Map(y)) => { + x.len() == y.len() + && x + .iter() + .zip(y) + .all(|((k1, v1), (k2, v2))| term_eq(k1, k2) && term_eq(v1, v2)) + } + (Quote(x), Quote(y)) | (Unquote(x), Unquote(y)) | (UnquoteSplice(x), UnquoteSplice(y)) => { + term_eq(x, y) + } + (DotAccess(x, f), DotAccess(y, g)) => f == g && term_eq(x, y), + _ => false, + } +} + +/// Immediate children, mutable, in preorder order. +fn children(e: &Expr) -> Vec<&Expr> { + use ExprKind::*; + match &e.kind { + List(v) | Vec(v) | Set(v) | Tuple(v) => v.iter().collect(), + Map(ps) => ps.iter().flat_map(|(k, v)| [k, v]).collect(), + Quote(x) | Unquote(x) | UnquoteSplice(x) | DotAccess(x, _) => vec![x], + _ => vec![], + } +} + +/// Rebuild `e` with its children mapped through `f`. +fn map_children(e: &Expr, f: &mut dyn FnMut(&Expr) -> Expr) -> Expr { + use ExprKind::*; + let kind = match &e.kind { + List(v) => List(v.iter().map(&mut *f).collect()), + Vec(v) => Vec(v.iter().map(&mut *f).collect()), + Set(v) => Set(v.iter().map(&mut *f).collect()), + Tuple(v) => Tuple(v.iter().map(&mut *f).collect()), + Map(ps) => Map(ps.iter().map(|(k, v)| (f(k), f(v))).collect()), + Quote(x) => Quote(Box::new(f(x))), + Unquote(x) => Unquote(Box::new(f(x))), + UnquoteSplice(x) => UnquoteSplice(Box::new(f(x))), + DotAccess(x, s) => DotAccess(Box::new(f(x)), s.clone()), + k => k.clone(), + }; + with_kind(e, kind) +} + +pub fn head_sym(e: &Expr) -> Option<&str> { + match &e.kind { + ExprKind::List(v) => match v.first().map(|h| &h.kind) { + Some(ExprKind::Symbol(s)) => Some(s), + _ => None, + }, + _ => None, + } +} + +/// Every symbol occurring anywhere in `e`. +pub fn symbols(e: &Expr, out: &mut HashSet) { + if let ExprKind::Symbol(s) = &e.kind { + out.insert(s.clone()); + } + for c in children(e) { + symbols(c, out); + } +} + +/// Variables bound by a match pattern (symbols that are not constructors, +/// `_`, or literals). +pub fn pattern_vars(p: &Expr, defs: &Defs, out: &mut Vec) { + match &p.kind { + ExprKind::Symbol(s) if s != "_" && !defs.is_ctor(s) => out.push(s.clone()), + ExprKind::List(v) => { + for (i, c) in v.iter().enumerate() { + if i == 0 && matches!(c.kind, ExprKind::Symbol(_)) { + continue; // constructor head + } + pattern_vars(c, defs, out); + } + } + ExprKind::Vec(v) | ExprKind::Tuple(v) => { + for c in v { + pattern_vars(c, defs, out); + } + } + _ => {} + } +} + +/// Binders introduced by `fn` params: `[fn [a b] body]` or `[fn name [a b] body]`. +fn fn_binders(items: &[Expr]) -> Option<(usize, Vec)> { + let idx = match items.get(1).map(|e| &e.kind) { + Some(ExprKind::List(_)) => 1, + Some(ExprKind::Symbol(_)) if matches!(items.get(2).map(|e| &e.kind), Some(ExprKind::List(_))) => 2, + _ => return None, + }; + let ExprKind::List(ps) = &items[idx].kind else { + return None; + }; + Some(( + idx, + ps.iter() + .filter_map(|p| match &p.kind { + ExprKind::Symbol(s) => Some(s.clone()), + _ => None, + }) + .collect(), + )) +} + +/// Capture-respecting substitution of free symbols. Binders (`match` arm +/// patterns, `fn` params) shadow the substitution inside their scope. +pub fn subst(e: &Expr, map: &HashMap, defs: &Defs) -> Expr { + if map.is_empty() { + return e.clone(); + } + match &e.kind { + ExprKind::Symbol(s) => map.get(s).cloned().unwrap_or_else(|| e.clone()), + ExprKind::List(items) if head_sym(e) == Some("match") && items.len() >= 2 => { + let mut out = vec![items[0].clone(), subst(&items[1], map, defs)]; + for pair in items[2..].chunks(2) { + out.push(pair[0].clone()); + if let Some(body) = pair.get(1) { + let mut bound = Vec::new(); + pattern_vars(&pair[0], defs, &mut bound); + let inner: HashMap = map + .iter() + .filter(|(k, _)| !bound.contains(k)) + .map(|(k, v)| (k.clone(), v.clone())) + .collect(); + out.push(subst(body, &inner, defs)); + } + } + with_kind(e, ExprKind::List(out)) + } + ExprKind::List(items) if head_sym(e) == Some("fn") => { + if let Some((idx, bound)) = fn_binders(items) { + let inner: HashMap = map + .iter() + .filter(|(k, _)| !bound.contains(k)) + .map(|(k, v)| (k.clone(), v.clone())) + .collect(); + let mut out: Vec = items[..=idx].to_vec(); + out.extend(items[idx + 1..].iter().map(|b| subst(b, &inner, defs))); + with_kind(e, ExprKind::List(out)) + } else { + map_children(e, &mut |c| subst(c, map, defs)) + } + } + _ => map_children(e, &mut |c| subst(c, map, defs)), + } +} + +/// Rename every pattern-bound variable in `body` to a name not in `used`. +fn freshen_binders(body: &Expr, defs: &Defs, used: &mut HashSet) -> Expr { + match &body.kind { + ExprKind::List(items) if head_sym(body) == Some("match") && items.len() >= 2 => { + let mut out = vec![items[0].clone(), freshen_binders(&items[1], defs, used)]; + for pair in items[2..].chunks(2) { + let mut bound = Vec::new(); + pattern_vars(&pair[0], defs, &mut bound); + let mut ren = HashMap::new(); + for v in bound { + let nv = fresh_name(&v, used); + ren.insert(v, sym(&nv)); + } + out.push(rename_pattern(&pair[0], &ren)); + if let Some(b) = pair.get(1) { + let b = subst(b, &ren, defs); + out.push(freshen_binders(&b, defs, used)); + } + } + with_kind(body, ExprKind::List(out)) + } + _ => map_children(body, &mut |c| freshen_binders(c, defs, used)), + } +} + +fn rename_pattern(p: &Expr, ren: &HashMap) -> Expr { + match &p.kind { + ExprKind::Symbol(s) => ren.get(s).cloned().unwrap_or_else(|| p.clone()), + _ => map_children(p, &mut |c| rename_pattern(c, ren)), + } +} + +pub fn fresh_name(base: &str, used: &mut HashSet) -> String { + let base = base.trim_end_matches(|c: char| c.is_ascii_digit()); + let base = if base.is_empty() { "v" } else { base }; + let mut cand = base.to_string(); + let mut i = 1; + while used.contains(&cand) { + cand = format!("{base}{i}"); + i += 1; + } + used.insert(cand.clone()); + cand +} + +// ─── Normalization ───────────────────────────────────────────────────────── + +/// Is `e` a constructor value head: a nullary ctor symbol or `[Ctor ...]`? +fn ctor_of<'a>(e: &'a Expr, defs: &Defs) -> Option<(&'a str, &'a [Expr])> { + match &e.kind { + ExprKind::Symbol(s) if defs.is_ctor(s) => Some((s, &[])), + ExprKind::List(v) => match v.first().map(|h| &h.kind) { + Some(ExprKind::Symbol(s)) if defs.is_ctor(s) => Some((s, &v[1..])), + _ => None, + }, + _ => None, + } +} + +enum PatResult { + Match(HashMap), + NoMatch, + Undecided, +} + +fn match_pattern(p: &Expr, v: &Expr, defs: &Defs) -> PatResult { + match &p.kind { + ExprKind::Symbol(s) if s == "_" => PatResult::Match(HashMap::new()), + ExprKind::Symbol(s) if defs.is_ctor(s) => match ctor_of(v, defs) { + Some((c, args)) if c == s && args.is_empty() => PatResult::Match(HashMap::new()), + Some(_) => PatResult::NoMatch, + None => PatResult::Undecided, + }, + ExprKind::Symbol(s) => PatResult::Match(HashMap::from([(s.clone(), v.clone())])), + ExprKind::Int(n) => match v.kind { + ExprKind::Int(m) if m == *n => PatResult::Match(HashMap::new()), + ExprKind::Int(_) => PatResult::NoMatch, + _ => PatResult::Undecided, + }, + ExprKind::List(ps) if head_sym(p).is_some_and(|h| defs.is_ctor(h)) => { + let pc = head_sym(p).unwrap(); + match ctor_of(v, defs) { + Some((c, args)) if c == pc && args.len() == ps.len() - 1 => { + let mut binds = HashMap::new(); + for (sp, sv) in ps[1..].iter().zip(args) { + match match_pattern(sp, sv, defs) { + PatResult::Match(b) => binds.extend(b), + other => return other, + } + } + PatResult::Match(binds) + } + Some(_) => PatResult::NoMatch, + None => PatResult::Undecided, + } + } + _ => PatResult::Undecided, + } +} + +/// Reduce a `match` node whose scrutinee is decided by a constructor. +fn reduce_match(e: &Expr, defs: &Defs) -> Option { + let ExprKind::List(items) = &e.kind else { + return None; + }; + if head_sym(e) != Some("match") || items.len() < 4 { + return None; + } + let scrut = &items[1]; + for pair in items[2..].chunks(2) { + let [pat, body] = pair else { return None }; + match match_pattern(pat, scrut, defs) { + PatResult::Match(b) => return Some(subst(body, &b, defs)), + PatResult::NoMatch => continue, + PatResult::Undecided => return None, + } + } + None +} + +fn fold_arith(e: &Expr) -> Option { + let ExprKind::List(items) = &e.kind else { + return None; + }; + if items.len() != 3 { + return None; + } + let (ExprKind::Int(a), ExprKind::Int(b)) = (&items[1].kind, &items[2].kind) else { + return None; + }; + let r = match head_sym(e)? { + "+" => a.checked_add(*b)?, + "-" => a.checked_sub(*b)?, + "*" => a.checked_mul(*b)?, + _ => return None, + }; + Some(int(r)) +} + +/// Flatten a `+` tree (children already normalized) into its operands. +fn plus_operands(e: &Expr, out: &mut Vec) { + if let ExprKind::List(items) = &e.kind { + if head_sym(e) == Some("+") && items.len() == 3 { + plus_operands(&items[1], out); + plus_operands(&items[2], out); + return; + } + } + out.push(e.clone()); +} + +/// Canonical form for `+`: associativity, commutativity and the zero law, +/// all at once. Literals are summed into one constant placed first; the +/// remaining operands are sorted by their printed form; the result is +/// right-nested. `[+ 1 [+ a b]]`, `[+ [+ 1 a] b]` and `[+ b [+ a 1]]` all +/// become `[+ 1 [+ a b]]`; `[+ 0 n]` becomes `n`. +fn normalize_plus(e: &Expr) -> Option { + let ExprKind::List(items) = &e.kind else { + return None; + }; + if head_sym(e) != Some("+") || items.len() != 3 { + return None; + } + let mut ops = Vec::new(); + plus_operands(e, &mut ops); + let mut constant: i64 = 0; + let mut rest: Vec = Vec::new(); + for op in ops { + match op.kind { + ExprKind::Int(n) => constant = constant.checked_add(n)?, + _ => rest.push(op), + } + } + rest.sort_by_key(|x| x.to_string()); + let mut terms: Vec = Vec::new(); + if constant != 0 || rest.is_empty() { + terms.push(int(constant)); + } + terms.extend(rest); + let mut acc = terms.pop()?; + while let Some(t) = terms.pop() { + acc = Expr::new( + ExprKind::List(vec![Expr::new(ExprKind::Symbol("+".into()), e.span), t, acc]), + e.span, + ); + } + Some(acc) +} + +/// Flatten a user AC-operator tree into its operands. +fn ac_operands(e: &Expr, op: &str, out: &mut Vec) { + if let ExprKind::List(items) = &e.kind { + if head_sym(e) == Some(op) && items.len() == 3 { + ac_operands(&items[1], op, out); + ac_operands(&items[2], op, out); + return; + } + } + out.push(e.clone()); +} + +/// Canonical form for an AC operator application (children already +/// normalized): `+` via `normalize_plus`; an active user operator OP by +/// flattening, dropping its declared unit, sorting operands by printed form, +/// and rebuilding right-nested. One operand is returned bare; none gives the +/// unit. `None` if `e` is not an application of an active AC operator. +fn normalize_ac(e: &Expr, defs: &Defs) -> Option { + let h = head_sym(e)?; + if h == "+" { + return normalize_plus(e); + } + let ac = defs.ac.iter().find(|a| a.op == h)?; + let ExprKind::List(items) = &e.kind else { return None }; + if items.len() != 3 { + return None; + } + let mut ops = Vec::new(); + ac_operands(e, &ac.op, &mut ops); + if let Some(u) = &ac.unit { + ops.retain(|x| !term_eq(x, u)); + } + ops.sort_by_key(|x| x.to_string()); + let Some(mut acc) = ops.pop() else { + return ac.unit.clone(); + }; + while let Some(t) = ops.pop() { + acc = Expr::new(ExprKind::List(vec![items[0].clone(), t, acc]), e.span); + } + Some(acc) +} + +/// Constructor-match normalization plus literal constant folding and AC +/// canonicalization, bottom-up. +pub fn normalize(e: &Expr, defs: &Defs) -> Expr { + let e = map_children(e, &mut |c| normalize(c, defs)); + if let Some(r) = reduce_match(&e, defs) { + return normalize(&r, defs); + } + if let Some(r) = normalize_ac(&e, defs) { + return r; + } + if let Some(r) = fold_arith(&e) { + return r; + } + e +} + +/// Instantiate `f`'s body at `args`, freshening its binders against `used`. +fn instantiate(f: &FnDef, args: &[Expr], defs: &Defs, used: &mut HashSet) -> Expr { + for a in args { + symbols(a, used); + } + let body = freshen_binders(&f.body, defs, used); + let map: HashMap = f + .params + .iter() + .cloned() + .zip(args.iter().cloned()) + .collect(); + subst(&body, &map, defs) +} + +/// Is `e` an application of total fn `name` whose scrutinized argument is a +/// constructor (so unfolding it fires a match)? +fn is_redex(e: &Expr, name: &str, defs: &Defs) -> bool { + let Some(f) = defs.fns.get(name) else { + return false; + }; + let ExprKind::List(items) = &e.kind else { + return false; + }; + if head_sym(e) != Some(name) || items.len() != f.params.len() + 1 { + return false; + } + match f.scrutinee { + Some(i) => ctor_of(&items[i + 1], defs).is_some(), + None => true, + } +} + +/// Evaluation normalization used to close goals: unfold every total +/// definition applied to a constructor in its scrutinized position. +pub fn eval_normalize(e: &Expr, defs: &Defs, used: &mut HashSet, fuel: &mut u32) -> Expr { + let e = map_children(e, &mut |c| eval_normalize(c, defs, used, fuel)); + if let Some(r) = reduce_match(&e, defs) { + return eval_normalize(&r, defs, used, fuel); + } + // A canonical user-AC application may still be a redex (its sorted first + // operand a constructor), so fall through to unfolding with it. + let e = match normalize_ac(&e, defs) { + Some(r) if head_sym(&e) == Some("+") => return r, + Some(r) if head_sym(&r) != head_sym(&e) => return r, + Some(r) => r, + None => e, + }; + if let Some(r) = fold_arith(&e) { + return r; + } + if *fuel == 0 { + return e; + } + if let Some(name) = head_sym(&e) { + if defs.total.contains(name) && defs.fns[name].scrutinee.is_some() && is_redex(&e, name, defs) { + *fuel -= 1; + let ExprKind::List(items) = &e.kind else { unreachable!() }; + let r = instantiate(&defs.fns[name], &items[1..], defs, used); + return eval_normalize(&r, defs, used, fuel); + } + } + e +} + +// ─── Totality (structural recursion) ─────────────────────────────────────── + +/// Compute the set of total functions: structurally recursive on one fixed +/// parameter, calling only total definitions, with no mutual recursion. +pub fn total_fns(defs: &Defs) -> HashSet { + let mut total = HashSet::new(); + let mut state: HashMap = HashMap::new(); // 1 visiting, 2 done + let names: Vec = defs.fns.keys().cloned().collect(); + for n in names { + check_total(&n, defs, &mut state, &mut total); + } + total +} + +fn check_total(name: &str, defs: &Defs, state: &mut HashMap, total: &mut HashSet) -> bool { + match state.get(name) { + Some(2) => return total.contains(name), + Some(1) => return false, // mutual recursion + _ => {} + } + state.insert(name.to_string(), 1); + let f = &defs.fns[name]; + let mut callees = HashSet::new(); + symbols(&f.body, &mut callees); + let mut ok = callees + .iter() + .filter(|c| c.as_str() != name && defs.fns.contains_key(c.as_str())) + .filter(|c| !f.params.contains(c)) + .all(|c| check_total(c, defs, state, total)); + ok = ok && structural(f, name, defs); + state.insert(name.to_string(), 2); + if ok { + total.insert(name.to_string()); + } + ok +} + +fn structural(f: &FnDef, name: &str, defs: &Defs) -> bool { + if f.params.iter().any(|p| p == name) { + return false; + } + let mut calls = Vec::new(); + if !collect_self_calls(&f.body, name, &HashMap::new(), defs, &mut calls) { + return false; + } + if calls.is_empty() { + return true; + } + // Some fixed parameter index i such that every self-call's i-th arg is a + // strict subterm of parameter i. + (0..f.params.len()).any(|i| { + calls.iter().all(|args| { + args.len() == f.params.len() + && matches!(&args[i], Some(p) if *p == i) + }) + }) +} + +/// Walk `e`, tracking which variables are strict subterms of which param +/// (`env`: var -> param index). Each self-call records, per argument, the +/// param it is a strict subterm of. Returns false on a non-call self-reference +/// or on rebinding that would make tracking unsound. +fn collect_self_calls( + e: &Expr, + name: &str, + env: &HashMap, + defs: &Defs, + calls: &mut Vec>>, +) -> bool { + let f = &defs.fns[name]; + match &e.kind { + ExprKind::Symbol(s) => s != name, + ExprKind::List(items) if head_sym(e) == Some(name) => { + calls.push( + items[1..] + .iter() + .map(|a| match &a.kind { + ExprKind::Symbol(s) => env.get(s).copied(), + _ => None, + }) + .collect(), + ); + items[1..].iter().all(|a| collect_self_calls(a, name, env, defs, calls)) + } + ExprKind::List(items) if head_sym(e) == Some("match") && items.len() >= 2 => { + if !collect_self_calls(&items[1], name, env, defs, calls) { + return false; + } + let scrut_param = match &items[1].kind { + ExprKind::Symbol(s) => f.params.iter().position(|p| p == s).filter(|_| !env.contains_key(s)), + _ => None, + }; + // A scrutinee that is itself a tracked subterm stays tracked. + let scrut_sub = match &items[1].kind { + ExprKind::Symbol(s) => env.get(s).copied(), + _ => None, + }; + for pair in items[2..].chunks(2) { + let mut bound = Vec::new(); + pattern_vars(&pair[0], defs, &mut bound); + let is_ctor_pat = matches!(pair[0].kind, ExprKind::List(_)); + let mut inner = env.clone(); + for v in &bound { + inner.remove(v); + if f.params.contains(v) { + return false; // shadowing a param: refuse + } + if is_ctor_pat { + if let Some(i) = scrut_param.or(scrut_sub) { + inner.insert(v.clone(), i); + } + } + } + if let Some(b) = pair.get(1) { + if !collect_self_calls(b, name, &inner, defs, calls) { + return false; + } + } + } + true + } + ExprKind::List(items) if matches!(head_sym(e), Some("let") | Some("fn")) => { + // Conservative: any rebinding of a param or tracked var rejects. + let mut bs = HashSet::new(); + if let Some(b) = items.get(1) { + symbols(b, &mut bs); + } + if bs.iter().any(|b| f.params.contains(b) || env.contains_key(b)) { + return false; + } + items.iter().all(|c| collect_self_calls(c, name, env, defs, calls)) + } + _ => children(e).into_iter().all(|c| collect_self_calls(c, name, env, defs, calls)), + } +} + +// ─── Rewriting ───────────────────────────────────────────────────────────── + +/// A rewrite rule: universally quantified `params` act as pattern variables. +#[derive(Clone, Debug)] +pub struct Rule { + pub params: Vec, + pub lhs: Expr, + pub rhs: Expr, +} + +/// First-order matching. At an application of an active user AC operator +/// the two operands are also tried swapped (matching modulo commutativity), +/// since a pattern's variables sort by name rather than by what they bind. +fn match_term(pat: &Expr, t: &Expr, vars: &[String], b: &mut HashMap, defs: &Defs) -> bool { + let saved = b.clone(); + if match_plain(pat, t, vars, b, defs) { + return true; + } + *b = saved; + let (ExprKind::List(ps), ExprKind::List(ts)) = (&pat.kind, &t.kind) else { return false }; + let is_ac = |e: &Expr| head_sym(e).is_some_and(|h| defs.ac.iter().any(|a| a.op == h)); + if ps.len() != 3 || ts.len() != 3 || !is_ac(pat) || head_sym(pat) != head_sym(t) { + return false; + } + let saved = b.clone(); + if match_term(&ps[1], &ts[2], vars, b, defs) && match_term(&ps[2], &ts[1], vars, b, defs) { + return true; + } + *b = saved; + false +} + +fn match_plain(pat: &Expr, t: &Expr, vars: &[String], b: &mut HashMap, defs: &Defs) -> bool { + if let ExprKind::Symbol(s) = &pat.kind { + if vars.contains(s) { + if let Some(prev) = b.get(s) { + return term_eq(prev, t); + } + b.insert(s.clone(), t.clone()); + return true; + } + } + let (pc, tc) = (children(pat), children(t)); + let same_kind = std::mem::discriminant(&pat.kind) == std::mem::discriminant(&t.kind); + if !same_kind || pc.len() != tc.len() { + return false; + } + if pc.is_empty() { + return term_eq(pat, t); + } + if let (ExprKind::DotAccess(_, f), ExprKind::DotAccess(_, g)) = (&pat.kind, &t.kind) { + if f != g { + return false; + } + } + pc.iter().zip(tc).all(|(p, x)| match_term(p, x, vars, b, defs)) +} + +/// Preorder walk replacing the `target`-th match of `rule`. Returns the new +/// term if a replacement happened. +fn rewrite_nth(t: &Expr, rule: &Rule, target: usize, seen: &mut usize, defs: &Defs) -> Option { + let mut b = HashMap::new(); + if match_term(&rule.lhs, t, &rule.params, &mut b, defs) { + if *seen == target { + return Some(subst(&rule.rhs, &b, defs)); + } + *seen += 1; + } + let mut done = false; + let out = map_children(t, &mut |c| { + if done { + return c.clone(); + } + match rewrite_nth(c, rule, target, seen, defs) { + Some(r) => { + done = true; + r + } + None => c.clone(), + } + }); + done.then_some(out) +} + +pub fn rewrite(t: &Expr, rule: &Rule, at: usize, defs: &Defs) -> Result { + let mut lhs_vars = HashSet::new(); + symbols(&rule.lhs, &mut lhs_vars); + let mut rhs_vars = HashSet::new(); + symbols(&rule.rhs, &mut rhs_vars); + if let Some(v) = rule + .params + .iter() + .find(|p| rhs_vars.contains(*p) && !lhs_vars.contains(*p)) + { + return Err(format!("rule would introduce unbound variable `{v}`")); + } + rewrite_nth(t, rule, at, &mut 0, defs).ok_or_else(|| "rule does not match".to_string()) +} + +/// Replace the leftmost-outermost redex of `name` (an application whose +/// scrutinized argument is a constructor); failing that, the leftmost-outermost +/// application at all. +pub fn unfold(t: &Expr, name: &str, defs: &Defs, used: &mut HashSet) -> Result { + let f = defs + .fns + .get(name) + .ok_or_else(|| format!("`{name}` is not defined in defs.oo"))?; + if !defs.total.contains(name) { + return Err(format!("`{name}` is not structurally recursive; cannot unfold")); + } + let arity = f.params.len(); + let is_app = |e: &Expr| matches!(&e.kind, ExprKind::List(v) if v.len() == arity + 1) && head_sym(e) == Some(name); + for pred in [true, false] { + let mut done = false; + let out = replace_first(t, &mut |e| { + let hit = if pred { is_redex(e, name, defs) } else { is_app(e) }; + if !hit { + return None; + } + let ExprKind::List(items) = &e.kind else { return None }; + Some(instantiate(f, &items[1..], defs, used)) + }, &mut done); + if done { + return Ok(out); + } + } + Err(format!("no application of `{name}`")) +} + +fn replace_first(t: &Expr, f: &mut dyn FnMut(&Expr) -> Option, done: &mut bool) -> Expr { + if *done { + return t.clone(); + } + if let Some(r) = f(t) { + *done = true; + return r; + } + map_children(t, &mut |c| replace_first(c, f, done)) +} + +// ─── Proof checking ──────────────────────────────────────────────────────── + +#[derive(Clone, Debug, PartialEq)] +pub enum Outcome { + Proven, + Admitted, + Stuck { case: String, term: String, reason: String }, +} + +/// A type as far as the kernel needs it: a head name plus argument types. +/// `?` stands for an argument the checker could not determine; a field whose +/// type is such an unknown parameter gets no type (so it cannot be split). +#[derive(Clone, Debug, PartialEq)] +pub struct Ty { + pub name: String, + pub args: Vec, +} + +impl Ty { + pub fn named(n: &str) -> Ty { + Ty { name: n.to_string(), args: vec![] } + } + + pub fn app(n: &str, args: Vec) -> Ty { + Ty { name: n.to_string(), args } + } + + pub fn unknown() -> Ty { + Ty::named("?") + } +} + +/// The type of each field of `ctor` (a constructor of `ty`), instantiating +/// the ADT's type parameters with `ty.args`. `None` where unknown. +pub fn field_tys(defs: &Defs, ty: &Ty, fields: &[Expr]) -> Vec> { + let params = defs.type_params.get(&ty.name).cloned().unwrap_or_default(); + fn conv(f: &Expr, params: &[String], ty: &Ty) -> Option { + match &f.kind { + ExprKind::Symbol(s) => match params.iter().position(|p| p == s) { + Some(i) => ty.args.get(i).filter(|t| t.name != "?").cloned(), + None => Some(Ty::named(s)), + }, + ExprKind::List(v) | ExprKind::Tuple(v) => { + let Some(ExprKind::Symbol(h)) = v.first().map(|e| &e.kind) else { + return None; + }; + let args = v[1..].iter().map(|a| conv(a, params, ty).unwrap_or_else(Ty::unknown)).collect(); + Some(Ty::app(h, args)) + } + _ => None, + } + } + fields.iter().map(|f| conv(f, ¶ms, ty)).collect() +} + +/// Is a declared field type exactly the ADT `name` itself (`name` or +/// `(name ...)`)? Only such fields get an induction hypothesis: a field like +/// `(List (Tree T))` mentions the ADT but is not a structural subterm of it. +fn is_self_field(f: &Expr, name: &str) -> bool { + match &f.kind { + ExprKind::Symbol(s) => s == name, + ExprKind::List(v) | ExprKind::Tuple(v) => matches!(v.first().map(|e| &e.kind), Some(ExprKind::Symbol(h)) if h == name), + _ => false, + } +} + +pub struct Goal<'a> { + pub law_name: &'a str, + pub params: &'a [String], + /// param name -> ADT type, where known + pub param_types: &'a HashMap, + pub lhs: &'a Expr, + pub rhs: &'a Expr, +} + +/// Look up a citable law by name: returns (rule, admitted?). +pub type Lemmas<'a> = dyn Fn(&str) -> Option<(Rule, bool)> + 'a; + +struct Ctx<'a> { + defs: &'a Defs, + lemmas: &'a Lemmas<'a>, + admitted: bool, +} + +#[derive(Clone)] +struct State { + l: Expr, + r: Expr, + /// Law params still universally quantified in this goal. + params: Vec, + /// var -> type (law params and constructor fields introduced by splits) + types: HashMap, + /// Induction hypotheses in scope, keyed by the recursive field they are + /// about. Cited as `ih-FIELD`; plain `ih` names the only one. + ihs: Vec<(String, Rule)>, + case: String, +} + +pub fn check_proof(goal: &Goal, steps: &[Expr], defs: &Defs, lemmas: &Lemmas) -> Outcome { + let mut ctx = Ctx { defs, lemmas, admitted: false }; + let st = State { + l: normalize(goal.lhs, defs), + r: normalize(goal.rhs, defs), + params: goal.params.to_vec(), + types: goal.param_types.clone(), + ihs: Vec::new(), + case: "root".into(), + }; + let _ = goal.law_name; + match run_steps(&mut ctx, st, steps) { + Ok(()) if ctx.admitted => Outcome::Admitted, + Ok(()) => Outcome::Proven, + Err(o) => o, + } +} + +fn stuck(st: &State, reason: impl Into) -> Outcome { + let mut reason = reason.into(); + if !st.ihs.is_empty() { + let names: Vec = st.ihs.iter().map(|(f, _)| format!("ih-{f}")).collect(); + reason = format!("{reason} [hypotheses: {}]", names.join(" ")); + } + Outcome::Stuck { + case: st.case.clone(), + term: format!("{}", st.l), + reason, + } +} + +/// Resolve `ih` / `ih-FIELD` to a hypothesis in scope. `None` if `name` is +/// not hypothesis syntax (so it is looked up as a law). +fn lookup_ih(st: &State, name: &str) -> Option> { + if name == "ih" { + return Some(match st.ihs.as_slice() { + [] => Err(stuck(st, "no induction hypothesis in scope")), + [(_, r)] => Ok(r.clone()), + _ => Err(stuck(st, "`ih` is ambiguous here; name one with ih-FIELD")), + }); + } + let field = name.strip_prefix("ih-")?; + Some( + st.ihs + .iter() + .find(|(f, _)| f == field) + .map(|(_, r)| r.clone()) + .ok_or_else(|| stuck(st, format!("no hypothesis `{name}` in scope"))), + ) +} + +fn closes(st: &State, defs: &Defs) -> bool { + let mut used = HashSet::new(); + symbols(&st.l, &mut used); + symbols(&st.r, &mut used); + let mut fuel = 10_000; + let l = eval_normalize(&st.l, defs, &mut used, &mut fuel); + let r = eval_normalize(&st.r, defs, &mut used, &mut fuel); + term_eq(&l, &r) +} + +fn used_symbols(st: &State) -> HashSet { + let mut used = HashSet::new(); + symbols(&st.l, &mut used); + symbols(&st.r, &mut used); + used.extend(st.params.iter().cloned()); + used.extend(st.types.keys().cloned()); + for (f, ih) in &st.ihs { + used.insert(f.clone()); + symbols(&ih.lhs, &mut used); + symbols(&ih.rhs, &mut used); + } + used +} + +fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome> { + for (i, step) in steps.iter().enumerate() { + let ExprKind::List(items) = &step.kind else { + return Err(stuck(&st, format!("malformed step `{step}`"))); + }; + let op = head_sym(step).unwrap_or(""); + match op { + "unfold" => { + let Some(ExprKind::Symbol(f)) = items.get(1).map(|e| &e.kind) else { + return Err(stuck(&st, "unfold needs a function name")); + }; + let mut used = used_symbols(&st); + st.l = unfold(&st.l, f, ctx.defs, &mut used) + .map(|l| normalize(&l, ctx.defs)) + .map_err(|e| stuck(&st, format!("unfold {f}: {e}")))?; + } + "rewrite" => { + let Some(ExprKind::Symbol(name)) = items.get(1).map(|e| &e.kind) else { + return Err(stuck(&st, "rewrite needs a rule name")); + }; + let (mut rev, mut at) = (false, 0usize); + let mut j = 2; + while j < items.len() { + match &items[j].kind { + ExprKind::Keyword(k) if k == "rev" => rev = true, + ExprKind::Keyword(k) if k == "at" => { + j += 1; + match items.get(j).map(|e| &e.kind) { + Some(ExprKind::Int(n)) if *n >= 0 => at = *n as usize, + _ => return Err(stuck(&st, "`:at` needs a non-negative integer")), + } + } + _ => return Err(stuck(&st, format!("unknown rewrite option `{}`", items[j]))), + } + j += 1; + } + let rule = if let Some(ih) = lookup_ih(&st, name) { + ih? + } else { + let (rule, adm) = (ctx.lemmas)(name).ok_or_else(|| { + stuck(&st, format!("`{name}` is not a law proven earlier")) + })?; + ctx.admitted |= adm; + rule + }; + // Rules are matched in the same canonical form as the goal. + let (lhs, rhs) = (normalize(&rule.lhs, ctx.defs), normalize(&rule.rhs, ctx.defs)); + let rule = if rev { + Rule { params: rule.params, lhs: rhs, rhs: lhs } + } else { + Rule { params: rule.params, lhs, rhs } + }; + st.l = rewrite(&st.l, &rule, at, ctx.defs) + .map(|l| normalize(&l, ctx.defs)) + .map_err(|e| stuck(&st, format!("rewrite {name}: {e}")))?; + } + "refl" => { + if !closes(&st, ctx.defs) { + return Err(stuck(&st, "refl: sides differ")); + } + return Ok(()); + } + "admit" => { + ctx.admitted = true; + return Ok(()); + } + "induction" | "cases" => { + if i + 1 != steps.len() { + return Err(stuck(&st, format!("steps after `{op}` are not allowed; put them in its cases"))); + } + return split(ctx, st, items, op == "induction"); + } + _ => return Err(stuck(&st, format!("unknown step `{step}`"))), + } + } + if closes(&st, ctx.defs) { + Ok(()) + } else { + Err(stuck(&st, "no step applies; sides differ")) + } +} + +fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<(), Outcome> { + let Some(ExprKind::Symbol(var)) = items.get(1).map(|e| &e.kind) else { + return Err(stuck(&st, "induction/cases needs a variable")); + }; + let var = var.clone(); + if induction && !st.params.contains(&var) { + return Err(stuck(&st, format!("`{var}` is not a law parameter of this goal"))); + } + let Some(ty) = st.types.get(&var).cloned() else { + return Err(stuck(&st, format!("type of `{var}` is not a known ADT"))); + }; + let Some(ctors) = ctx.defs.types.get(&ty.name) else { + return Err(stuck(&st, format!("`{}` is not an ADT declared in defs.oo", ty.name))); + }; + let ty_name = ty.name.clone(); + if induction { + let mut fs = HashSet::new(); + symbols(&st.l, &mut fs); + symbols(&st.r, &mut fs); + if let Some(bad) = fs + .iter() + .find(|s| ctx.defs.fns.contains_key(s.as_str()) && !ctx.defs.total.contains(s.as_str())) + { + return Err(stuck(&st, format!("induction needs total functions; `{bad}` is not structurally recursive"))); + } + } + let cases: Vec<&Expr> = items[2..].iter().collect(); + for ctor in ctors { + let case = cases.iter().find(|c| { + head_sym(c).is_some_and(|h| h == ctor.name || h.eq_ignore_ascii_case(&ctor.name)) + }); + let mut used = used_symbols(&st); + let mut fields = Vec::new(); + let mut types = st.types.clone(); + types.remove(&var); + let ftys = field_tys(ctx.defs, &ty, &ctor.fields); + // Fields that are structural subterms of the same ADT. + let mut rec_fields = Vec::new(); + for (k, rec) in ctor.recursive.iter().enumerate() { + let is_self = ctor.fields.get(k).is_some_and(|f| is_self_field(f, &ty_name)); + let base = if *rec { "rest" } else { "x" }; + let n = fresh_name(base, &mut used); + if let Some(Some(t)) = ftys.get(k) { + types.insert(n.clone(), t.clone()); + } + if is_self { + rec_fields.push(n.clone()); + } + fields.push(sym(&n)); + } + let value = if fields.is_empty() { + sym(&ctor.name) + } else { + let mut v = vec![sym(&ctor.name)]; + v.extend(fields); + list(v) + }; + let m = HashMap::from([(var.clone(), value)]); + let params: Vec = st.params.iter().filter(|p| **p != var).cloned().collect(); + // Induction: one hypothesis per recursive field, each quantified over + // the remaining law params. Cases: hypotheses already in scope carry + // over, specialized at the split value unless they quantify `var`. + let ihs: Vec<(String, Rule)> = if induction { + rec_fields + .iter() + .map(|rf| { + let im = HashMap::from([(var.clone(), sym(rf))]); + ( + rf.clone(), + Rule { + params: params.clone(), + lhs: subst(&st.l, &im, ctx.defs), + rhs: subst(&st.r, &im, ctx.defs), + }, + ) + }) + .collect() + } else { + st.ihs + .iter() + .map(|(f, ih)| { + let ih = if ih.params.contains(&var) { + ih.clone() + } else { + Rule { + lhs: subst(&ih.lhs, &m, ctx.defs), + rhs: subst(&ih.rhs, &m, ctx.defs), + params: ih.params.clone(), + } + }; + (f.clone(), ih) + }) + .collect() + }; + let child = State { + l: normalize(&subst(&st.l, &m, ctx.defs), ctx.defs), + r: normalize(&subst(&st.r, &m, ctx.defs), ctx.defs), + params, + types, + ihs, + case: if st.case == "root" { ctor.name.clone() } else { format!("{}/{}", st.case, ctor.name) }, + }; + let Some(case) = case else { + return Err(stuck(&child, format!("missing case {}", ctor.name))); + }; + let ExprKind::List(cs) = &case.kind else { unreachable!() }; + run_steps(ctx, child, &cs[1..])?; + } + if let Some(extra) = cases.iter().find(|c| { + !ctors + .iter() + .any(|k| head_sym(c).is_some_and(|h| h.eq_ignore_ascii_case(&k.name))) + }) { + return Err(stuck(&st, format!("case `{extra}` is not a constructor of {ty_name}"))); + } + Ok(()) +} diff --git a/crates/loon-lang/src/verify/mod.rs b/crates/loon-lang/src/verify/mod.rs new file mode 100644 index 0000000..b34ad96 --- /dev/null +++ b/crates/loon-lang/src/verify/mod.rs @@ -0,0 +1,923 @@ +//! `loon prove`: laws, proof objects, a rewrite kernel, bounded falsification. +//! +//! See docs/plans/2026-10-28-verify-autoresearch.md. Layout of a verify dir: +//! +//! ```text +//! defs.oo frozen reference prelude (ADTs + fns the kernel can unfold) +//! builtins.oo frozen bridge laws, bounded-only (status `bounded`) +//! canary.oo frozen false laws; proving one makes the run unsound +//! laws/*.oo agent conjectures +//! proofs/*.oo agent proof objects +//! ``` + +pub mod bounded; +pub mod infer; +pub mod kernel; + +use crate::ast::{Expr, ExprKind}; +use kernel::{head_sym, Outcome, Rule}; +use serde_json::{json, Value as J}; +use std::collections::{HashMap, HashSet}; +use std::path::Path; + +// ─── Definitions ─────────────────────────────────────────────────────────── + +#[derive(Clone, Debug)] +pub struct FnDef { + pub params: Vec, + pub body: Expr, + /// Index of the param the body's top-level `match` scrutinizes. + pub scrutinee: Option, +} + +#[derive(Clone, Debug)] +pub struct CtorInfo { + pub name: String, + /// One entry per field: does the field mention the ADT itself? + pub recursive: Vec, + /// Declared field types, verbatim (`T`, `(List T)`, `Int`, ...). + pub fields: Vec, +} + +#[derive(Clone, Debug, Default)] +pub struct Defs { + pub fns: HashMap, + pub types: HashMap>, + /// Reference fn names in definition order. + pub fn_order: Vec, + /// Type parameters of each ADT, in declaration order. + pub type_params: HashMap>, + pub ctors: HashSet, + /// Structurally recursive (total) fns. + pub total: HashSet, + /// User operators normalized modulo associativity/commutativity (and a + /// unit, if declared). Empty in the frozen defs; `run_dir` fills a clone + /// per proof with the `ac` declarations active for that proof. + pub ac: Vec, +} + +/// An active AC operator: a two-argument fn of defs.oo. +#[derive(Clone, Debug)] +pub struct AcOp { + pub op: String, + pub unit: Option, +} + +impl Defs { + pub fn is_ctor(&self, s: &str) -> bool { + self.ctors.contains(s) + } + + pub fn type_of_ctor(&self, c: &str) -> Option { + self.types + .iter() + .find(|(_, cs)| cs.iter().any(|k| k.name == c)) + .map(|(t, _)| t.clone()) + } + + /// Build from parsed top-level forms (`type` and `fn`); other forms are ignored. + pub fn from_exprs(exprs: &[Expr]) -> Result { + let mut d = Defs::default(); + for e in exprs { + let ExprKind::List(items) = &e.kind else { continue }; + match head_sym(e) { + Some("type") => d.add_type(items)?, + Some("fn") => d.add_fn(items)?, + _ => {} + } + } + // Scrutinee needs ctor knowledge; compute after all types are in. + d.total = kernel::total_fns(&d); + Ok(d) + } + + fn add_type(&mut self, items: &[Expr]) -> Result<(), String> { + let Some(ExprKind::Symbol(name)) = items.get(1).map(|e| &e.kind) else { + return Err("type: expected a name".into()); + }; + let mut fields_syms = HashSet::new(); + for it in &items[2..] { + if let ExprKind::List(v) = &it.kind { + for f in &v[1..] { + kernel::symbols(f, &mut fields_syms); + } + } + } + let mut params: Vec = Vec::new(); + for it in &items[2..] { + if let ExprKind::Symbol(s) = &it.kind { + if fields_syms.contains(s) && !params.contains(s) { + params.push(s.clone()); + } + } + } + let mut ctors = Vec::new(); + for it in &items[2..] { + match &it.kind { + // A bare symbol used in some field is a type param, else a nullary ctor. + ExprKind::Symbol(s) if fields_syms.contains(s) => {} + ExprKind::Symbol(s) => ctors.push(CtorInfo { name: s.clone(), recursive: vec![], fields: vec![] }), + ExprKind::List(v) => { + let Some(ExprKind::Symbol(c)) = v.first().map(|e| &e.kind) else { + return Err(format!("type {name}: malformed constructor `{it}`")); + }; + let recursive = v[1..] + .iter() + .map(|f| { + let mut s = HashSet::new(); + kernel::symbols(f, &mut s); + s.contains(name) + }) + .collect(); + ctors.push(CtorInfo { name: c.clone(), recursive, fields: v[1..].to_vec() }); + } + _ => return Err(format!("type {name}: unexpected `{it}`")), + } + } + for c in &ctors { + self.ctors.insert(c.name.clone()); + } + self.types.insert(name.clone(), ctors); + self.type_params.insert(name.clone(), params); + Ok(()) + } + + fn add_fn(&mut self, items: &[Expr]) -> Result<(), String> { + let (Some(ExprKind::Symbol(name)), Some(ExprKind::List(ps))) = + (items.get(1).map(|e| &e.kind), items.get(2).map(|e| &e.kind)) + else { + return Ok(()); // anonymous or multi-clause: not unfoldable + }; + if items.len() != 4 { + return Err(format!("fn {name}: reference definitions must have a single body expression")); + } + let params: Vec = ps + .iter() + .map(|p| match &p.kind { + ExprKind::Symbol(s) => Ok(s.clone()), + _ => Err(format!("fn {name}: params must be plain symbols")), + }) + .collect::>()?; + let body = items[3].clone(); + let scrutinee = match &body.kind { + ExprKind::List(v) if head_sym(&body) == Some("match") && v.len() >= 2 => match &v[1].kind { + ExprKind::Symbol(s) => params.iter().position(|p| p == s), + _ => None, + }, + _ => None, + }; + self.fns.insert(name.clone(), FnDef { params, body, scrutinee }); + self.fn_order.push(name.clone()); + Ok(()) + } +} + +// ─── Laws and proofs ─────────────────────────────────────────────────────── + +#[derive(Clone, Copy, Debug, PartialEq, Eq)] +pub enum Origin { + Laws, + Builtins, + Canary, +} + +#[derive(Clone, Debug)] +pub struct Law { + pub name: String, + pub params: Vec, + pub lhs: Expr, + pub rhs: Expr, + pub origin: Origin, + pub file: String, +} + +/// Parse `[law NAME [PARAMS...] [= LHS RHS]]`. +pub fn parse_law(e: &Expr, origin: Origin, file: &str) -> Option> { + let ExprKind::List(items) = &e.kind else { return None }; + if head_sym(e) != Some("law") { + return None; + } + Some((|| { + let Some(ExprKind::Symbol(name)) = items.get(1).map(|e| &e.kind) else { + return Err(format!("{file}: law needs a name")); + }; + let Some(ExprKind::List(ps)) = items.get(2).map(|e| &e.kind) else { + return Err(format!("{file}: law {name}: expected a param list")); + }; + let params = ps + .iter() + .map(|p| match &p.kind { + ExprKind::Symbol(s) => Ok(s.clone()), + _ => Err(format!("{file}: law {name}: params must be symbols")), + }) + .collect::, _>>()?; + let eq = items.get(3).filter(|_| items.len() == 4); + let Some(ExprKind::List(eqv)) = eq.map(|e| &e.kind) else { + return Err(format!("{file}: law {name}: expected [= LHS RHS]")); + }; + if eqv.len() != 3 || head_sym(eq.unwrap()) != Some("=") { + return Err(format!("{file}: law {name}: expected [= LHS RHS]")); + } + Ok(Law { + name: name.clone(), + params, + lhs: eqv[1].clone(), + rhs: eqv[2].clone(), + origin, + file: file.to_string(), + }) + })()) +} + +/// Rule names a proof cites (excluding `ih`). +pub fn cited(steps: &[Expr], out: &mut Vec) { + for s in steps { + let ExprKind::List(items) = &s.kind else { continue }; + match head_sym(s) { + Some("rewrite") => { + if let Some(ExprKind::Symbol(n)) = items.get(1).map(|e| &e.kind) { + if n != "ih" && !out.contains(n) { + out.push(n.clone()); + } + } + } + Some("induction") | Some("cases") => { + for c in items.iter().skip(2) { + if let ExprKind::List(cs) = &c.kind { + cited(&cs[1..], out); + } + } + } + _ => {} + } + } +} + +// ─── AC declarations ─────────────────────────────────────────────────────── + +/// `[ac OP ASSOC-LAW COMM-LAW]` or `[ac OP ASSOC-LAW COMM-LAW :unit UNIT UNIT-LAW]`, +/// with the cited laws' statements checked for shape. +#[derive(Clone, Debug)] +pub struct AcDecl { + pub op: String, + pub assoc: String, + pub comm: String, + pub unit: Option, + pub unit_law: Option, +} + +impl AcDecl { + pub fn laws(&self) -> Vec { + let mut v = vec![self.assoc.clone(), self.comm.clone()]; + v.extend(self.unit_law.clone()); + v + } +} + +const META: [&str; 3] = ["\0a", "\0b", "\0c"]; + +/// Does `t` match `pat`, where the `META` symbols of `pat` stand for distinct +/// law params (alpha-equivalence) and everything else must be equal? +fn alpha_match(pat: &Expr, t: &Expr, params: &[String], b: &mut HashMap) -> bool { + if let ExprKind::Symbol(m) = &pat.kind { + if META.contains(&m.as_str()) { + let ExprKind::Symbol(s) = &t.kind else { return false }; + if !params.contains(s) { + return false; + } + return match b.get(m) { + Some(prev) => prev == s, + None if b.values().any(|v| v == s) => false, + None => { + b.insert(m.clone(), s.clone()); + true + } + }; + } + } + match (&pat.kind, &t.kind) { + (ExprKind::List(ps), ExprKind::List(ts)) => { + ps.len() == ts.len() && ps.iter().zip(ts).all(|(p, x)| alpha_match(p, x, params, b)) + } + _ => kernel::term_eq(pat, t), + } +} + +/// Is `law`'s statement `[= L R]` an instance of one of `shapes` (either +/// orientation)? +fn law_has_shape(law: &Law, shapes: &[(Expr, Expr)]) -> bool { + shapes.iter().any(|(l, r)| { + [(&law.lhs, &law.rhs), (&law.rhs, &law.lhs)].iter().any(|(x, y)| { + let mut b = HashMap::new(); + alpha_match(l, x, &law.params, &mut b) && alpha_match(r, y, &law.params, &mut b) + }) + }) +} + +pub fn parse_ac(e: &Expr, laws: &[Law], defs: &Defs) -> Result { + use kernel::{list, sym}; + let ExprKind::List(items) = &e.kind else { unreachable!() }; + let names: Vec> = items + .iter() + .map(|x| match &x.kind { + ExprKind::Symbol(s) => Some(s.as_str()), + _ => None, + }) + .collect(); + let bad = || format!("malformed `{e}`; expected [ac OP ASSOC-LAW COMM-LAW] or [ac OP ASSOC-LAW COMM-LAW :unit UNIT UNIT-LAW]"); + let with_unit = items.len() == 7 && matches!(&items[4].kind, ExprKind::Keyword(k) if k == "unit"); + if !(items.len() == 4 || with_unit) { + return Err(bad()); + } + let (Some(op), Some(assoc), Some(comm)) = (names[1], names[2], names[3]) else { + return Err(bad()); + }; + if defs.fns.get(op).map(|f| f.params.len()) != Some(2) { + return Err(format!("ac {op}: `{op}` is not a two-argument fn of defs.oo")); + } + let law = |n: &str| { + laws.iter() + .find(|l| l.name == n && l.origin == Origin::Laws) + .ok_or_else(|| format!("ac {op}: `{n}` is not a law")) + }; + let app = |a: Expr, b: Expr| list(vec![sym(op), a, b]); + let [a, b, c] = META.map(sym); + let assoc_shape = (app(app(a.clone(), b.clone()), c.clone()), app(a.clone(), app(b.clone(), c))); + if !law_has_shape(law(assoc)?, &[assoc_shape]) { + return Err(format!("ac {op}: `{assoc}` is not [= [{op} [{op} a b] c] [{op} a [{op} b c]]]")); + } + let comm_shape = (app(a.clone(), b.clone()), app(b, a.clone())); + if !law_has_shape(law(comm)?, &[comm_shape]) { + return Err(format!("ac {op}: `{comm}` is not [= [{op} a b] [{op} b a]]")); + } + let (mut unit, mut unit_law) = (None, None); + if with_unit { + let u = items[5].clone(); + let ok = match &u.kind { + ExprKind::Int(_) => true, + ExprKind::Symbol(s) => defs.types.values().flatten().any(|k| &k.name == s && k.fields.is_empty()), + _ => false, + }; + if !ok { + return Err(format!("ac {op}: unit `{u}` is not a nullary constructor or literal")); + } + let Some(ul) = names[6] else { return Err(bad()) }; + let shapes = [(app(a.clone(), u.clone()), a.clone()), (app(u.clone(), a.clone()), a.clone())]; + if !law_has_shape(law(ul)?, &shapes) { + return Err(format!("ac {op}: `{ul}` is not [= [{op} n {u}] n] or [= [{op} {u} n] n]")); + } + unit = Some(u); + unit_law = Some(ul.to_string()); + } + Ok(AcDecl { op: op.into(), assoc: assoc.into(), comm: comm.into(), unit, unit_law }) +} + +/// `op` plus every fn of defs.oo whose body transitively mentions it: a goal +/// mentioning none of these can never contain an `op` application. +fn reaching(op: &str, defs: &Defs) -> HashSet { + let mut r: HashSet = HashSet::from([op.to_string()]); + loop { + let more: Vec = defs + .fns + .iter() + .filter(|(n, f)| { + !r.contains(*n) && { + let mut s = HashSet::new(); + kernel::symbols(&f.body, &mut s); + s.iter().any(|x| r.contains(x)) + } + }) + .map(|(n, _)| n.clone()) + .collect(); + if more.is_empty() { + return r; + } + r.extend(more); + } +} + +// ─── Run ─────────────────────────────────────────────────────────────────── + +pub struct Options { + pub bound: usize, + pub seed: u64, +} + +impl Default for Options { + fn default() -> Self { + Options { bound: 6, seed: 0x5EED } + } +} + +#[derive(Clone, Debug)] +pub struct LawReport { + pub name: String, + pub origin: Origin, + pub status: &'static str, + pub counterexample: Option<(Vec<(String, Expr)>, String, String)>, + pub stuck: Option<(String, String, String)>, + pub note: Option, + pub checked: usize, +} + +pub struct Report { + pub run: String, + pub defs_hash: String, + pub sound: bool, + pub laws: Vec, + pub errors: Vec, + pub defs: Defs, +} + +fn read_forms(path: &Path, required: bool) -> Result, String> { + let src = match std::fs::read_to_string(path) { + Ok(s) => s, + Err(_) if !required => return Ok(vec![]), + Err(e) => return Err(format!("{}: {e}", path.display())), + }; + crate::parser::parse(&src).map_err(|e| format!("{}: parse error: {}", path.display(), e.message)) +} + +fn oo_files(dir: &Path) -> Vec { + let mut v: Vec<_> = std::fs::read_dir(dir) + .map(|rd| { + rd.filter_map(|e| e.ok().map(|e| e.path())) + .filter(|p| p.extension().is_some_and(|x| x == "oo" || x == "loon")) + .collect() + }) + .unwrap_or_default(); + v.sort(); + v +} + +fn hash_hex(data: &[u8]) -> String { + #[cfg(feature = "pkg-fetch")] + { + format!("blake3:{}", blake3::hash(data).to_hex()) + } + #[cfg(not(feature = "pkg-fetch"))] + { + // FNV-1a 64; only used when blake3 is not compiled in. + let mut h: u64 = 0xcbf29ce484222325; + for b in data { + h ^= *b as u64; + h = h.wrapping_mul(0x100000001b3); + } + format!("fnv1a64:{h:016x}") + } +} + +fn now_rfc3339() -> String { + let secs = std::time::SystemTime::now() + .duration_since(std::time::UNIX_EPOCH) + .map(|d| d.as_secs() as i64) + .unwrap_or(0); + let (days, rem) = (secs.div_euclid(86400), secs.rem_euclid(86400)); + // Howard Hinnant's civil_from_days. + let z = days + 719468; + let era = z.div_euclid(146097); + let doe = z - era * 146097; + let yoe = (doe - doe / 1460 + doe / 36524 - doe / 146096) / 365; + let doy = doe - (365 * yoe + yoe / 4 - yoe / 100); + let mp = (5 * doy + 2) / 153; + let d = doy - (153 * mp + 2) / 5 + 1; + let m = if mp < 10 { mp + 3 } else { mp - 9 }; + let y = yoe + era * 400 + if m <= 2 { 1 } else { 0 }; + format!( + "{y:04}-{m:02}-{d:02}T{:02}:{:02}:{:02}Z", + rem / 3600, + (rem % 3600) / 60, + rem % 60 + ) +} + +/// The kernel's view of a checker type. +fn checker_ty(t: &crate::types::Type) -> kernel::Ty { + use crate::types::Type; + match t { + Type::Int => kernel::Ty::named("Int"), + Type::Bool => kernel::Ty::named("Bool"), + Type::Con(n, args) => kernel::Ty::app(n, args.iter().map(checker_ty).collect()), + _ => kernel::Ty::unknown(), + } +} + +/// Run the whole pipeline over a verify directory. +pub fn run_dir(dir: &Path, opts: &Options) -> Result { + let read = |name: &str| std::fs::read(dir.join(name)).unwrap_or_default(); + let mut hashed = Vec::new(); + for f in ["defs.oo", "builtins.oo", "canary.oo"] { + hashed.extend(read(f)); + hashed.push(0); + } + let defs_hash = hash_hex(&hashed); + + let defs_src = std::fs::read_to_string(dir.join("defs.oo")) + .map_err(|e| format!("{}: {e}", dir.join("defs.oo").display()))?; + let defs_forms = read_forms(&dir.join("defs.oo"), true)?; + let defs = Defs::from_exprs(&defs_forms)?; + + let mut errors = Vec::new(); + let mut laws: Vec = Vec::new(); + let mut proofs: HashMap> = HashMap::new(); + let mut extra_fns: Vec = Vec::new(); + let mut ac_forms: Vec<(Expr, String)> = Vec::new(); + + let mut sources: Vec<(std::path::PathBuf, Origin, bool)> = vec![ + (dir.join("builtins.oo"), Origin::Builtins, false), + (dir.join("canary.oo"), Origin::Canary, false), + ]; + for p in oo_files(&dir.join("laws")) { + sources.push((p, Origin::Laws, true)); + } + for (path, origin, required) in &sources { + let file = path.display().to_string(); + for e in read_forms(path, *required)? { + if let Some(l) = parse_law(&e, *origin, &file) { + match l { + Ok(l) if laws.iter().any(|x| x.name == l.name) => { + errors.push(format!("{file}: duplicate law `{}`", l.name)) + } + Ok(l) => laws.push(l), + Err(m) => errors.push(m), + } + } else if *origin == Origin::Laws && head_sym(&e) == Some("ac") { + ac_forms.push((e.clone(), file.clone())); + } else if *origin == Origin::Builtins && head_sym(&e) == Some("fn") { + extra_fns.push(e); + } else if head_sym(&e) == Some("proof") { + errors.push(format!("{file}: proofs belong in proofs/")); + } + } + } + for path in oo_files(&dir.join("proofs")) { + let file = path.display().to_string(); + for e in read_forms(&path, true)? { + let ExprKind::List(items) = &e.kind else { continue }; + if head_sym(&e) != Some("proof") { + continue; + } + let Some(ExprKind::Symbol(name)) = items.get(1).map(|x| &x.kind) else { + errors.push(format!("{file}: proof needs a law name")); + continue; + }; + match laws.iter().find(|l| &l.name == name) { + None => errors.push(format!("{file}: proof for unknown law `{name}`")), + Some(l) if l.origin == Origin::Builtins => { + errors.push(format!("{file}: `{name}` is a bridge law; bridge laws are bounded-only")) + } + Some(_) if proofs.contains_key(name) => errors.push(format!("{file}: duplicate proof `{name}`")), + Some(_) => { + proofs.insert(name.clone(), items[2..].to_vec()); + } + } + } + } + + let ac_decls: Vec = ac_forms + .iter() + .filter_map(|(e, file)| match parse_ac(e, &laws, &defs) { + Ok(d) => Some(d), + Err(m) => { + errors.push(format!("{file}: {m}")); + None + } + }) + .collect(); + + // Evaluation prelude: type decls verbatim, fns renamed. + let mut prelude = String::new(); + for e in &defs_forms { + match head_sym(e) { + Some("type") => { + prelude.push_str(&defs_src[e.span.start..e.span.end]); + prelude.push('\n'); + } + Some("fn") => { + prelude.push_str(&format!("{}\n", bounded::mangle(e, &defs))); + } + _ => {} + } + } + for e in &extra_fns { + prelude.push_str(&format!("{}\n", bounded::mangle(e, &defs))); + } + + // Bounded evaluation and param types. + let mut reports: Vec = Vec::new(); + let mut param_types: HashMap> = HashMap::new(); + for law in &laws { + let kinds = bounded::param_kinds(&prelude, &law.params, &law.lhs, &law.rhs, &defs); + let inferred = infer::law_param_types(&defs, &defs.fn_order, &law.params, &law.lhs, &law.rhs); + let types = law + .params + .iter() + .zip(&kinds) + .filter_map(|(p, k)| match k { + bounded::Kind::List(t, _, _) => Some((p.clone(), kernel::Ty::app(t, vec![kernel::Ty::named("Int")]))), + bounded::Kind::Adt(t, _) => { + let n = defs.type_params.get(t).map_or(0, |v| v.len()); + Some((p.clone(), kernel::Ty::app(t, vec![kernel::Ty::named("Int"); n]))) + } + bounded::Kind::Typed(t, _) => Some((p.clone(), checker_ty(t))), + _ => None, + }) + .collect(); + let types = match &inferred { + Some(ts) => law + .params + .iter() + .zip(ts) + .map(|(p, t)| (p.clone(), infer::to_ty(t))) + .filter(|(_, t)| defs.types.contains_key(&t.name)) + .collect(), + None => types, + }; + param_types.insert(law.name.clone(), types); + let b = bounded::check_law(&prelude, &law.params, &kinds, &law.lhs, &law.rhs, &defs, opts.bound, opts.seed); + let status = match (&b.counterexample, law.origin) { + (Some(_), _) => "falsified", + (None, Origin::Builtins) if b.error.is_none() => "bounded", + _ => "unknown", + }; + reports.push(LawReport { + name: law.name.clone(), + origin: law.origin, + status, + counterexample: b.counterexample, + stuck: None, + note: b.error.map(|e| format!("bounded: {e}")), + checked: b.checked, + }); + } + + // Kernel, in dependency order. + let mut deps: HashMap> = proofs + .iter() + .map(|(n, steps)| { + let mut c = Vec::new(); + cited(steps, &mut c); + (n.clone(), c) + }) + .collect(); + // An `ac` declaration counts as citing its laws, for every proof it may + // affect except the proofs its own laws (transitively) rest on: those + // must not use the normalization they justify. + let mut ac_for: HashMap> = HashMap::new(); + for (i, d) in ac_decls.iter().enumerate() { + let mut excl: HashSet = HashSet::new(); + let mut todo = d.laws(); + while let Some(n) = todo.pop() { + if excl.insert(n.clone()) { + todo.extend(deps.get(&n).cloned().unwrap_or_default()); + } + } + let reach = reaching(&d.op, &defs); + let names: Vec = proofs.keys().filter(|n| !excl.contains(*n)).cloned().collect(); + for n in names { + let mut syms = HashSet::new(); + for l in laws.iter().filter(|l| l.name == n || deps[&n].contains(&l.name)) { + kernel::symbols(&l.lhs, &mut syms); + kernel::symbols(&l.rhs, &mut syms); + } + if syms.iter().any(|s| reach.contains(s)) { + ac_for.entry(n.clone()).or_default().push(i); + let dn = deps.get_mut(&n).unwrap(); + for l in d.laws() { + if !dn.contains(&l) { + dn.push(l); + } + } + } + } + } + let mut order = Vec::new(); + let mut state: HashMap = HashMap::new(); + let mut cyclic: HashSet = HashSet::new(); + fn dfs( + n: &str, + deps: &HashMap>, + state: &mut HashMap, + stack: &mut Vec, + cyclic: &mut HashSet, + order: &mut Vec, + ) { + state.insert(n.to_string(), 1); + stack.push(n.to_string()); + for d in deps.get(n).into_iter().flatten() { + if !deps.contains_key(d) { + continue; + } + match state.get(d.as_str()) { + Some(1) => { + let at = stack.iter().position(|s| s == d).unwrap_or(0); + cyclic.extend(stack[at..].iter().cloned()); + } + Some(_) => {} + None => dfs(d, deps, state, stack, cyclic, order), + } + } + stack.pop(); + state.insert(n.to_string(), 2); + order.push(n.to_string()); + } + let mut names: Vec<&String> = proofs.keys().collect(); + names.sort_by_key(|n| laws.iter().position(|l| &l.name == *n)); + for n in names { + if !state.contains_key(n.as_str()) { + dfs(n, &deps, &mut state, &mut Vec::new(), &mut cyclic, &mut order); + } + } + + let mut outcome: HashMap = HashMap::new(); + for name in &order { + let law = laws.iter().find(|l| &l.name == name).unwrap(); + let rep = reports.iter().find(|r| &r.name == name).unwrap(); + if rep.status == "falsified" && law.origin != Origin::Canary { + continue; // falsified laws are not sent to the kernel + } + if cyclic.contains(name) { + outcome.insert( + name.clone(), + Outcome::Stuck { + case: "root".into(), + term: format!("{}", law.lhs), + reason: "dependency cycle between proofs".into(), + }, + ); + continue; + } + let lemmas = |cite: &str| -> Option<(Rule, bool)> { + let adm = match outcome.get(cite)? { + Outcome::Proven => false, + Outcome::Admitted => true, + Outcome::Stuck { .. } => return None, + }; + let l = laws.iter().find(|l| l.name == cite)?; + Some((Rule { params: l.params.clone(), lhs: l.lhs.clone(), rhs: l.rhs.clone() }, adm)) + }; + let goal = kernel::Goal { + law_name: name, + params: &law.params, + param_types: ¶m_types[name], + lhs: &law.lhs, + rhs: &law.rhs, + }; + // Activate each relevant `ac` decl whose laws are proven (or admitted, + // which taints this proof). + let mut pdefs = defs.clone(); + let mut ac_tainted = false; + for &i in ac_for.get(name).into_iter().flatten() { + let d = &ac_decls[i]; + let st: Vec> = d.laws().iter().map(|l| outcome.get(l)).collect(); + if st.iter().all(|o| matches!(o, Some(Outcome::Proven | Outcome::Admitted))) { + ac_tainted |= st.iter().any(|o| matches!(o, Some(Outcome::Admitted))); + pdefs.ac.push(AcOp { op: d.op.clone(), unit: d.unit.clone() }); + } + } + let o = match kernel::check_proof(&goal, &proofs[name], &pdefs, &lemmas) { + Outcome::Proven if ac_tainted => Outcome::Admitted, + o => o, + }; + outcome.insert(name.clone(), o); + } + + let mut sound = true; + for rep in reports.iter_mut() { + let law = laws.iter().find(|l| l.name == rep.name).unwrap(); + match (outcome.get(&rep.name), law.origin) { + (Some(Outcome::Proven | Outcome::Admitted), Origin::Canary) => { + sound = false; + rep.status = "unsound"; + rep.note = Some("canary law was accepted by the kernel".into()); + } + (Some(Outcome::Proven), _) => rep.status = "proven", + (Some(Outcome::Admitted), _) => rep.status = "admitted", + (Some(Outcome::Stuck { case, term, reason }), _) => { + if rep.status != "falsified" { + rep.status = "unknown"; + } + rep.stuck = Some((case.clone(), term.clone(), reason.clone())); + } + (None, Origin::Laws) if rep.status == "unknown" && !proofs.contains_key(&rep.name) => { + rep.note = Some(rep.note.take().map_or("no proof".into(), |n| format!("no proof; {n}"))); + } + _ => {} + } + } + + Ok(Report { run: now_rfc3339(), defs_hash, sound, laws: reports, errors, defs }) +} + +// ─── Reporting ───────────────────────────────────────────────────────────── + +impl Report { + fn count(&self, status: &str) -> usize { + self.laws + .iter() + .filter(|l| l.origin == Origin::Laws && l.status == status) + .count() + } + + pub fn score(&self) -> i64 { + if !self.sound { + return 0; + } + self.count("proven") as i64 - 2 * self.count("admitted") as i64 + } + + pub fn to_json(&self) -> J { + let laws: Vec = self + .laws + .iter() + .map(|l| { + let mut o = json!({ "name": l.name, "status": l.status }); + let m = o.as_object_mut().unwrap(); + match l.origin { + Origin::Builtins => { + m.insert("bridge".into(), J::Bool(true)); + } + Origin::Canary => { + m.insert("canary".into(), J::Bool(true)); + } + Origin::Laws => {} + } + if let Some((asg, lv, rv)) = &l.counterexample { + let ce: serde_json::Map = asg + .iter() + .map(|(k, v)| (k.clone(), bounded::to_json(v, &self.defs))) + .collect(); + m.insert("counterexample".into(), J::Object(ce)); + m.insert("lhs".into(), bounded::value_json(lv, &self.defs)); + m.insert("rhs".into(), bounded::value_json(rv, &self.defs)); + } + if let Some((case, term, reason)) = &l.stuck { + m.insert("stuck".into(), json!({ "case": case, "term": term, "reason": reason })); + } + if l.checked > 0 { + m.insert("inputs".into(), J::from(l.checked)); + } + if let Some(n) = &l.note { + m.insert("note".into(), J::String(n.clone())); + } + o + }) + .collect(); + json!({ + "run": self.run, + "defs_hash": self.defs_hash, + "sound": self.sound, + "laws": laws, + "errors": self.errors, + "score": { + "proven": self.count("proven"), + "admitted": self.count("admitted"), + "falsified": self.count("falsified"), + "unknown": self.count("unknown"), + "value": self.score(), + } + }) + } + + pub fn to_text(&self) -> String { + let mut s = String::new(); + for (title, origin) in [("laws", Origin::Laws), ("bridge (bounded only)", Origin::Builtins), ("canary", Origin::Canary)] { + let ls: Vec<_> = self.laws.iter().filter(|l| l.origin == origin).collect(); + if ls.is_empty() { + continue; + } + s.push_str(&format!("{title}:\n")); + for l in ls { + s.push_str(&format!(" {:<10} {}", l.status, l.name)); + if let Some((asg, lv, rv)) = &l.counterexample { + let a: Vec = asg.iter().map(|(k, v)| format!("{k}={v}")).collect(); + s.push_str(&format!("\n counterexample {}\n lhs = {lv}\n rhs = {rv}", a.join(" "))); + } + if let Some((case, term, reason)) = &l.stuck { + s.push_str(&format!(" case {case}: stuck at\n L = {term}\n {reason}")); + } + if let Some(n) = &l.note { + s.push_str(&format!(" ({n})")); + } + s.push('\n'); + } + } + for e in &self.errors { + s.push_str(&format!("error: {e}\n")); + } + s.push_str(&format!( + "\nsound: {} score: {} (proven {}, admitted {}, falsified {}, unknown {})\ndefs_hash: {}\n", + self.sound, + self.score(), + self.count("proven"), + self.count("admitted"), + self.count("falsified"), + self.count("unknown"), + self.defs_hash + )); + s + } +} + +#[cfg(test)] +mod tests; diff --git a/crates/loon-lang/src/verify/tests.rs b/crates/loon-lang/src/verify/tests.rs new file mode 100644 index 0000000..22c7c4f --- /dev/null +++ b/crates/loon-lang/src/verify/tests.rs @@ -0,0 +1,738 @@ +use super::kernel::{self, check_proof, term_eq, Goal, Outcome, Rule}; +use super::*; + +const DEFS: &str = r#" +[type List T [Cons T (List T)] Nil] +[fn append [xs ys] + [match xs + Nil ys + [Cons x rest] [Cons x [append rest ys]]]] +[fn reverse [xs] + [match xs + Nil Nil + [Cons x rest] [append [reverse rest] [Cons x Nil]]]] +[fn spin [xs] [spin xs]] +"#; + +fn p(s: &str) -> Expr { + crate::parser::parse(s).unwrap().pop().unwrap() +} + +fn defs() -> Defs { + Defs::from_exprs(&crate::parser::parse(DEFS).unwrap()).unwrap() +} + +fn prove(defs: &Defs, params: &[&str], lhs: &str, rhs: &str, steps: &str, lemmas: &kernel::Lemmas) -> Outcome { + let params: Vec = params.iter().map(|s| s.to_string()).collect(); + let types: HashMap = params.iter().map(|p| (p.clone(), kernel::Ty::named("List"))).collect(); + let (l, r) = (p(lhs), p(rhs)); + let goal = Goal { law_name: "t", params: ¶ms, param_types: &types, lhs: &l, rhs: &r }; + let steps = crate::parser::parse(steps).unwrap(); + check_proof(&goal, &steps, defs, lemmas) +} + +fn none(_: &str) -> Option<(Rule, bool)> { + None +} + +#[test] +fn totality() { + let d = defs(); + assert!(d.total.contains("append")); + assert!(d.total.contains("reverse")); + assert!(!d.total.contains("spin")); +} + +#[test] +fn unfold_normalizes_nil_case() { + let d = defs(); + let mut used = HashSet::new(); + let t = kernel::unfold(&p("[append Nil ys]"), "append", &d, &mut used).unwrap(); + assert!(term_eq(&kernel::normalize(&t, &d), &p("ys"))); + let t = kernel::unfold(&p("[append [Cons a b] ys]"), "append", &d, &mut used).unwrap(); + assert!(term_eq(&kernel::normalize(&t, &d), &p("[Cons a [append b ys]]"))); +} + +#[test] +fn unfold_refuses_non_total() { + let d = defs(); + assert!(kernel::unfold(&p("[spin Nil]"), "spin", &d, &mut HashSet::new()).is_err()); +} + +#[test] +fn rewrite_with_rule() { + let d = defs(); + let ih = Rule { params: vec![], lhs: p("[append rest Nil]"), rhs: p("rest") }; + let t = kernel::rewrite(&p("[Cons x [append rest Nil]]"), &ih, 0, &d).unwrap(); + assert!(term_eq(&t, &p("[Cons x rest]"))); + // :at selects the Nth preorder match + let r = Rule { params: vec!["a".into()], lhs: p("[f a]"), rhs: p("a") }; + let t = kernel::rewrite(&p("[g [f 1] [f 2]]"), &r, 1, &d).unwrap(); + assert!(term_eq(&t, &p("[g [f 1] 2]"))); + assert!(kernel::rewrite(&p("[g 1]"), &r, 0, &d).is_err()); +} + +#[test] +fn induction_closes_append_nil() { + let d = defs(); + let o = prove( + &d, + &["xs"], + "[append xs Nil]", + "xs", + "[induction xs [Nil [unfold append]] [Cons [unfold append] [rewrite ih]]]", + &none, + ); + assert_eq!(o, Outcome::Proven); +} + +#[test] +fn stuck_reports_term() { + let d = defs(); + let o = prove( + &d, + &["xs"], + "[append xs Nil]", + "xs", + "[induction xs [Nil [unfold append]] [Cons [unfold append]]]", + &none, + ); + match o { + Outcome::Stuck { case, term, .. } => { + assert_eq!(case, "Cons"); + assert_eq!(term, "[Cons x [append rest Nil]]"); + } + o => panic!("expected stuck, got {o:?}"), + } +} + +#[test] +fn missing_case_is_stuck() { + let d = defs(); + let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[induction xs [Nil [unfold append]]]", &none); + assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("missing case Cons"))); +} + +#[test] +fn admit_taints() { + let d = defs(); + let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[induction xs [Nil [unfold append]] [Cons [admit]]]", &none); + assert_eq!(o, Outcome::Admitted); + // Citing an admitted lemma taints too. + let lem = |n: &str| (n == "an").then(|| (Rule { params: vec!["xs".into()], lhs: p("[append xs Nil]"), rhs: p("xs") }, true)); + let o = prove(&d, &["ys"], "[append [append ys Nil] Nil]", "ys", "[rewrite an] [rewrite an]", &lem); + assert_eq!(o, Outcome::Admitted); +} + +#[test] +fn ih_only_inside_induction() { + let d = defs(); + let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[rewrite ih]", &none); + assert!(matches!(o, Outcome::Stuck { .. })); + // `cases` gives no ih + let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[cases xs [Nil] [Cons [unfold append] [rewrite ih]]]", &none); + assert!(matches!(o, Outcome::Stuck { .. })); +} + +#[test] +fn induction_refuses_non_total_goal() { + let d = defs(); + let o = prove(&d, &["xs"], "[spin xs]", "[spin xs]", "[induction xs [Nil] [Cons]]", &none); + assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("structurally recursive"))); +} + +#[test] +fn canary_cannot_be_proven() { + let d = defs(); + for steps in ["", "[refl]", "[induction xs [Nil] [Cons [rewrite ih]]]", "[unfold reverse] [unfold append]"] { + let o = prove(&d, &["xs"], "[reverse xs]", "xs", steps, &none); + assert!(matches!(o, Outcome::Stuck { .. }), "steps {steps:?} gave {o:?}"); + } + let o = prove(&d, &[], "1", "2", "", &none); + assert!(matches!(o, Outcome::Stuck { .. })); +} + +// ─── Whole-pipeline tests over a temp verify dir ─────────────────────────── + +fn tmp_dir(tag: &str, files: &[(&str, &str)]) -> std::path::PathBuf { + let dir = std::env::temp_dir().join(format!("loon-verify-{tag}-{}", std::process::id())); + let _ = std::fs::remove_dir_all(&dir); + for (name, body) in files { + let path = dir.join(name); + std::fs::create_dir_all(path.parent().unwrap()).unwrap(); + std::fs::write(path, body).unwrap(); + } + dir +} + +fn status<'a>(r: &'a Report, name: &str) -> &'a LawReport { + r.laws.iter().find(|l| l.name == name).unwrap() +} + +const LAWS: &str = r#" +[law append-nil [xs] [= [append xs Nil] xs]] +[law append-assoc [xs ys zs] [= [append [append xs ys] zs] [append xs [append ys zs]]]] +[law rev-append-wrong [xs ys] [= [reverse [append xs ys]] [append [reverse xs] [reverse ys]]]] +"#; + +#[test] +fn pipeline_proves_falsifies_and_orders() { + let dir = tmp_dir( + "pipeline", + &[ + ("defs.oo", DEFS), + ("canary.oo", "[law canary [] [= 1 2]]"), + ("laws/l.oo", LAWS), + ( + "proofs/p.oo", + r#" +[proof append-assoc [induction xs [Nil [unfold append]] [Cons [unfold append] [unfold append] [rewrite ih]]]] +[proof append-nil [induction xs [Nil [unfold append]] [Cons [unfold append] [rewrite ih]]]] +[proof rev-append-wrong [admit]] +"#, + ), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + assert!(r.sound); + assert_eq!(status(&r, "append-nil").status, "proven"); + assert_eq!(status(&r, "append-assoc").status, "proven"); + let w = status(&r, "rev-append-wrong"); + assert_eq!(w.status, "falsified"); + let (asg, _, _) = w.counterexample.as_ref().unwrap(); + assert_eq!(asg.len(), 2); + assert_eq!(status(&r, "canary").status, "falsified"); + assert_eq!(r.score(), 2); + let j = r.to_json(); + assert_eq!(j["score"]["value"], 2); + assert!(j["defs_hash"].as_str().unwrap().contains(':')); +} + +#[test] +fn cycle_rejected() { + let dir = tmp_dir( + "cycle", + &[ + ("defs.oo", DEFS), + ("laws/l.oo", "[law a [xs] [= [append xs Nil] xs]]\n[law b [xs] [= xs [append xs Nil]]]"), + ("proofs/p.oo", "[proof a [rewrite b :rev]]\n[proof b [rewrite a :rev]]"), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + for n in ["a", "b"] { + let l = status(&r, n); + assert_eq!(l.status, "unknown"); + assert!(l.stuck.as_ref().unwrap().2.contains("cycle")); + } +} + +#[test] +fn admitted_canary_is_unsound() { + let dir = tmp_dir( + "canary", + &[ + ("defs.oo", DEFS), + ("canary.oo", "[law canary-list [xs] [= [reverse xs] xs]]"), + ("laws/l.oo", "[law append-nil [xs] [= [append xs Nil] xs]]"), + ( + "proofs/p.oo", + "[proof append-nil [induction xs [Nil [unfold append]] [Cons [unfold append] [rewrite ih]]]]\n[proof canary-list [admit]]", + ), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + assert!(!r.sound); + assert_eq!(status(&r, "canary-list").status, "unsound"); + assert_eq!(r.score(), 0); +} + +#[test] +fn plus_canonical_form() { + let d = defs(); + let n = |s: &str| kernel::normalize(&p(s), &d).to_string(); + assert_eq!(n("[+ 1 [+ a b]]"), "[+ 1 [+ a b]]"); + assert_eq!(n("[+ [+ 1 a] b]"), "[+ 1 [+ a b]]"); + assert_eq!(n("[+ b [+ a 1]]"), "[+ 1 [+ a b]]"); + assert_eq!(n("[+ 0 n]"), "n"); + assert_eq!(n("[+ n 0]"), "n"); + assert_eq!(n("[+ 2 [+ 3 x]]"), "[+ 5 x]"); + assert_eq!(n("[+ 0 0]"), "0"); + // not conflated with other arithmetic + assert_eq!(n("[- a b]"), "[- a b]"); + assert_eq!(n("[* [+ 1 a] b]"), "[* [+ 1 a] b]"); +} + +#[test] +fn plus_normalization_does_not_prove_falsehoods() { + let d = defs(); + let r = prove(&d, &["xs"], "[+ 1 [length xs]]", "[length xs]", "[refl]", &none); + assert!(!matches!(r, Outcome::Proven), "1 + n = n must not close"); + let r = prove(&d, &["xs"], "[+ a b]", "[+ a c]", "[refl]", &none); + assert!(!matches!(r, Outcome::Proven), "a + b = a + c must not close"); +} + +// --- nat agent: bounded generation for non-list ADTs --- +#[test] +fn bounded_enumerates_nat() { + let defs = r#" +[type Nat [S Nat] Z] +[fn add [m n] [match m Z n [S k] [S [add k n]]]] +[fn mul [m n] [match m Z Z [S k] [add n [mul k n]]]] +"#; + let dir = tmp_dir( + "nat", + &[ + ("defs.oo", defs), + ("canary.oo", "[law canary [] [= 1 2]]"), + ( + "laws/n.oo", + r#" +[law add-zero-right [n] [= [add n Z] n]] +[law mul-dist [a b p] [= [mul [add a b] p] [add [mul a p] [mul b p]]]] +[law mul-is-add [m n] [= [mul m n] [add m n]]] +"#, + ), + ("proofs/p.oo", "[proof add-zero-right [induction n [Z] [S [unfold add] [rewrite ih]]]]"), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + assert!(r.sound); + assert_eq!(status(&r, "add-zero-right").status, "proven"); + // `p` is only a non-scrutinized argument; it must still be generated as a Nat. + let d = status(&r, "mul-dist"); + assert!(!d.note.as_deref().unwrap_or("").contains("bounded"), "{:?}", d.note); + assert!(d.checked > 10); + let w = status(&r, "mul-is-add"); + assert_eq!(w.status, "falsified"); + let (asg, _, _) = w.counterexample.as_ref().unwrap(); + assert_eq!(format!("{}", asg[1].1), "[S Z]"); +} + +// ─── Compiler correctness: kernel extensions (compiler agent) ────────────── + +/// Hutton's razor with `exec` written as in the paper: nested constructor +/// patterns and a `_` fallback. The kernel handles this shape even though the +/// VM cannot run it (verify/defs.oo factors out `step` for that reason). +const COMPILER_DEFS: &str = r#" +[type List T [Cons T (List T)] Nil] +[type Expr [Lit Int] [Add Expr Expr]] +[type Instr [Push Int] IAdd] +[type Rose [Node Int (List Rose)]] +[fn append [xs ys] + [match xs + Nil ys + [Cons x rest] [Cons x [append rest ys]]]] +[fn eval [e] [match e [Lit n] n [Add a b] [+ [eval a] [eval b]]]] +[fn compile [e] + [match e + [Lit n] [Cons [Push n] Nil] + [Add a b] [append [compile a] [append [compile b] [Cons IAdd Nil]]]]] +[fn exec [code stack] + [match code + Nil stack + [Cons [Push n] rest] [exec rest [Cons n stack]] + [Cons IAdd rest] [match stack + [Cons y [Cons x s]] [exec rest [Cons [+ x y] s]] + _ [exec rest stack]]]] +[fn exec-halt [code stack] + [match code + Nil stack + [Cons [Push n] rest] [exec-halt rest [Cons n stack]] + [Cons IAdd rest] [match stack + [Cons y [Cons x s]] [exec-halt rest [Cons [+ x y] s]] + _ stack]]] +"#; + +fn cdefs() -> Defs { + Defs::from_exprs(&crate::parser::parse(COMPILER_DEFS).unwrap()).unwrap() +} + +fn ty(s: &str) -> kernel::Ty { + match p(s).kind { + ExprKind::Symbol(n) => kernel::Ty::named(&n), + ExprKind::List(v) => kernel::Ty::app( + &v[0].to_string(), + v[1..].iter().map(|a| ty(&a.to_string())).collect(), + ), + _ => panic!("bad type {s}"), + } +} + +fn prove_typed(defs: &Defs, params: &[(&str, &str)], lhs: &str, rhs: &str, steps: &str, lemmas: &kernel::Lemmas) -> Outcome { + let names: Vec = params.iter().map(|(n, _)| n.to_string()).collect(); + let types: HashMap = params.iter().map(|(n, t)| (n.to_string(), ty(t))).collect(); + let (l, r) = (p(lhs), p(rhs)); + let goal = Goal { law_name: "t", params: &names, param_types: &types, lhs: &l, rhs: &r }; + let steps = crate::parser::parse(steps).unwrap(); + check_proof(&goal, &steps, defs, lemmas) +} + +fn exec_append_lemma(n: &str) -> Option<(Rule, bool)> { + (n == "exec-append").then(|| { + ( + Rule { + params: vec!["c1".into(), "c2".into(), "s".into()], + lhs: p("[exec [append c1 c2] s]"), + rhs: p("[exec c2 [exec c1 s]]"), + }, + false, + ) + }) +} + +const EXEC_APPEND_PROOF: &str = r#" +[induction c1 + [Nil [unfold append]] + [Cons [cases x + [Push [unfold append] [unfold exec] [rewrite ih]] + [IAdd [unfold append] [unfold exec] + [cases s + [Nil [rewrite ih]] + [Cons [cases rest1 + [Nil [rewrite ih]] + [Cons [rewrite ih]]]]]]]]] +"#; + +#[test] +fn nested_pattern_exec_is_total() { + let d = cdefs(); + assert!(d.total.contains("exec"), "code shrinks on every call"); + assert!(d.total.contains("exec-halt")); + assert!(d.total.contains("compile")); + assert!(d.total.contains("eval")); +} + +#[test] +fn reduce_match_nested_patterns_and_wildcard() { + let d = cdefs(); + let n = |s: &str| kernel::normalize(&p(s), &d).to_string(); + let m = "[match S [Cons y [Cons x s]] [hit x y s] _ [miss]]"; + assert_eq!(n(&m.replace('S', "[Cons 1 [Cons 2 t]]")), "[hit 2 1 t]"); + assert_eq!(n(&m.replace('S', "[Cons 1 Nil]")), "[miss]"); + assert_eq!(n(&m.replace('S', "Nil")), "[miss]"); + // Undecided inner pattern: must not fall through to `_`. + assert_eq!(n(&m.replace('S', "[Cons 1 t]")), m.replace('S', "[Cons 1 t]")); +} + +#[test] +fn field_types_instantiate_type_params() { + let d = cdefs(); + let cons = d.types["List"].iter().find(|c| c.name == "Cons").unwrap(); + let ft = kernel::field_tys(&d, &ty("[List Instr]"), &cons.fields); + assert_eq!(ft, vec![Some(ty("Instr")), Some(ty("[List Instr]"))]); + // Unknown element type: the head field gets no type. + let ft = kernel::field_tys(&d, &kernel::Ty::named("List"), &cons.fields); + assert_eq!(ft[0], None); +} + +#[test] +fn cases_on_constructor_field_with_inferred_type() { + // exec-append over the nested-pattern exec needs `cases` on the head + // instruction `x` (a field, typed Instr via List Instr) and on the stack + // and its tail `rest1` (List Int). + let d = cdefs(); + let o = prove_typed( + &d, + &[("c1", "[List Instr]"), ("c2", "[List Instr]"), ("s", "[List Int]")], + "[exec [append c1 c2] s]", + "[exec c2 [exec c1 s]]", + EXEC_APPEND_PROOF, + &none, + ); + assert_eq!(o, Outcome::Proven); + // Without the element type, `x` cannot be split. + let o = prove_typed( + &d, + &[("c1", "List"), ("c2", "List"), ("s", "List")], + "[exec [append c1 c2] s]", + "[exec c2 [exec c1 s]]", + EXEC_APPEND_PROOF, + &none, + ); + assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("type of `x`")), "{o:?}"); + // `cases` on an Int is refused. + let o = prove_typed(&d, &[("s", "[List Int]")], "s", "s", "[cases s [Nil] [Cons [cases x [A] [B]]]]", &none); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); +} + +#[test] +fn halting_exec_does_not_distribute() { + // exec-halt stops on stack underflow, so exec-append is false for it; + // the same proof must get stuck. + let d = cdefs(); + let o = prove_typed( + &d, + &[("c1", "[List Instr]"), ("c2", "[List Instr]"), ("s", "[List Int]")], + "[exec-halt [append c1 c2] s]", + "[exec-halt c2 [exec-halt c1 s]]", + &EXEC_APPEND_PROOF.replace("exec", "exec-halt"), + &none, + ); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); +} + +#[test] +fn two_hypotheses_for_two_recursive_fields() { + let d = cdefs(); + let goal = |steps: &str| { + prove_typed( + &d, + &[("e", "Expr"), ("stack", "[List Int]")], + "[exec [compile e] stack]", + "[Cons [eval e] stack]", + steps, + &exec_append_lemma, + ) + }; + let ok = "[induction e [Lit] [Add [unfold compile] [rewrite exec-append] [rewrite ih-rest] [rewrite exec-append] [rewrite ih-rest1]]]"; + assert_eq!(goal(ok), Outcome::Proven); + // Plain `ih` is ambiguous with two hypotheses. + let o = goal("[induction e [Lit] [Add [unfold compile] [rewrite exec-append] [rewrite ih]]]"); + assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("ambiguous")), "{o:?}"); + // The stuck report lists the hypotheses in scope. + let o = goal("[induction e [Lit] [Add [unfold compile]]]"); + match o { + Outcome::Stuck { case, reason, .. } => { + assert_eq!(case, "Add"); + assert!(reason.contains("ih-rest ih-rest1"), "{reason}"); + } + o => panic!("expected stuck, got {o:?}"), + } + // A hypothesis is about its own field: using ih-rest where ih-rest1 is + // needed does not match. + let o = goal("[induction e [Lit] [Add [unfold compile] [rewrite exec-append] [rewrite ih-rest] [rewrite exec-append] [rewrite ih-rest]]]"); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); + // Unknown hypothesis names are refused, not looked up as laws. + let o = goal("[induction e [Lit] [Add [rewrite ih-zz]]]"); + assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("ih-zz")), "{o:?}"); +} + +#[test] +fn hypotheses_quantify_the_other_params() { + // ih-rest1 is used at stack := [Cons [eval rest] stack]. If hypotheses + // were fixed at the original stack, this proof would get stuck. + let d = cdefs(); + let o = prove_typed( + &d, + &[("e", "Expr"), ("stack", "[List Int]")], + "[exec [compile e] stack]", + "[Cons [eval e] stack]", + "[induction e [Lit] [Add [unfold compile] [rewrite exec-append] [rewrite ih-rest] [rewrite exec-append] [rewrite ih-rest1]]]", + &exec_append_lemma, + ); + assert_eq!(o, Outcome::Proven); + // ...but not over the induction variable: a false law stays unprovable. + let o = prove_typed( + &d, + &[("e", "Expr"), ("stack", "[List Int]")], + "[exec [compile e] stack]", + "[Cons [eval e] Nil]", + "[induction e [Lit] [Add [unfold compile] [rewrite exec-append] [rewrite ih-rest] [rewrite exec-append] [rewrite ih-rest1]]]", + &exec_append_lemma, + ); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); +} + +#[test] +fn no_hypothesis_for_indirectly_recursive_fields() { + // Rose's field `(List Rose)` mentions Rose but is a list, not a Rose: + // induction on Rose must not offer a hypothesis about it. + let d = cdefs(); + let o = prove_typed(&d, &[("t", "Rose")], "[f t]", "[g t]", "[induction t [Node [rewrite ih]]]", &none); + assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("no induction hypothesis")), "{o:?}"); +} + +#[test] +fn infer_law_param_types() { + let d = cdefs(); + let ts = super::infer::law_param_types( + &d, + &d.fn_order, + &["c1".into(), "c2".into(), "s".into()], + &p("[exec [append c1 c2] s]"), + &p("[exec c2 [exec c1 s]]"), + ) + .unwrap(); + let ts: Vec = ts.iter().map(|t| format!("{:?}", super::infer::to_ty(t))).collect(); + assert!(ts[0].contains("\"List\"") && ts[0].contains("\"Instr\""), "{ts:?}"); + assert!(ts[2].contains("\"List\"") && ts[2].contains("\"Int\""), "{ts:?}"); + // compile uses append at Instr; a plain list law stays polymorphic. + let ts = super::infer::law_param_types(&d, &d.fn_order, &["xs".into()], &p("[append xs Nil]"), &p("xs")).unwrap(); + assert_eq!(super::infer::to_ty(&ts[0]), kernel::Ty::app("List", vec![kernel::Ty::unknown()])); + // Ill-typed laws do not infer. + assert!(super::infer::law_param_types(&d, &d.fn_order, &["e".into()], &p("[eval e]"), &p("[Cons 1 Nil]")).is_none()); +} + +#[test] +fn typed_generator_enumerates_any_adt() { + use crate::types::Type; + let d = cdefs(); + let expr = Type::Con("Expr".into(), vec![]); + assert!(super::bounded::typed_values(&expr, 0, &d, 0).is_empty()); + let one: Vec = super::bounded::typed_values(&expr, 1, &d, 0).iter().map(|e| e.to_string()).collect(); + assert_eq!(one, vec!["[Lit 0]", "[Lit 1]", "[Lit 2]"]); + assert_eq!(super::bounded::typed_values(&expr, 3, &d, 0).len(), 9); // Add of two Lits + let code = Type::Con("List".into(), vec![Type::Con("Instr".into(), vec![])]); + let c1: Vec = super::bounded::typed_values(&code, 1, &d, 0).iter().map(|e| e.to_string()).collect(); + assert_eq!(c1, vec!["[Cons IAdd Nil]"]); +} + +#[test] +fn pipeline_falsifies_false_compiler_law() { + let dir = tmp_dir( + "compiler", + &[ + ("defs.oo", &std::fs::read_to_string(concat!(env!("CARGO_MANIFEST_DIR"), "/../../verify/defs.oo")).unwrap()), + ( + "laws/c.oo", + "[law compile-drops-stack [e stack] [= [exec [compile e] stack] [Cons [eval e] Nil]]]\n\ + [law exec-append [c1 c2 s] [= [exec [append c1 c2] s] [exec c2 [exec c1 s]]]]", + ), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + let w = status(&r, "compile-drops-stack"); + assert_eq!(w.status, "falsified"); + let (asg, _, _) = w.counterexample.as_ref().unwrap(); + assert_eq!(format!("{}", asg[0].1), "[Lit 0]"); + // the true law survives the bounded check on instruction lists + let t = status(&r, "exec-append"); + let bounded_err = t.note.as_deref().is_some_and(|n| n.contains("bounded")); + assert!(t.counterexample.is_none() && !bounded_err && t.checked > 100, "{:?} {}", t.note, t.checked); +} + +// ─── AC normalization of declared operators ──────────────────────────────── + +const NAT_DEFS: &str = r#" +[type Nat [S Nat] Z] +[fn add [m n] [match m Z n [S k] [S [add k n]]]] +[fn mul [m n] [match m Z Z [S k] [add n [mul k n]]]] +"#; + +fn nat_ac(unit: bool) -> Defs { + let mut d = Defs::from_exprs(&crate::parser::parse(NAT_DEFS).unwrap()).unwrap(); + d.ac.push(AcOp { op: "add".into(), unit: unit.then(|| kernel::sym("Z")) }); + d +} + +fn prove_nat(d: &Defs, params: &[&str], lhs: &str, rhs: &str, steps: &str) -> Outcome { + let ps: Vec<(&str, &str)> = params.iter().map(|p| (*p, "Nat")).collect(); + prove_typed(d, &ps, lhs, rhs, steps, &none) +} + +#[test] +fn ac_closes_permuted_nesting() { + let d = nat_ac(false); + let o = prove_nat(&d, &["a", "b", "c"], "[add [add a b] c]", "[add c [add b a]]", ""); + assert_eq!(o, Outcome::Proven); + // not without the declaration + let plain = Defs::from_exprs(&crate::parser::parse(NAT_DEFS).unwrap()).unwrap(); + let o = prove_nat(&plain, &["a", "b", "c"], "[add [add a b] c]", "[add c [add b a]]", ""); + assert!(matches!(o, Outcome::Stuck { .. })); +} + +#[test] +fn ac_does_not_prove_falsehoods() { + let d = nat_ac(true); + let o = prove_nat(&d, &["a", "b", "c"], "[add a b]", "[add a c]", "[refl]"); + assert!(!matches!(o, Outcome::Proven), "a + b = a + c must not close"); + let o = prove_nat(&d, &["a", "b"], "[mul a b]", "[add a b]", ""); + assert!(!matches!(o, Outcome::Proven)); + let o = prove_nat(&d, &["a"], "[add a a]", "a", ""); + assert!(!matches!(o, Outcome::Proven)); +} + +#[test] +fn ac_unit_dropped_only_when_declared() { + let n = |d: &Defs, s: &str| kernel::normalize(&p(s), d).to_string(); + let with = nat_ac(true); + assert_eq!(n(&with, "[add n Z]"), "n"); + assert_eq!(n(&with, "[add Z [add n Z]]"), "n"); + assert_eq!(n(&with, "[add Z Z]"), "Z"); + assert_eq!(n(&with, "[add b [add Z a]]"), "[add a b]"); + let without = nat_ac(false); + assert_eq!(n(&without, "[add n Z]"), "[add Z n]"); +} + +const AC_LAWS: &str = r#" +[law add-zero-right [n] [= [add n Z] n]] +[law add-succ-right [m n] [= [add m [S n]] [S [add m n]]]] +[law add-comm [m n] [= [add m n] [add n m]]] +[law add-assoc [m n p] [= [add [add m n] p] [add m [add n p]]]] +[law add-rotate [a b c] [= [add [add a b] c] [add c [add b a]]]] +[ac add add-assoc add-comm :unit Z add-zero-right] +"#; + +const AC_PROOFS_GOOD: &str = r#" +[proof add-zero-right [induction n [Z] [S [unfold add] [rewrite ih]]]] +[proof add-succ-right [induction m [Z [unfold add]] [S [unfold add] [rewrite ih]]]] +[proof add-assoc [induction m [Z] [S [unfold add] [unfold add] [rewrite ih]]]] +[proof add-rotate] +"#; + +fn ac_dir(tag: &str, laws: &str, proofs: &str) -> Report { + let dir = tmp_dir( + tag, + &[("defs.oo", NAT_DEFS), ("canary.oo", "[law canary [] [= 1 2]]"), ("laws/n.oo", laws), ("proofs/p.oo", proofs)], + ); + run_dir(&dir, &Options::default()).unwrap() +} + +#[test] +fn ac_active_after_its_laws_are_proven() { + let proofs = format!( + "{AC_PROOFS_GOOD}\n[proof add-comm [induction m [Z [unfold add] [rewrite add-zero-right :rev]] [S [unfold add] [rewrite ih] [rewrite add-succ-right :rev]]]]" + ); + let r = ac_dir("ac-on", AC_LAWS, &proofs); + assert!(r.errors.is_empty(), "{:?}", r.errors); + assert_eq!(status(&r, "add-comm").status, "proven"); + assert_eq!(status(&r, "add-rotate").status, "proven", "{:?}", status(&r, "add-rotate").stuck); +} + +#[test] +fn ac_not_active_in_proofs_of_its_own_laws() { + // With AC on, add-comm would close by normalization alone. + let proofs = format!("{AC_PROOFS_GOOD}\n[proof add-comm]"); + let r = ac_dir("ac-self", AC_LAWS, &proofs); + assert_eq!(status(&r, "add-comm").status, "unknown"); + // ...and add-rotate, which relies on the decl, is then not proven either. + assert_eq!(status(&r, "add-rotate").status, "unknown"); + // Same for a lemma a cited law's proof rests on (add-succ-right, via add-comm). + let proofs = AC_PROOFS_GOOD.replace( + "[proof add-succ-right [induction m [Z [unfold add]] [S [unfold add] [rewrite ih]]]]", + "[proof add-succ-right]", + ) + "\n[proof add-comm [induction m [Z [unfold add] [rewrite add-zero-right :rev]] [S [unfold add] [rewrite ih] [rewrite add-succ-right :rev]]]]"; + let r = ac_dir("ac-self2", AC_LAWS, &proofs); + assert_eq!(status(&r, "add-succ-right").status, "unknown"); +} + +#[test] +fn ac_malformed_decl_rejected() { + for (decl, frag) in [ + ("[ac add add-comm add-comm]", "add-comm` is not [= [add [add"), + ("[ac add add-assoc add-assoc]", "add-assoc` is not [= [add a b]"), + ("[ac add add-assoc add-comm :unit Z add-succ-right]", "add-succ-right` is not"), + ("[ac add add-assoc add-comm :unit S add-zero-right]", "unit `S`"), + ("[ac add add-assoc nope]", "`nope` is not a law"), + ("[ac Z add-assoc add-comm]", "not a two-argument fn"), + ("[ac add add-assoc]", "malformed"), + ] { + let laws = AC_LAWS.replace("[ac add add-assoc add-comm :unit Z add-zero-right]", decl); + let proofs = format!("{AC_PROOFS_GOOD}\n[proof add-comm [induction m [Z [unfold add] [rewrite add-zero-right :rev]] [S [unfold add] [rewrite ih] [rewrite add-succ-right :rev]]]]"); + let r = ac_dir("ac-bad", &laws, &proofs); + assert!(r.errors.iter().any(|e| e.contains(frag)), "{decl}: {:?}", r.errors); + assert_eq!(status(&r, "add-rotate").status, "unknown", "{decl}"); + } + // A comm law with the same shape but over a different op is rejected too. + let laws = format!("{AC_LAWS}\n[law mul-comm [m n] [= [mul m n] [mul n m]]]\n[ac add add-assoc mul-comm]"); + let r = ac_dir("ac-bad2", &laws, AC_PROOFS_GOOD); + assert!(r.errors.iter().any(|e| e.contains("mul-comm` is not")), "{:?}", r.errors); +} + +#[test] +fn ac_citing_admitted_law_taints() { + let proofs = format!("{AC_PROOFS_GOOD}\n[proof add-comm [admit]]"); + let r = ac_dir("ac-adm", AC_LAWS, &proofs); + assert_eq!(status(&r, "add-comm").status, "admitted"); + assert_eq!(status(&r, "add-rotate").status, "admitted"); +} diff --git a/crates/loon-lang/tests/effect_rows.rs b/crates/loon-lang/tests/effect_rows.rs index 09cf68d..15e876a 100644 --- a/crates/loon-lang/tests/effect_rows.rs +++ b/crates/loon-lang/tests/effect_rows.rs @@ -109,9 +109,11 @@ fn sum_with_both_uses_checks_clean() { let (effects, errors) = check(SUM_WITH_BOTH_USES); assert!(errors.is_empty(), "must check cleanly, got: {errors:?}"); let sum_with = effects.get("sum-with").unwrap(); + // `sum-with` recurses on `[drop 1 v]`, not a matched subterm, so it + // carries `Div` (nontermination) — but nothing else of its own. assert!( - sum_with.labels.is_empty(), - "sum-with has no effects of its own, got: {}", + sum_with.labels.iter().all(|l| l == "Div"), + "sum-with has no effects of its own besides Div, got: {}", sum_with.render() ); let main = effects.get("main").unwrap(); @@ -233,8 +235,9 @@ fn ctor_under_handler_runs_on_interp() { /// A recursive call INSIDE the handled body. The monomorphic self-reference /// aliases the function's own row with the body row; the handle boundary -/// must not bake the handled label into the function's row, so a `#{}` -/// (pure) annotation on the caller still checks. +/// must not bake the handled label into the function's row, so a `#{Div}` +/// annotation on the caller still checks (`weird` recurses on `[- n 1]`, +/// which is not structural, so it is `Div`). const RECURSIVE_CALL_IN_HANDLE: &str = "\ [effect A [a [] Int]] [fn weird [n] @@ -242,7 +245,7 @@ const RECURSIVE_CALL_IN_HANDLE: &str = "\ 0 [handle [+ [A.a] [weird [- n 1]]] [A.a] [resume 1]]]] -[fn main [] #{} +[fn main [] #{Div} [println [weird 3]]]"; #[test] diff --git a/docs/plans/2026-10-28-verify-autoresearch.md b/docs/plans/2026-10-28-verify-autoresearch.md new file mode 100644 index 0000000..bca8b9f --- /dev/null +++ b/docs/plans/2026-10-28-verify-autoresearch.md @@ -0,0 +1,386 @@ +# Verify: laws, a rewrite kernel, and an autoresearch loop + +*October 2026 — design, nothing shipped* + +Loon gets a small verification story that fits its thesis: invisible types, +effects as the security model, a VM that replays deterministically. No +dependent types, no tactic language. Three things, in order: + +1. **`Div` as an effect** — nontermination is inferred like `IO` is. Pure + total code is `#{}`; the kernel reasons only about that fragment. +2. **`law` + `proof` + a rewrite kernel** — equational logic with structural + induction over ADTs. Proof objects are data; the kernel re-checks them. +3. **`loon verify`** — a harness that falsifies cheaply, proves what it can, + and emits a JSON report an agent can loop on overnight (the autoresearch + pattern: fixed harness, agent edits one directory, keep what scores). + +What we take from Lean: a tiny trusted kernel, an untrusted elaborator (here, +the LLM), `sorry` as a tainting escape hatch, totality tiers. What we take +from Bend/Kind: proof by normalization, and the observation that Loon's +ownership discipline is already the proof a parallel backend would need. + +## 0. Ground truth that shapes the design + +- The prelude (`crates/loon-lang/src/prelude.rs`) is two ADTs. `reverse`, + `map`, `concat`, `flatten` are Rust builtins (`builtins.rs`, kind + `Special`) with no Loon body. **The kernel cannot unfold what has no + definition.** So verification starts from a *reference prelude* written in + Loon, and the builtins are checked against it by bounded evaluation. +- `loon run` does not gate on `loon check` (`docs/capabilities.md`). A + verification story on top of a checker the runtime ignores is marketing. + Wiring `check` into `run` is a prerequisite, not part of this plan. +- `[test name [params] body]` already exists (`interp/mod.rs`, + `eval_test_def`). `law` sits next to it syntactically. +- The VM is deterministic and records/replays. A failing run is reproducible, + which is what makes an overnight loop's signal trustworthy. + +## 1. `Div`: nontermination as an effect + +Koka's `div`. A function that may not terminate carries `Div` in its row. +Inference: + +- Structural recursion on an ADT argument (every recursive call is on a + strict subterm of a `match` scrutinee) → no `Div`. +- Any other recursion, or a call to a `Div` function, → `Div`. +- Builtins that can loop (`loop`, `while`, anything taking a callback it may + call forever) are declared `#{Div}`. +- An explicit annotation can *add* `Div` (opt out of the check), never remove + it. + +Invisible for almost all code: the row is inferred, nobody writes it. The +payoff is a decidable fragment: `#{}` functions can be evaluated at check +time and unfolded by the kernel. + +Lives in `check/`, next to effect-row inference. Error code in the E04xx +range. + +## 2. Laws and proofs + +### 2.1 The reference prelude + +`verify/defs.oo`, frozen (content-hashed; a hash mismatch discards a run): + +```loon +[fn append [xs ys] + [match xs + #[] ys + [cons x rest] [cons x [append rest ys]]]] + +[fn reverse [xs] + [match xs + #[] #[] + [cons x rest] [append [reverse rest] #[x]]]] + +[fn length [xs] + [match xs + #[] 0 + [cons _ rest] [+ 1 [length rest]]]] + +[fn map [f xs] + [match xs + #[] #[] + [cons x rest] [cons [f x] [map f rest]]]] +``` + +A separate `verify/builtins.oo` holds *equivalence laws* between each +reference function and its builtin, e.g. `[law reverse-builtin [xs] +[= [reverse xs] [builtin-reverse xs]]]`. These are never proven, only +bounded-checked. They are the bridge: a proof about reference `reverse` says +something about the `reverse` people run only to the extent that bridge holds. + +### 2.2 `law` + +```loon +[law append-nil [xs] [= [append xs #[]] xs]] +[law append-assoc [xs ys zs] + [= [append [append xs ys] zs] [append xs [append ys zs]]]] +``` + +Grammar: `[law NAME [PARAMS...] [= LHS RHS]]`. Params are universally +quantified; their types are inferred from use. Only `=` for now. Both sides +must be `#{}` (no `Div`, no other effects) or the law is rejected at parse +time with an error naming the offending call. + +A law in a file is a *conjecture*. Its status is one of: + +| status | meaning | +|-------------|-----------------------------------------------------------| +| `falsified` | bounded evaluation found a counterexample (reported) | +| `proven` | a `proof` for it was kernel-checked with no `admit` | +| `admitted` | a `proof` was checked but contained `admit` | +| `unknown` | no proof, or the proof got stuck (stuck term reported) | + +### 2.3 `proof` + +```loon +[proof append-nil + [induction xs + [nil [unfold append]] + [cons [unfold append] [rewrite ih]]]] +``` + +Grammar: + +``` +proof := [proof NAME STEP*] +STEP := [unfold FN] ; one unfolding of FN at the leftmost-outermost redex + | [rewrite RULE] ; rewrite leftmost-outermost match, left to right + | [rewrite RULE :rev] ; right to left + | [rewrite RULE :at N] ; Nth match in preorder, 0-based + | [induction VAR CASE*] ; VAR must be a law param of ADT type + | [cases VAR CASE*] ; like induction, no new ih; VAR may be a + ; constructor field bound by an earlier split + | [refl] ; both sides syntactically equal after normalization + | [admit] ; close the goal, taint the proof +CASE := [CTOR STEP*] ; CTOR is a constructor of VAR's type; nil/cons for Vec +RULE := ih ; the induction hypothesis, when exactly one is in scope + | ih-FIELD ; the hypothesis for recursive field FIELD + | NAME ; a law already proven earlier in dependency order +``` + +Semantics, per goal `[= L R]`: + +- The kernel keeps a current goal. Each step transforms `L` (never `R`; + symmetric steps are expressed with `:rev`). +- `unfold FN` replaces the leftmost-outermost application of `FN` by its + body with arguments substituted, then normalizes `match` on a constructor + head. If no such application exists, the step fails. +- `rewrite RULE` instantiates `RULE`'s free variables by matching its LHS + against a subterm of the goal's `L`; replaces it with the instantiated RHS. + Matching is first-order, syntactic, up to normalization of constructor + `match`. No unification through function bodies. +- `induction VAR` splits the goal per constructor. In a recursive + constructor's case, `ih` is the law instantiated at the recursive subterm. + The case's fields get fresh names (`x`, `rest`, `rest1`, ... avoiding names + already in the goal), and there is one hypothesis per field whose declared + type is the ADT itself, cited as `ih-FIELD` (e.g. `[Add a b]` gives + `ih-rest` and `ih-rest1`). Plain `ih` works only when exactly one is in + scope. Hypotheses stay universally quantified over the law's other params, + so `ih-rest1` may be used at a different stack than the goal's. Stuck + reports list the hypotheses in scope. A field like `(List Rose)` inside + `Rose` mentions the ADT but gets no hypothesis. +- `cases VAR` works on law params and on constructor fields from an earlier + split. A field's type comes from the constructor's declaration with the + ADT's type parameters instantiated, so the head of a `List Instr` param is + an `Instr` and can be split into `Push`/`IAdd`. Law param types come from + verify's own HM inference over defs.oo (`verify/infer.rs`), falling back + to the language checker. Note this inference is effectively trusted: a + split over the wrong ADT would be unsound, as it already was with the + checker-derived types. It is small and fails closed (no type, no split). + Only legal if every function mentioned in the goal is `#{}` — this is where + `Div` does its work. +- A goal closes when `L` and `R` are syntactically equal after normalization + (`refl` is implicit at the end of every case; writing it is allowed). +- A proof may cite a law as `RULE` only if that law is `proven` or `admitted` + *earlier in dependency order*. Citing an `admitted` law makes the citing + proof `admitted`. Cycles are rejected. + +AC declarations (a top-level form in `laws/*.oo`): + +``` +ac := [ac OP ASSOC-LAW COMM-LAW] + | [ac OP ASSOC-LAW COMM-LAW :unit UNIT UNIT-LAW] +``` + +e.g. `[ac add add-assoc add-comm :unit Z add-zero-right]`. Rules: + +- `OP` must be a two-argument fn of defs.oo. The kernel checks each cited + law's statement for shape, up to renaming of its params and either + orientation: ASSOC-LAW `[= [OP [OP a b] c] [OP a [OP b c]]]`, COMM-LAW + `[= [OP a b] [OP b a]]`, UNIT-LAW `[= [OP n UNIT] n]` or + `[= [OP UNIT n] n]`, with `UNIT` a nullary constructor or a literal. A + malformed declaration is reported in `errors` and ignored. +- The declaration counts as citing its laws, in every proof whose law (or a + law it cites) mentions `OP` or a fn reaching `OP`, except the proofs the + cited laws themselves transitively rest on: those never see the + normalization. It is active for a proof only once all its laws are + `proven` or `admitted`; an `admitted` one makes the proof `admitted`. +- When active, normalization canonicalizes `OP` applications like the + builtin `+` (which is always on, with literal folding and 0 as unit): + nested applications are flattened, `UNIT` operands dropped, operands + sorted by printed form and rebuilt right-nested; one operand stands + alone, none gives `UNIT`. `rewrite` works on that canonical form (rule + sides are normalized the same way, and an `OP` node in a rule's LHS also + matches with its two operands swapped), so operand order in stuck + reports and `:at` counts is printed-form order. + +That is the whole trusted surface: substitution, one-step unfolding, +first-order matching, constructor-`match` normalization, and the induction +scheme for ADTs. Target size: a few hundred lines in `check/verify.rs`. +Everything clever lives outside it. + +### 2.4 Worked example + +Full trace for `append-nil`, cons case. Goal after `induction xs`, case +`[cons x r]`, with `ih : [= [append r #[]] r]`: + +``` +L = [append [cons x r] #[]] +unfold append → [match [cons x r] #[] #[] [cons x rest] [cons x [append rest #[]]]] + → [cons x [append r #[]]] ; match normalized +rewrite ih → [cons x r] +R = [cons x r] ; closed +``` + +A proof that needs lemmas: + +```loon +[proof rev-append ; [= [reverse [append xs ys]] [append [reverse ys] [reverse xs]]] + [induction xs + [nil [unfold reverse] [unfold append] [rewrite append-nil :rev]] + [cons [unfold reverse] [unfold append] [rewrite ih] [rewrite append-assoc]]]] + +[proof rev-rev ; [= [reverse [reverse xs]] xs] + [induction xs + [nil [unfold reverse]] + [cons [unfold reverse] [rewrite rev-append] [rewrite ih] + [unfold reverse] [unfold append]]]] +``` + +When a proof is stuck the report says where: + +``` +unknown rev-rev case cons: stuck at + L = [reverse [append [reverse r] #[x]]] + no step applies +``` + +The stuck term is the signal. It names the missing lemma. + +## 3. `loon verify` + +``` +loon verify [DIR] # default: verify/ + --json # machine report (the agent reads this) + --bound N # bounded-evaluation input size, default 6 + --seed S # for the generator; default fixed +``` + +Directory layout, with what is writable by an agent in the loop: + +``` +verify/ + defs.oo frozen reference prelude + builtins.oo frozen bridge laws (bounded-only) + canary.oo frozen [law canary [] [= 1 2]] and friends + laws/ agent conjectures + proofs/ agent proof objects +``` + +Pipeline per run: + +1. Parse everything; reject any law whose sides are not `#{}`. +2. **Bounded evaluation** of every law: generate inputs up to `--bound` + (exhaustive for small ADTs, seeded random for `Int`/`Str`), evaluate both + sides in the EIR VM, report the smallest counterexample. Laws falsified + here are *not* sent to the kernel. +3. **Kernel** for every surviving law with a `proof`, in dependency order. +4. **Canary check**: if any canary law is `proven` or `admitted`, the whole + run is reported `unsound` and scored 0. +5. **Report** — human text, or JSON: + +```json +{ + "run": "2026-10-28T03:14:00Z", + "defs_hash": "sha256:…", + "sound": true, + "laws": [ + {"name": "append-nil", "status": "proven"}, + {"name": "rev-append", "status": "falsified", + "counterexample": {"xs": [1], "ys": [2]}, "lhs": [2,1], "rhs": [1,2]}, + {"name": "rev-rev", "status": "unknown", + "stuck": {"case": "cons", "term": "[reverse [append [reverse r] #[x]]]"}} + ], + "score": {"proven": 1, "admitted": 0, "falsified": 1, "unknown": 1, "value": 1} +} +``` + +Score: `proven - admitted * 2`, and `0` when `sound` is false. A +`falsified` law is not penalized — a counterexample is a result. The +agent's incentive is to turn `unknown` into `proven`, or into a corrected +conjecture. + +## 4. The autoresearch loop + +Karpathy's pattern, unchanged: a fixed harness, an agent that edits one +directory, run, keep if better, repeat. + +``` +loop: + agent reads report.json + agent edits verify/laws/ and verify/proofs/ (nothing else) + loon verify --json > report.json + if report.sound and report.score > best: + commit; best = score + else: + git checkout -- verify/laws verify/proofs +``` + +What the agent does with each status: + +- `falsified` → fix the conjecture (the counterexample says how) or drop it. +- `unknown`, stuck → the stuck term names a lemma; conjecture it, prove it, + retry. +- `unknown`, no proof → write one. Start with `induction` on the first + param of ADT type; that is right surprisingly often. +- `proven` → leave it. Proven laws are rewrite rules for later proofs and, + eventually, for the optimizer. + +Why the score is trustworthy: + +- `defs.oo`, `builtins.oo`, `canary.oo` and the kernel are not in the + writable set, and `defs_hash` is in the report. The agent cannot weaken + what it is scored against. +- `admit` is visible and taxed. It never produces `proven`. +- The canary cannot be proven by a sound kernel. If it is, the run is thrown + out and the kernel bug is the night's most valuable output. +- Every run is deterministic (fixed seed, EIR VM); a surprising result + replays. + +### 4.1 Conjecture mining (later) + +QuickSpec-style: enumerate terms up to depth 3 over `defs.oo` functions and +a few variables, bucket them by evaluation on random inputs, emit `[law …]` +for each pair in a bucket. Bounded evaluation prunes the lies; the agent +proves the rest. This is what turns "prove what I wrote" into "find what is +true". Not needed to start the loop; hand-written seed laws are enough. + +## 5. Order of work + +1. **`Div` inference** in `check/`. Small, self-contained, has value on its + own (the checker can evaluate `#{}` code at compile time). +2. **Reference prelude** `verify/defs.oo` + bridge laws. Mostly writing Loon. +3. **`law` form**: parse, type, reject non-`#{}` sides. +4. **Bounded evaluation** of laws in the VM. This alone is useful + (property testing with counterexamples) and ships before any kernel. +5. **Rewrite kernel**: `unfold`, `rewrite`, `induction`/`cases`, `refl`, + `admit`, dependency order, canary. `check/verify.rs`. +6. **`loon verify --json`**. +7. **The loop script** (`scripts/autoresearch.sh` or a Loon program using + `Process.exec`), and a first overnight run against list laws. +8. Conjecture miner. +9. Capability certificates: embed the checked effect rows and grant table in + `loon image` so fxos re-checks them at load. Separate plan; same spirit. + +## 6. Not doing + +- Dependent types, refinement types, SMT. Conflicts with invisible types and + would make the trusted surface large. SMT may return as an optional + *bounded* backend later; it never becomes the kernel. +- A tactic language. The LLM is the tactic engine; the kernel only checks. +- Laws over effectful code. If it is not `#{}`, bounded evaluation under + record/replay is the tool, not proof. +- Proving builtins correct. They are *bridged* by bounded laws, and that + gap is stated in every report (`builtins.oo` laws are listed with status + `bounded` and never `proven`). + +## 7. Open questions + +- `rewrite` position selection. `:at N` is crude; Lean's `rw … at h` and + `simp` lemma sets are where this goes if proofs get long. Decide after the + first overnight run shows what proofs actually look like. +- Induction on non-first params, nested induction, mutual recursion in + `defs.oo`. Reject initially; expand when a stuck proof demands it. +- Should `law` live in ordinary `.oo` files next to `test`, or only under + `verify/`? Leaning ordinary files, with `loon verify` collecting them, so + a library ships its laws. diff --git a/verify/builtins.oo b/verify/builtins.oo new file mode 100644 index 0000000..80c77e7 --- /dev/null +++ b/verify/builtins.oo @@ -0,0 +1,13 @@ +; Bridge laws: reference definitions (defs.oo) against the Rust builtins. +; Bounded-only: never proven, reported with status `bounded`. +; `builtin-NAME` names the builtin NAME (the reference fn shadows it otherwise). + +[fn to-vec [xs] + [match xs + Nil #[] + [Cons x rest] [concat #[x] [to-vec rest]]]] + +[law reverse-builtin [xs] [= [to-vec [reverse xs]] [builtin-reverse [to-vec xs]]]] +[law append-builtin [xs ys] [= [to-vec [append xs ys]] [builtin-concat [to-vec xs] [to-vec ys]]]] +[law length-builtin [xs] [= [length xs] [builtin-len [to-vec xs]]]] +[law map-builtin [f xs] [= [to-vec [map f xs]] [builtin-map f [to-vec xs]]]] diff --git a/verify/canary.oo b/verify/canary.oo new file mode 100644 index 0000000..4a01df9 --- /dev/null +++ b/verify/canary.oo @@ -0,0 +1,4 @@ +; Canaries: false laws. If the kernel ever accepts one, the run is unsound. + +[law canary [] [= 1 2]] +[law canary-list [xs] [= [reverse xs] xs]] diff --git a/verify/defs.oo b/verify/defs.oo new file mode 100644 index 0000000..ab674af --- /dev/null +++ b/verify/defs.oo @@ -0,0 +1,82 @@ +; Reference prelude for `loon prove`. Frozen: its hash is in every report. + +[type List T [Cons T (List T)] Nil] + +[fn append [xs ys] + [match xs + Nil ys + [Cons x rest] [Cons x [append rest ys]]]] + +[fn reverse [xs] + [match xs + Nil Nil + [Cons x rest] [append [reverse rest] [Cons x Nil]]]] + +[fn length [xs] + [match xs + Nil 0 + [Cons x rest] [+ 1 [length rest]]]] + +[fn map [f xs] + [match xs + Nil Nil + [Cons x rest] [Cons [f x] [map f rest]]]] + +; Peano naturals (nat agent) +[type Nat [S Nat] Z] + +[fn add [m n] + [match m + Z n + [S k] [S [add k n]]]] + +[fn mul [m n] + [match m + Z Z + [S k] [add n [mul k n]]]] + +[fn sum [n] + [match n + Z Z + [S k] [add [S k] [sum k]]]] + +[fn odds [n] + [match n + Z Z + [S k] [add [S [add k k]] [odds k]]]] ; 1 + 3 + ... + (2n-1) + +; Hutton's arithmetic compiler (compiler agent). One instruction's effect is +; `step`, so `exec` only matches on the code list: the VM does not bind +; variables in nested constructor patterns, and the checker shares one +; instantiation of `Cons` per function, so code and stack must not both be +; matched with `Cons` in the same fn. An IAdd that underflows the stack is +; skipped rather than halting execution, so exec distributes over append. +[type Expr [Lit Int] [Add Expr Expr]] +[type Instr [Push Int] IAdd] + +[fn eval [e] + [match e + [Lit n] n + [Add a b] [+ [eval a] [eval b]]]] + +[fn compile [e] + [match e + [Lit n] [Cons [Push n] Nil] + [Add a b] [append [compile a] [append [compile b] [Cons IAdd Nil]]]]] + +[fn add-top [stack] + [match stack + Nil Nil + [Cons y s] [match s + Nil [Cons y Nil] + [Cons x t] [Cons [+ x y] t]]]] + +[fn step [i stack] + [match i + [Push n] [Cons n stack] + IAdd [add-top stack]]] + +[fn exec [code stack] + [match code + Nil stack + [Cons i rest] [exec rest [step i stack]]]] diff --git a/verify/laws/compiler.oo b/verify/laws/compiler.oo new file mode 100644 index 0000000..e51f6d8 --- /dev/null +++ b/verify/laws/compiler.oo @@ -0,0 +1,11 @@ +; Compiler correctness for Hutton's razor (verify/defs.oo: eval, compile, exec). + +[law exec-append [c1 c2 s] + [= [exec [append c1 c2] s] [exec c2 [exec c1 s]]]] + +[law compile-correct [e stack] + [= [exec [compile e] stack] [Cons [eval e] stack]]] + +; false: the compiled code pushes onto the existing stack, it does not replace it +[law compile-drops-stack [e stack] + [= [exec [compile e] stack] [Cons [eval e] Nil]]] diff --git a/verify/laws/list.oo b/verify/laws/list.oo new file mode 100644 index 0000000..81ddd4f --- /dev/null +++ b/verify/laws/list.oo @@ -0,0 +1,22 @@ +; List conjectures over the reference prelude (verify/defs.oo). + +[law append-nil [xs] [= [append xs Nil] xs]] + +[law append-assoc [xs ys zs] + [= [append [append xs ys] zs] [append xs [append ys zs]]]] + +[law rev-append [xs ys] + [= [reverse [append xs ys]] [append [reverse ys] [reverse xs]]]] + +[law rev-rev [xs] [= [reverse [reverse xs]] xs]] + +[law length-append [xs ys] + [= [length [append xs ys]] [+ [length xs] [length ys]]]] + +[law map-append [f xs ys] + [= [map f [append xs ys]] [append [map f xs] [map f ys]]]] + +; added by hand after the agents finished +[law map-length [f xs] [= [length [map f xs]] [length xs]]] +[law map-rev-bogus [f xs] [= [map f [reverse xs]] [reverse xs]]] +[law rev-length [xs] [= [length [reverse xs]] [length xs]]] diff --git a/verify/laws/nat.oo b/verify/laws/nat.oo new file mode 100644 index 0000000..346f3e0 --- /dev/null +++ b/verify/laws/nat.oo @@ -0,0 +1,28 @@ +; Peano arithmetic over Nat (verify/defs.oo). + +[law add-zero-right [n] [= [add n Z] n]] +[law add-succ-right [m n] [= [add m [S n]] [S [add m n]]]] +[law add-comm [m n] [= [add m n] [add n m]]] +[law add-assoc [m n p] [= [add [add m n] p] [add m [add n p]]]] +[law mul-zero-right [n] [= [mul n Z] Z]] +[law mul-succ-right [m n] [= [mul m [S n]] [add m [mul m n]]]] +[law mul-comm [m n] [= [mul m n] [mul n m]]] +[law mul-distrib-left [m n p] [= [mul m [add n p]] [add [mul m n] [mul m p]]]] +[law mul-assoc [m n p] [= [mul [mul m n] p] [mul m [mul n p]]]] +[law gauss [n] [= [mul [S [S Z]] [sum n]] [mul n [S n]]]] + +; false on purpose: the falsifier should find counterexamples +[law mul-is-add-bogus [m n] [= [mul m n] [add m n]]] +[law sum-is-square-bogus [n] [= [sum n] [mul n n]]] + +; helper on the way to mul-assoc +[law mul-distrib-right [a b p] [= [mul [add a b] p] [add [mul a p] [mul b p]]]] + +; stretch: the sum of the first n odd numbers is n squared +[law odds-square [n] [= [odds n] [mul n n]]] + +; Close goals modulo associativity/commutativity (and unit) of these operators. +; The kernel checks each cited law's shape and only uses the normalization in +; proofs that come after those laws are proven (never in their own proofs). +[ac add add-assoc add-comm :unit Z add-zero-right] +[ac mul mul-assoc mul-comm] diff --git a/verify/proofs/compiler.oo b/verify/proofs/compiler.oo new file mode 100644 index 0000000..3a54c58 --- /dev/null +++ b/verify/proofs/compiler.oo @@ -0,0 +1,15 @@ +; Compiler correctness (Hutton): exec distributes over append, then the +; compiled code of e pushes eval e, by induction on e with one hypothesis per +; subexpression, each instantiated at a different stack. + +[proof exec-append + [induction c1 + [Nil [unfold append]] + [Cons [unfold append] [unfold exec] [rewrite ih]]]] + +[proof compile-correct + [induction e + [Lit] + [Add [unfold compile] + [rewrite exec-append] [rewrite ih-rest] + [rewrite exec-append] [rewrite ih-rest1]]]] diff --git a/verify/proofs/list.oo b/verify/proofs/list.oo new file mode 100644 index 0000000..88e71dd --- /dev/null +++ b/verify/proofs/list.oo @@ -0,0 +1,41 @@ +; Proof objects, checked by the kernel in dependency order. + +[proof append-nil + [induction xs + [Nil [unfold append]] + [Cons [unfold append] [rewrite ih]]]] + +[proof append-assoc + [induction xs + [Nil [unfold append]] + [Cons [unfold append] [unfold append] [rewrite ih]]]] + +[proof rev-append + [induction xs + [Nil [unfold append] [rewrite append-nil :rev]] + [Cons [unfold append] [unfold reverse] [rewrite ih] [rewrite append-assoc]]]] + +[proof rev-rev + [induction xs + [Nil [unfold reverse]] + [Cons [unfold reverse] [rewrite rev-append] [rewrite ih]]]] + +[proof map-append + [induction xs + [Nil [unfold append]] + [Cons [unfold append] [unfold map] [rewrite ih]]]] + +[proof length-append + [induction xs + [Nil [unfold append]] + [Cons [unfold append] [unfold length] [rewrite ih]]]] + +[proof map-length + [induction xs + [Nil [unfold map]] + [Cons [unfold map] [unfold length] [rewrite ih]]]] + +[proof rev-length + [induction xs + [Nil [unfold reverse]] + [Cons [unfold reverse] [rewrite length-append] [rewrite ih]]]] diff --git a/verify/proofs/nat.oo b/verify/proofs/nat.oo new file mode 100644 index 0000000..c8d65ff --- /dev/null +++ b/verify/proofs/nat.oo @@ -0,0 +1,61 @@ +; Peano ladder. + +[proof add-zero-right + [induction n + [Z] + [S [unfold add] [rewrite ih]]]] + +[proof add-succ-right + [induction m + [Z [unfold add]] + [S [unfold add] [rewrite ih]]]] + +[proof add-comm + [induction m + [Z [unfold add] [rewrite add-zero-right :rev]] + [S [unfold add] [rewrite ih] [rewrite add-succ-right :rev]]]] + +[proof add-assoc + [induction m + [Z] + [S [unfold add] [unfold add] [rewrite ih]]]] + +[proof mul-zero-right + [induction n + [Z] + [S [unfold mul] [rewrite ih]]]] + +[proof mul-succ-right + [induction m + [Z] + [S [unfold mul] [rewrite ih]]]] + +[proof mul-comm + [induction n + [Z [rewrite mul-zero-right]] + [S [rewrite mul-succ-right] [rewrite ih]]]] + +[proof mul-distrib-left + [induction m + [Z] + [S [unfold mul] [rewrite ih]]]] + +[proof mul-distrib-right + [induction a + [Z] + [S [unfold add] [unfold mul] [rewrite ih]]]] + +[proof mul-assoc + [induction m + [Z] + [S [unfold mul] [rewrite mul-distrib-right] [rewrite ih]]]] + +[proof gauss + [induction n + [Z] + [S [unfold sum] [rewrite mul-distrib-left] [rewrite ih]]]] + +[proof odds-square + [induction n + [Z] + [S [unfold odds] [rewrite ih]]]] From 4f83f8c7062a1f0311e1f6c44b4318354a144e3b Mon Sep 17 00:00:00 2001 From: Cam Pedersen Date: Wed, 28 Oct 2026 14:03:26 -0400 Subject: [PATCH 2/4] style: cargo fmt Co-Authored-By: Claude Fable 5.1 --- crates/loon-lang/src/check/mod.rs | 6 +- crates/loon-lang/src/check/termination.rs | 11 +- crates/loon-lang/src/errors/tutorials.rs | 3 +- crates/loon-lang/src/verify/bounded.rs | 161 ++++++++-- crates/loon-lang/src/verify/infer.rs | 52 +++- crates/loon-lang/src/verify/kernel.rs | 240 +++++++++++---- crates/loon-lang/src/verify/mod.rs | 238 +++++++++++---- crates/loon-lang/src/verify/tests.rs | 354 ++++++++++++++++++---- 8 files changed, 857 insertions(+), 208 deletions(-) diff --git a/crates/loon-lang/src/check/mod.rs b/crates/loon-lang/src/check/mod.rs index d14cfeb..4464e65 100644 --- a/crates/loon-lang/src/check/mod.rs +++ b/crates/loon-lang/src/check/mod.rs @@ -7652,7 +7652,11 @@ mod tests { [fn od [n] [if [= n 0] false [ev [- n 1]]]]", ); for f in ["collatz", "spin", "ev", "od"] { - assert!(!c.is_total(f), "{f} should be Div: {:?}", c.fn_effects.get(f)); + assert!( + !c.is_total(f), + "{f} should be Div: {:?}", + c.fn_effects.get(f) + ); } } diff --git a/crates/loon-lang/src/check/termination.rs b/crates/loon-lang/src/check/termination.rs index d1e4b88..5820bad 100644 --- a/crates/loon-lang/src/check/termination.rs +++ b/crates/loon-lang/src/check/termination.rs @@ -340,9 +340,10 @@ pub fn program_facts(exprs: &[Expr]) -> ProgramFacts { let mut defs: Vec<(String, &[Expr])> = Vec::new(); for e in exprs { if let ExprKind::List(items) = &e.kind { - if let (Some(ExprKind::Symbol(h)), Some(ExprKind::Symbol(n))) = - (items.first().map(|x| &x.kind), items.get(1).map(|x| &x.kind)) - { + if let (Some(ExprKind::Symbol(h)), Some(ExprKind::Symbol(n))) = ( + items.first().map(|x| &x.kind), + items.get(1).map(|x| &x.kind), + ) { if h == "fn" && items.len() >= 3 { defs.push((n.clone(), &items[2..])); } @@ -359,7 +360,9 @@ pub fn program_facts(exprs: &[Expr]) -> ProgramFacts { } edges.insert( n.clone(), - refs.into_iter().filter(|r| names.contains(r) && r != n).collect(), + refs.into_iter() + .filter(|r| names.contains(r) && r != n) + .collect(), ); } let reach = |from: &str| -> HashSet { diff --git a/crates/loon-lang/src/errors/tutorials.rs b/crates/loon-lang/src/errors/tutorials.rs index ae9c841..bcbbaf6 100644 --- a/crates/loon-lang/src/errors/tutorials.rs +++ b/crates/loon-lang/src/errors/tutorials.rs @@ -688,7 +688,8 @@ fn tutorial_may_diverge() -> Tutorial { }, TutorialStep::Try { prompt: "Write a total length function over a vector.".to_string(), - hint: "Try: [fn len [xs] [match xs #[] 0 #[_ & rest] [+ 1 [len rest]]]]".to_string(), + hint: "Try: [fn len [xs] [match xs #[] 0 #[_ & rest] [+ 1 [len rest]]]]" + .to_string(), expected_output: None, }, ], diff --git a/crates/loon-lang/src/verify/bounded.rs b/crates/loon-lang/src/verify/bounded.rs index 103acae..0cafd72 100644 --- a/crates/loon-lang/src/verify/bounded.rs +++ b/crates/loon-lang/src/verify/bounded.rs @@ -78,14 +78,26 @@ fn mangle_children(e: &mut Expr, defs: &Defs) { /// Infer each law parameter's kind by checking `[fn [params] #[lhs rhs]]` /// against the evaluation prelude. -pub fn param_kinds(prelude_src: &str, params: &[String], lhs: &Expr, rhs: &Expr, defs: &Defs) -> Vec { +pub fn param_kinds( + prelude_src: &str, + params: &[String], + lhs: &Expr, + rhs: &Expr, + defs: &Defs, +) -> Vec { // Prefer verify's own inference (generalizes top-level fns); fall back // to the language checker when it cannot type the law. if let Some(ts) = super::infer::law_param_types(defs, &defs.fn_order, params, lhs, rhs) { - return ts.iter().map(|t| kind_of(&super::infer::to_checker(t), defs)).collect(); + return ts + .iter() + .map(|t| kind_of(&super::infer::to_checker(t), defs)) + .collect(); } let Ok(prefix) = crate::parser::parse(prelude_src) else { - return params.iter().map(|_| Kind::Unsupported("prelude parse error".into())).collect(); + return params + .iter() + .map(|_| Kind::Unsupported("prelude parse error".into())) + .collect(); }; // Only the fns the law reaches: the checker does not generalize top-level // fns, so an unrelated use (`append` on instructions in `compile`) would @@ -96,7 +108,10 @@ pub fn param_kinds(prelude_src: &str, params: &[String], lhs: &Expr, rhs: &Expr, let lam = list(vec![ sym("fn"), list(params.iter().map(|p| sym(p)).collect()), - Expr::new(ExprKind::Vec(vec![mangle(lhs, defs), mangle(rhs, defs)]), Span::ZERO), + Expr::new( + ExprKind::Vec(vec![mangle(lhs, defs), mangle(rhs, defs)]), + Span::ZERO, + ), ]); // Round-trip through text so the checker sees fresh node ids and spans. let lam = crate::parser::parse(&format!("{lam}")) @@ -106,7 +121,10 @@ pub fn param_kinds(prelude_src: &str, params: &[String], lhs: &Expr, rhs: &Expr, let ty = checker.infer(&lam); let ty = checker.resolve(&ty); let Type::Fn(ps, _, _) = ty else { - return params.iter().map(|_| Kind::Unsupported("could not infer types".into())).collect(); + return params + .iter() + .map(|_| Kind::Unsupported("could not infer types".into())) + .collect(); }; let scrut: Vec> = params .iter() @@ -140,7 +158,12 @@ fn scrutinized_adts<'a>(scrut: &'a [Option], defs: &Defs) -> Vec<&'a Str let mut v: Vec<&String> = scrut .iter() .flatten() - .filter(|t| !matches!(kind_of(&Type::Con((*t).clone(), vec![]), defs), Kind::List(..))) + .filter(|t| { + !matches!( + kind_of(&Type::Con((*t).clone(), vec![]), defs), + Kind::List(..) + ) + }) .collect(); v.sort(); v @@ -148,9 +171,13 @@ fn scrutinized_adts<'a>(scrut: &'a [Option], defs: &Defs) -> Vec<&'a Str /// Does `p` appear as a direct argument of a reference fn application? fn fn_arg(p: &str, e: &Expr, defs: &Defs) -> bool { - let ExprKind::List(items) = &e.kind else { return false }; + let ExprKind::List(items) = &e.kind else { + return false; + }; if head_sym(e).is_some_and(|h| defs.fns.contains_key(h)) - && items[1..].iter().any(|a| matches!(&a.kind, ExprKind::Symbol(s) if s == p)) + && items[1..] + .iter() + .any(|a| matches!(&a.kind, ExprKind::Symbol(s) if s == p)) { return true; } @@ -199,7 +226,8 @@ fn scrutinized_type(p: &str, e: &Expr, defs: &Defs) -> Option { if let (Some(h), ExprKind::List(items)) = (head_sym(e), &e.kind) { if let Some(f) = defs.fns.get(h) { if let Some(i) = f.scrutinee { - if matches!(items.get(i + 1).map(|a| &a.kind), Some(ExprKind::Symbol(s)) if s == p) { + if matches!(items.get(i + 1).map(|a| &a.kind), Some(ExprKind::Symbol(s)) if s == p) + { if let ExprKind::List(m) = &f.body.kind { for pat in m[2..].iter().step_by(2) { let c = match &pat.kind { @@ -234,7 +262,9 @@ fn kind_of(t: &Type, defs: &Defs) -> Kind { Type::Fn(ps, r, _) if ps.len() == 1 && is_intish(&ps[0]) && is_intish(r) => Kind::Fn1, Type::Con(name, args) if defs.types.contains_key(name) => { if args.iter().any(|a| !is_intish(a)) { - let gs: Vec> = (0..=TYPED_MAX_SIZE).map(|n| typed_values(t, n, defs, 0)).collect(); + let gs: Vec> = (0..=TYPED_MAX_SIZE) + .map(|n| typed_values(t, n, defs, 0)) + .collect(); if gs.iter().all(|g| g.is_empty()) { return Kind::Unsupported(format!("{name} of non-Int elements")); } @@ -249,10 +279,15 @@ fn kind_of(t: &Type, defs: &Defs) -> Kind { (2, Some(n), Some(c)) => Kind::List(name.clone(), n.name.clone(), c.name.clone()), _ if nil.is_some() => Kind::Adt( name.clone(), - ctors.iter().map(|c| (c.name.clone(), c.recursive.clone())).collect(), + ctors + .iter() + .map(|c| (c.name.clone(), c.recursive.clone())) + .collect(), ), _ => { - let gs: Vec> = (0..=TYPED_MAX_SIZE).map(|n| typed_values(t, n, defs, 0)).collect(); + let gs: Vec> = (0..=TYPED_MAX_SIZE) + .map(|n| typed_values(t, n, defs, 0)) + .collect(); Kind::Typed(t.clone(), gs) } } @@ -272,8 +307,23 @@ pub fn typed_values(t: &Type, n: usize, defs: &Defs, depth: usize) -> Vec return vec![]; } match t { - Type::Int | Type::Var(_) => if n == 0 { ELEMS.iter().map(|e| super::kernel::int(*e)).collect() } else { vec![] }, - Type::Bool => if n == 0 { vec![Expr::new(ExprKind::Bool(false), Span::ZERO), Expr::new(ExprKind::Bool(true), Span::ZERO)] } else { vec![] }, + Type::Int | Type::Var(_) => { + if n == 0 { + ELEMS.iter().map(|e| super::kernel::int(*e)).collect() + } else { + vec![] + } + } + Type::Bool => { + if n == 0 { + vec![ + Expr::new(ExprKind::Bool(false), Span::ZERO), + Expr::new(ExprKind::Bool(true), Span::ZERO), + ] + } else { + vec![] + } + } Type::Con(name, args) if defs.types.contains_key(name) => { let params = defs.type_params.get(name).cloned().unwrap_or_default(); fn conv(f: &Expr, params: &[String], args: &[Type]) -> Option { @@ -287,7 +337,10 @@ pub fn typed_values(t: &Type, n: usize, defs: &Defs, depth: usize) -> Vec ExprKind::List(v) | ExprKind::Tuple(v) => match v.first().map(|e| &e.kind) { Some(ExprKind::Symbol(h)) => Some(Type::Con( h.clone(), - v[1..].iter().map(|a| conv(a, params, args)).collect::>>()?, + v[1..] + .iter() + .map(|a| conv(a, params, args)) + .collect::>>()?, )), _ => None, }, @@ -305,7 +358,12 @@ pub fn typed_values(t: &Type, n: usize, defs: &Defs, depth: usize) -> Vec if n == 0 { continue; } - let Some(ftys) = c.fields.iter().map(|f| conv(f, ¶ms, args)).collect::>>() else { + let Some(ftys) = c + .fields + .iter() + .map(|f| conv(f, ¶ms, args)) + .collect::>>() + else { continue; }; // Distribute n-1 over the fields, in field order. @@ -314,7 +372,11 @@ pub fn typed_values(t: &Type, n: usize, defs: &Defs, depth: usize) -> Vec let last = fi + 1 == ftys.len(); let mut next = Vec::new(); 'outer: for (vals, left) in &partial { - let sizes: Vec = if last { vec![*left] } else { (0..=*left).collect() }; + let sizes: Vec = if last { + vec![*left] + } else { + (0..=*left).collect() + }; for sz in sizes { for v in typed_values(ft, sz, defs, depth + 1) { let mut v2 = vals.clone(); @@ -385,7 +447,11 @@ fn groups(kind: &Kind, bound: usize, rng: &mut u64) -> Vec> { let mut nl = Vec::new(); for (c, left) in combos.iter().zip(&left_opts) { if *rec { - let sizes: Vec = if last_rec { vec![*left] } else { (1..=*left).collect() }; + let sizes: Vec = if last_rec { + vec![*left] + } else { + (1..=*left).collect() + }; for s in sizes { for v in by_size.get(s).into_iter().flatten() { let mut c2 = c.clone(); @@ -430,7 +496,11 @@ fn groups(kind: &Kind, bound: usize, rng: &mut u64) -> Vec> { out.push(vec![super::kernel::int(0)]); for k in 1..=bound as i64 { let r = (splitmix(rng) % 41) as i64 - 20; - out.push(vec![super::kernel::int(k), super::kernel::int(-k), super::kernel::int(r)]); + out.push(vec![ + super::kernel::int(k), + super::kernel::int(-k), + super::kernel::int(r), + ]); } } Kind::Bool => { @@ -480,7 +550,13 @@ fn inputs(kinds: &[Kind], bound: usize, seed: u64) -> Vec> { out } -fn compositions(gs: &[Vec>], left: usize, i: usize, sizes: &mut Vec, f: &mut dyn FnMut(&[usize])) { +fn compositions( + gs: &[Vec>], + left: usize, + i: usize, + sizes: &mut Vec, + f: &mut dyn FnMut(&[usize]), +) { if i == gs.len() { if left == 0 { f(sizes); @@ -493,7 +569,13 @@ fn compositions(gs: &[Vec>], left: usize, i: usize, sizes: &mut Vec>], sizes: &[usize], i: usize, cur: &mut Vec, out: &mut Vec>) { +fn product( + gs: &[Vec>], + sizes: &[usize], + i: usize, + cur: &mut Vec, + out: &mut Vec>, +) { if out.len() >= MAX_INPUTS { return; } @@ -520,7 +602,11 @@ pub fn check_law( bound: usize, seed: u64, ) -> Bounded { - if let Some((p, Kind::Unsupported(why))) = params.iter().zip(kinds).find(|(_, k)| matches!(k, Kind::Unsupported(_))) { + if let Some((p, Kind::Unsupported(why))) = params + .iter() + .zip(kinds) + .find(|(_, k)| matches!(k, Kind::Unsupported(_))) + { return Bounded { error: Some(format!("cannot generate `{p}`: {why}")), ..Default::default() @@ -537,7 +623,8 @@ pub fn check_law( let name = format!("__law-chunk-{ci}"); src.push_str(&format!("\n[fn {name} [] [str")); for input in chunk { - let m: HashMap = params.iter().cloned().zip(input.iter().cloned()).collect(); + let m: HashMap = + params.iter().cloned().zip(input.iter().cloned()).collect(); src.push_str(&format!( "\n {} \"|\" {} \"|\"", subst(&ml, &m, defs), @@ -553,7 +640,8 @@ pub fn check_law( } src.push_str("]]\n"); let run = || -> Result { - let mut sess = crate::eir::vm::Session::new(&src, std::path::Path::new("."), Default::default())?; + let mut sess = + crate::eir::vm::Session::new(&src, std::path::Path::new("."), Default::default())?; sess.start()?; Ok(sess.show(sess.value())) }; @@ -570,7 +658,11 @@ pub fn check_law( let lines = &lines[..lines.len().saturating_sub(1)]; if lines.len() != ins.len() * 2 { return Bounded { - error: Some(format!("expected {} values, got {}", ins.len() * 2, lines.len())), + error: Some(format!( + "expected {} values, got {}", + ins.len() * 2, + lines.len() + )), ..Default::default() }; } @@ -579,7 +671,11 @@ pub fn check_law( if l != r { return Bounded { checked: i + 1, - counterexample: Some((params.iter().cloned().zip(input.iter().cloned()).collect(), l.clone(), r.clone())), + counterexample: Some(( + params.iter().cloned().zip(input.iter().cloned()).collect(), + l.clone(), + r.clone(), + )), error: None, }; } @@ -597,7 +693,9 @@ pub fn to_json(e: &Expr, defs: &Defs) -> serde_json::Value { match &e.kind { ExprKind::Int(n) => J::from(*n), ExprKind::Bool(b) => J::Bool(*b), - ExprKind::Symbol(s) if defs.is_ctor(s) && is_nil(s, defs) && is_list_type(s, defs) => J::Array(vec![]), + ExprKind::Symbol(s) if defs.is_ctor(s) && is_nil(s, defs) && is_list_type(s, defs) => { + J::Array(vec![]) + } ExprKind::Vec(v) => J::Array(v.iter().map(|x| to_json(x, defs)).collect()), ExprKind::List(v) if v.len() == 3 && head_sym(e).is_some_and(|h| is_cons(h, defs)) => { let mut arr = vec![to_json(&v[1], defs)]; @@ -616,12 +714,17 @@ fn is_list_type(ctor: &str, defs: &Defs) -> bool { defs.types.values().any(|cs| { cs.iter().any(|c| c.name == ctor) && cs.len() == 2 - && cs.iter().any(|c| c.recursive.len() == 2 && !c.recursive[0] && c.recursive[1]) + && cs + .iter() + .any(|c| c.recursive.len() == 2 && !c.recursive[0] && c.recursive[1]) }) } fn is_nil(s: &str, defs: &Defs) -> bool { - defs.types.values().flatten().any(|c| c.name == s && c.recursive.is_empty()) + defs.types + .values() + .flatten() + .any(|c| c.name == s && c.recursive.is_empty()) } fn is_cons(s: &str, defs: &Defs) -> bool { diff --git a/crates/loon-lang/src/verify/infer.rs b/crates/loon-lang/src/verify/infer.rs index 1bb46f7..a8afd4b 100644 --- a/crates/loon-lang/src/verify/infer.rs +++ b/crates/loon-lang/src/verify/infer.rs @@ -92,7 +92,11 @@ impl Inf<'_> { let params = self.defs.type_params.get(&ty).cloned().unwrap_or_default(); let inst: Vec = params.iter().map(|_| self.fresh()).collect(); let info = self.defs.types[&ty].iter().find(|k| k.name == c)?.clone(); - let fields = info.fields.iter().map(|f| self.field(f, ¶ms, &inst)).collect::>>()?; + let fields = info + .fields + .iter() + .map(|f| self.field(f, ¶ms, &inst)) + .collect::>>()?; Some((fields, T::Con(ty, inst))) } @@ -103,8 +107,13 @@ impl Inf<'_> { None => T::Con(s.clone(), vec![]), }), ExprKind::List(v) | ExprKind::Tuple(v) => { - let Some(ExprKind::Symbol(h)) = v.first().map(|e| &e.kind) else { return None }; - let args = v[1..].iter().map(|a| self.field(a, params, inst)).collect::>>()?; + let Some(ExprKind::Symbol(h)) = v.first().map(|e| &e.kind) else { + return None; + }; + let args = v[1..] + .iter() + .map(|a| self.field(a, params, inst)) + .collect::>>()?; Some(T::Con(h.clone(), args)) } _ => None, @@ -142,7 +151,12 @@ impl Inf<'_> { } } - fn expr(&mut self, e: &Expr, env: &HashMap, current: Option<(&str, &T)>) -> Option { + fn expr( + &mut self, + e: &Expr, + env: &HashMap, + current: Option<(&str, &T)>, + ) -> Option { let int = T::Con("Int".into(), vec![]); match &e.kind { ExprKind::Int(_) => Some(int), @@ -179,14 +193,18 @@ impl Inf<'_> { Some(out) } Some("fn") => { - let ExprKind::List(ps) = &items.get(1)?.kind else { return None }; + let ExprKind::List(ps) = &items.get(1)?.kind else { + return None; + }; if items.len() != 3 { return None; } let mut inner = env.clone(); let mut pts = Vec::new(); for p in ps { - let ExprKind::Symbol(s) = &p.kind else { return None }; + let ExprKind::Symbol(s) = &p.kind else { + return None; + }; let t = self.fresh(); inner.insert(s.clone(), t.clone()); pts.push(t); @@ -249,10 +267,22 @@ impl Inf<'_> { /// Infer the types of `params` in the law `lhs = rhs`. `fn_order` lists the /// reference fns in definition order. `None` if anything fails to type. -pub fn law_param_types(defs: &Defs, fn_order: &[String], params: &[String], lhs: &Expr, rhs: &Expr) -> Option> { - let mut inf = Inf { defs, subst: Vec::new(), schemes: HashMap::new() }; +pub fn law_param_types( + defs: &Defs, + fn_order: &[String], + params: &[String], + lhs: &Expr, + rhs: &Expr, +) -> Option> { + let mut inf = Inf { + defs, + subst: Vec::new(), + schemes: HashMap::new(), + }; for name in fn_order { - let Some(f) = defs.fns.get(name) else { continue }; + let Some(f) = defs.fns.get(name) else { + continue; + }; let mut env = HashMap::new(); let mut pts = Vec::new(); for p in &f.params { @@ -263,7 +293,9 @@ pub fn law_param_types(defs: &Defs, fn_order: &[String], params: &[String], lhs: let r = inf.fresh(); pts.push(r.clone()); let ft = T::Con(ARROW.into(), pts); - let Some(bt) = inf.expr(&f.body, &env, Some((name, &ft))) else { continue }; + let Some(bt) = inf.expr(&f.body, &env, Some((name, &ft))) else { + continue; + }; if inf.unify(&bt, &r).is_none() { continue; } diff --git a/crates/loon-lang/src/verify/kernel.rs b/crates/loon-lang/src/verify/kernel.rs index 60c448d..41890ec 100644 --- a/crates/loon-lang/src/verify/kernel.rs +++ b/crates/loon-lang/src/verify/kernel.rs @@ -56,8 +56,7 @@ pub fn term_eq(a: &Expr, b: &Expr) -> bool { } (Map(x), Map(y)) => { x.len() == y.len() - && x - .iter() + && x.iter() .zip(y) .all(|((k1, v1), (k2, v2))| term_eq(k1, k2) && term_eq(v1, v2)) } @@ -144,7 +143,11 @@ pub fn pattern_vars(p: &Expr, defs: &Defs, out: &mut Vec) { fn fn_binders(items: &[Expr]) -> Option<(usize, Vec)> { let idx = match items.get(1).map(|e| &e.kind) { Some(ExprKind::List(_)) => 1, - Some(ExprKind::Symbol(_)) if matches!(items.get(2).map(|e| &e.kind), Some(ExprKind::List(_))) => 2, + Some(ExprKind::Symbol(_)) + if matches!(items.get(2).map(|e| &e.kind), Some(ExprKind::List(_))) => + { + 2 + } _ => return None, }; let ExprKind::List(ps) = &items[idx].kind else { @@ -386,7 +389,11 @@ fn normalize_plus(e: &Expr) -> Option { let mut acc = terms.pop()?; while let Some(t) = terms.pop() { acc = Expr::new( - ExprKind::List(vec![Expr::new(ExprKind::Symbol("+".into()), e.span), t, acc]), + ExprKind::List(vec![ + Expr::new(ExprKind::Symbol("+".into()), e.span), + t, + acc, + ]), e.span, ); } @@ -416,7 +423,9 @@ fn normalize_ac(e: &Expr, defs: &Defs) -> Option { return normalize_plus(e); } let ac = defs.ac.iter().find(|a| a.op == h)?; - let ExprKind::List(items) = &e.kind else { return None }; + let ExprKind::List(items) = &e.kind else { + return None; + }; if items.len() != 3 { return None; } @@ -457,12 +466,7 @@ fn instantiate(f: &FnDef, args: &[Expr], defs: &Defs, used: &mut HashSet symbols(a, used); } let body = freshen_binders(&f.body, defs, used); - let map: HashMap = f - .params - .iter() - .cloned() - .zip(args.iter().cloned()) - .collect(); + let map: HashMap = f.params.iter().cloned().zip(args.iter().cloned()).collect(); subst(&body, &map, defs) } @@ -506,9 +510,14 @@ pub fn eval_normalize(e: &Expr, defs: &Defs, used: &mut HashSet, fuel: & return e; } if let Some(name) = head_sym(&e) { - if defs.total.contains(name) && defs.fns[name].scrutinee.is_some() && is_redex(&e, name, defs) { + if defs.total.contains(name) + && defs.fns[name].scrutinee.is_some() + && is_redex(&e, name, defs) + { *fuel -= 1; - let ExprKind::List(items) = &e.kind else { unreachable!() }; + let ExprKind::List(items) = &e.kind else { + unreachable!() + }; let r = instantiate(&defs.fns[name], &items[1..], defs, used); return eval_normalize(&r, defs, used, fuel); } @@ -530,7 +539,12 @@ pub fn total_fns(defs: &Defs) -> HashSet { total } -fn check_total(name: &str, defs: &Defs, state: &mut HashMap, total: &mut HashSet) -> bool { +fn check_total( + name: &str, + defs: &Defs, + state: &mut HashMap, + total: &mut HashSet, +) -> bool { match state.get(name) { Some(2) => return total.contains(name), Some(1) => return false, // mutual recursion @@ -567,10 +581,9 @@ fn structural(f: &FnDef, name: &str, defs: &Defs) -> bool { // Some fixed parameter index i such that every self-call's i-th arg is a // strict subterm of parameter i. (0..f.params.len()).any(|i| { - calls.iter().all(|args| { - args.len() == f.params.len() - && matches!(&args[i], Some(p) if *p == i) - }) + calls + .iter() + .all(|args| args.len() == f.params.len() && matches!(&args[i], Some(p) if *p == i)) }) } @@ -598,14 +611,20 @@ fn collect_self_calls( }) .collect(), ); - items[1..].iter().all(|a| collect_self_calls(a, name, env, defs, calls)) + items[1..] + .iter() + .all(|a| collect_self_calls(a, name, env, defs, calls)) } ExprKind::List(items) if head_sym(e) == Some("match") && items.len() >= 2 => { if !collect_self_calls(&items[1], name, env, defs, calls) { return false; } let scrut_param = match &items[1].kind { - ExprKind::Symbol(s) => f.params.iter().position(|p| p == s).filter(|_| !env.contains_key(s)), + ExprKind::Symbol(s) => f + .params + .iter() + .position(|p| p == s) + .filter(|_| !env.contains_key(s)), _ => None, }; // A scrutinee that is itself a tracked subterm stays tracked. @@ -643,12 +662,19 @@ fn collect_self_calls( if let Some(b) = items.get(1) { symbols(b, &mut bs); } - if bs.iter().any(|b| f.params.contains(b) || env.contains_key(b)) { + if bs + .iter() + .any(|b| f.params.contains(b) || env.contains_key(b)) + { return false; } - items.iter().all(|c| collect_self_calls(c, name, env, defs, calls)) + items + .iter() + .all(|c| collect_self_calls(c, name, env, defs, calls)) } - _ => children(e).into_iter().all(|c| collect_self_calls(c, name, env, defs, calls)), + _ => children(e) + .into_iter() + .all(|c| collect_self_calls(c, name, env, defs, calls)), } } @@ -665,13 +691,21 @@ pub struct Rule { /// First-order matching. At an application of an active user AC operator /// the two operands are also tried swapped (matching modulo commutativity), /// since a pattern's variables sort by name rather than by what they bind. -fn match_term(pat: &Expr, t: &Expr, vars: &[String], b: &mut HashMap, defs: &Defs) -> bool { +fn match_term( + pat: &Expr, + t: &Expr, + vars: &[String], + b: &mut HashMap, + defs: &Defs, +) -> bool { let saved = b.clone(); if match_plain(pat, t, vars, b, defs) { return true; } *b = saved; - let (ExprKind::List(ps), ExprKind::List(ts)) = (&pat.kind, &t.kind) else { return false }; + let (ExprKind::List(ps), ExprKind::List(ts)) = (&pat.kind, &t.kind) else { + return false; + }; let is_ac = |e: &Expr| head_sym(e).is_some_and(|h| defs.ac.iter().any(|a| a.op == h)); if ps.len() != 3 || ts.len() != 3 || !is_ac(pat) || head_sym(pat) != head_sym(t) { return false; @@ -684,7 +718,13 @@ fn match_term(pat: &Expr, t: &Expr, vars: &[String], b: &mut HashMap, defs: &Defs) -> bool { +fn match_plain( + pat: &Expr, + t: &Expr, + vars: &[String], + b: &mut HashMap, + defs: &Defs, +) -> bool { if let ExprKind::Symbol(s) = &pat.kind { if vars.contains(s) { if let Some(prev) = b.get(s) { @@ -707,12 +747,20 @@ fn match_plain(pat: &Expr, t: &Expr, vars: &[String], b: &mut HashMap Option { +fn rewrite_nth( + t: &Expr, + rule: &Rule, + target: usize, + seen: &mut usize, + defs: &Defs, +) -> Option { let mut b = HashMap::new(); if match_term(&rule.lhs, t, &rule.params, &mut b, defs) { if *seen == target { @@ -754,26 +802,45 @@ pub fn rewrite(t: &Expr, rule: &Rule, at: usize, defs: &Defs) -> Result) -> Result { +pub fn unfold( + t: &Expr, + name: &str, + defs: &Defs, + used: &mut HashSet, +) -> Result { let f = defs .fns .get(name) .ok_or_else(|| format!("`{name}` is not defined in defs.oo"))?; if !defs.total.contains(name) { - return Err(format!("`{name}` is not structurally recursive; cannot unfold")); + return Err(format!( + "`{name}` is not structurally recursive; cannot unfold" + )); } let arity = f.params.len(); - let is_app = |e: &Expr| matches!(&e.kind, ExprKind::List(v) if v.len() == arity + 1) && head_sym(e) == Some(name); + let is_app = |e: &Expr| { + matches!(&e.kind, ExprKind::List(v) if v.len() == arity + 1) && head_sym(e) == Some(name) + }; for pred in [true, false] { let mut done = false; - let out = replace_first(t, &mut |e| { - let hit = if pred { is_redex(e, name, defs) } else { is_app(e) }; - if !hit { - return None; - } - let ExprKind::List(items) = &e.kind else { return None }; - Some(instantiate(f, &items[1..], defs, used)) - }, &mut done); + let out = replace_first( + t, + &mut |e| { + let hit = if pred { + is_redex(e, name, defs) + } else { + is_app(e) + }; + if !hit { + return None; + } + let ExprKind::List(items) = &e.kind else { + return None; + }; + Some(instantiate(f, &items[1..], defs, used)) + }, + &mut done, + ); if done { return Ok(out); } @@ -798,7 +865,11 @@ fn replace_first(t: &Expr, f: &mut dyn FnMut(&Expr) -> Option, done: &mut pub enum Outcome { Proven, Admitted, - Stuck { case: String, term: String, reason: String }, + Stuck { + case: String, + term: String, + reason: String, + }, } /// A type as far as the kernel needs it: a head name plus argument types. @@ -812,11 +883,17 @@ pub struct Ty { impl Ty { pub fn named(n: &str) -> Ty { - Ty { name: n.to_string(), args: vec![] } + Ty { + name: n.to_string(), + args: vec![], + } } pub fn app(n: &str, args: Vec) -> Ty { - Ty { name: n.to_string(), args } + Ty { + name: n.to_string(), + args, + } } pub fn unknown() -> Ty { @@ -838,7 +915,10 @@ pub fn field_tys(defs: &Defs, ty: &Ty, fields: &[Expr]) -> Vec> { let Some(ExprKind::Symbol(h)) = v.first().map(|e| &e.kind) else { return None; }; - let args = v[1..].iter().map(|a| conv(a, params, ty).unwrap_or_else(Ty::unknown)).collect(); + let args = v[1..] + .iter() + .map(|a| conv(a, params, ty).unwrap_or_else(Ty::unknown)) + .collect(); Some(Ty::app(h, args)) } _ => None, @@ -853,7 +933,9 @@ pub fn field_tys(defs: &Defs, ty: &Ty, fields: &[Expr]) -> Vec> { fn is_self_field(f: &Expr, name: &str) -> bool { match &f.kind { ExprKind::Symbol(s) => s == name, - ExprKind::List(v) | ExprKind::Tuple(v) => matches!(v.first().map(|e| &e.kind), Some(ExprKind::Symbol(h)) if h == name), + ExprKind::List(v) | ExprKind::Tuple(v) => { + matches!(v.first().map(|e| &e.kind), Some(ExprKind::Symbol(h)) if h == name) + } _ => false, } } @@ -891,7 +973,11 @@ struct State { } pub fn check_proof(goal: &Goal, steps: &[Expr], defs: &Defs, lemmas: &Lemmas) -> Outcome { - let mut ctx = Ctx { defs, lemmas, admitted: false }; + let mut ctx = Ctx { + defs, + lemmas, + admitted: false, + }; let st = State { l: normalize(goal.lhs, defs), r: normalize(goal.rhs, defs), @@ -997,7 +1083,12 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome _ => return Err(stuck(&st, "`:at` needs a non-negative integer")), } } - _ => return Err(stuck(&st, format!("unknown rewrite option `{}`", items[j]))), + _ => { + return Err(stuck( + &st, + format!("unknown rewrite option `{}`", items[j]), + )) + } } j += 1; } @@ -1011,11 +1102,22 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome rule }; // Rules are matched in the same canonical form as the goal. - let (lhs, rhs) = (normalize(&rule.lhs, ctx.defs), normalize(&rule.rhs, ctx.defs)); + let (lhs, rhs) = ( + normalize(&rule.lhs, ctx.defs), + normalize(&rule.rhs, ctx.defs), + ); let rule = if rev { - Rule { params: rule.params, lhs: rhs, rhs: lhs } + Rule { + params: rule.params, + lhs: rhs, + rhs: lhs, + } } else { - Rule { params: rule.params, lhs, rhs } + Rule { + params: rule.params, + lhs, + rhs, + } }; st.l = rewrite(&st.l, &rule, at, ctx.defs) .map(|l| normalize(&l, ctx.defs)) @@ -1033,7 +1135,10 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome } "induction" | "cases" => { if i + 1 != steps.len() { - return Err(stuck(&st, format!("steps after `{op}` are not allowed; put them in its cases"))); + return Err(stuck( + &st, + format!("steps after `{op}` are not allowed; put them in its cases"), + )); } return split(ctx, st, items, op == "induction"); } @@ -1053,13 +1158,19 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() }; let var = var.clone(); if induction && !st.params.contains(&var) { - return Err(stuck(&st, format!("`{var}` is not a law parameter of this goal"))); + return Err(stuck( + &st, + format!("`{var}` is not a law parameter of this goal"), + )); } let Some(ty) = st.types.get(&var).cloned() else { return Err(stuck(&st, format!("type of `{var}` is not a known ADT"))); }; let Some(ctors) = ctx.defs.types.get(&ty.name) else { - return Err(stuck(&st, format!("`{}` is not an ADT declared in defs.oo", ty.name))); + return Err(stuck( + &st, + format!("`{}` is not an ADT declared in defs.oo", ty.name), + )); }; let ty_name = ty.name.clone(); if induction { @@ -1070,7 +1181,10 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() .iter() .find(|s| ctx.defs.fns.contains_key(s.as_str()) && !ctx.defs.total.contains(s.as_str())) { - return Err(stuck(&st, format!("induction needs total functions; `{bad}` is not structurally recursive"))); + return Err(stuck( + &st, + format!("induction needs total functions; `{bad}` is not structurally recursive"), + )); } } let cases: Vec<&Expr> = items[2..].iter().collect(); @@ -1086,7 +1200,10 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() // Fields that are structural subterms of the same ADT. let mut rec_fields = Vec::new(); for (k, rec) in ctor.recursive.iter().enumerate() { - let is_self = ctor.fields.get(k).is_some_and(|f| is_self_field(f, &ty_name)); + let is_self = ctor + .fields + .get(k) + .is_some_and(|f| is_self_field(f, &ty_name)); let base = if *rec { "rest" } else { "x" }; let n = fresh_name(base, &mut used); if let Some(Some(t)) = ftys.get(k) { @@ -1147,12 +1264,18 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() params, types, ihs, - case: if st.case == "root" { ctor.name.clone() } else { format!("{}/{}", st.case, ctor.name) }, + case: if st.case == "root" { + ctor.name.clone() + } else { + format!("{}/{}", st.case, ctor.name) + }, }; let Some(case) = case else { return Err(stuck(&child, format!("missing case {}", ctor.name))); }; - let ExprKind::List(cs) = &case.kind else { unreachable!() }; + let ExprKind::List(cs) = &case.kind else { + unreachable!() + }; run_steps(ctx, child, &cs[1..])?; } if let Some(extra) = cases.iter().find(|c| { @@ -1160,7 +1283,10 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() .iter() .any(|k| head_sym(c).is_some_and(|h| h.eq_ignore_ascii_case(&k.name))) }) { - return Err(stuck(&st, format!("case `{extra}` is not a constructor of {ty_name}"))); + return Err(stuck( + &st, + format!("case `{extra}` is not a constructor of {ty_name}"), + )); } Ok(()) } diff --git a/crates/loon-lang/src/verify/mod.rs b/crates/loon-lang/src/verify/mod.rs index b34ad96..04948e4 100644 --- a/crates/loon-lang/src/verify/mod.rs +++ b/crates/loon-lang/src/verify/mod.rs @@ -79,7 +79,9 @@ impl Defs { pub fn from_exprs(exprs: &[Expr]) -> Result { let mut d = Defs::default(); for e in exprs { - let ExprKind::List(items) = &e.kind else { continue }; + let ExprKind::List(items) = &e.kind else { + continue; + }; match head_sym(e) { Some("type") => d.add_type(items)?, Some("fn") => d.add_fn(items)?, @@ -116,7 +118,11 @@ impl Defs { match &it.kind { // A bare symbol used in some field is a type param, else a nullary ctor. ExprKind::Symbol(s) if fields_syms.contains(s) => {} - ExprKind::Symbol(s) => ctors.push(CtorInfo { name: s.clone(), recursive: vec![], fields: vec![] }), + ExprKind::Symbol(s) => ctors.push(CtorInfo { + name: s.clone(), + recursive: vec![], + fields: vec![], + }), ExprKind::List(v) => { let Some(ExprKind::Symbol(c)) = v.first().map(|e| &e.kind) else { return Err(format!("type {name}: malformed constructor `{it}`")); @@ -129,7 +135,11 @@ impl Defs { s.contains(name) }) .collect(); - ctors.push(CtorInfo { name: c.clone(), recursive, fields: v[1..].to_vec() }); + ctors.push(CtorInfo { + name: c.clone(), + recursive, + fields: v[1..].to_vec(), + }); } _ => return Err(format!("type {name}: unexpected `{it}`")), } @@ -149,7 +159,9 @@ impl Defs { return Ok(()); // anonymous or multi-clause: not unfoldable }; if items.len() != 4 { - return Err(format!("fn {name}: reference definitions must have a single body expression")); + return Err(format!( + "fn {name}: reference definitions must have a single body expression" + )); } let params: Vec = ps .iter() @@ -160,13 +172,22 @@ impl Defs { .collect::>()?; let body = items[3].clone(); let scrutinee = match &body.kind { - ExprKind::List(v) if head_sym(&body) == Some("match") && v.len() >= 2 => match &v[1].kind { - ExprKind::Symbol(s) => params.iter().position(|p| p == s), - _ => None, - }, + ExprKind::List(v) if head_sym(&body) == Some("match") && v.len() >= 2 => { + match &v[1].kind { + ExprKind::Symbol(s) => params.iter().position(|p| p == s), + _ => None, + } + } _ => None, }; - self.fns.insert(name.clone(), FnDef { params, body, scrutinee }); + self.fns.insert( + name.clone(), + FnDef { + params, + body, + scrutinee, + }, + ); self.fn_order.push(name.clone()); Ok(()) } @@ -193,7 +214,9 @@ pub struct Law { /// Parse `[law NAME [PARAMS...] [= LHS RHS]]`. pub fn parse_law(e: &Expr, origin: Origin, file: &str) -> Option> { - let ExprKind::List(items) = &e.kind else { return None }; + let ExprKind::List(items) = &e.kind else { + return None; + }; if head_sym(e) != Some("law") { return None; } @@ -232,7 +255,9 @@ pub fn parse_law(e: &Expr, origin: Origin, file: &str) -> Option) { for s in steps { - let ExprKind::List(items) = &s.kind else { continue }; + let ExprKind::List(items) = &s.kind else { + continue; + }; match head_sym(s) { Some("rewrite") => { if let Some(ExprKind::Symbol(n)) = items.get(1).map(|e| &e.kind) { @@ -281,7 +306,9 @@ const META: [&str; 3] = ["\0a", "\0b", "\0c"]; fn alpha_match(pat: &Expr, t: &Expr, params: &[String], b: &mut HashMap) -> bool { if let ExprKind::Symbol(m) = &pat.kind { if META.contains(&m.as_str()) { - let ExprKind::Symbol(s) = &t.kind else { return false }; + let ExprKind::Symbol(s) = &t.kind else { + return false; + }; if !params.contains(s) { return false; } @@ -307,16 +334,20 @@ fn alpha_match(pat: &Expr, t: &Expr, params: &[String], b: &mut HashMap bool { shapes.iter().any(|(l, r)| { - [(&law.lhs, &law.rhs), (&law.rhs, &law.lhs)].iter().any(|(x, y)| { - let mut b = HashMap::new(); - alpha_match(l, x, &law.params, &mut b) && alpha_match(r, y, &law.params, &mut b) - }) + [(&law.lhs, &law.rhs), (&law.rhs, &law.lhs)] + .iter() + .any(|(x, y)| { + let mut b = HashMap::new(); + alpha_match(l, x, &law.params, &mut b) && alpha_match(r, y, &law.params, &mut b) + }) }) } pub fn parse_ac(e: &Expr, laws: &[Law], defs: &Defs) -> Result { use kernel::{list, sym}; - let ExprKind::List(items) = &e.kind else { unreachable!() }; + let ExprKind::List(items) = &e.kind else { + unreachable!() + }; let names: Vec> = items .iter() .map(|x| match &x.kind { @@ -324,8 +355,11 @@ pub fn parse_ac(e: &Expr, laws: &[Law], defs: &Defs) -> Result { _ => None, }) .collect(); - let bad = || format!("malformed `{e}`; expected [ac OP ASSOC-LAW COMM-LAW] or [ac OP ASSOC-LAW COMM-LAW :unit UNIT UNIT-LAW]"); - let with_unit = items.len() == 7 && matches!(&items[4].kind, ExprKind::Keyword(k) if k == "unit"); + let bad = || { + format!("malformed `{e}`; expected [ac OP ASSOC-LAW COMM-LAW] or [ac OP ASSOC-LAW COMM-LAW :unit UNIT UNIT-LAW]") + }; + let with_unit = + items.len() == 7 && matches!(&items[4].kind, ExprKind::Keyword(k) if k == "unit"); if !(items.len() == 4 || with_unit) { return Err(bad()); } @@ -333,7 +367,9 @@ pub fn parse_ac(e: &Expr, laws: &[Law], defs: &Defs) -> Result { return Err(bad()); }; if defs.fns.get(op).map(|f| f.params.len()) != Some(2) { - return Err(format!("ac {op}: `{op}` is not a two-argument fn of defs.oo")); + return Err(format!( + "ac {op}: `{op}` is not a two-argument fn of defs.oo" + )); } let law = |n: &str| { laws.iter() @@ -342,34 +378,60 @@ pub fn parse_ac(e: &Expr, laws: &[Law], defs: &Defs) -> Result { }; let app = |a: Expr, b: Expr| list(vec![sym(op), a, b]); let [a, b, c] = META.map(sym); - let assoc_shape = (app(app(a.clone(), b.clone()), c.clone()), app(a.clone(), app(b.clone(), c))); + let assoc_shape = ( + app(app(a.clone(), b.clone()), c.clone()), + app(a.clone(), app(b.clone(), c)), + ); if !law_has_shape(law(assoc)?, &[assoc_shape]) { - return Err(format!("ac {op}: `{assoc}` is not [= [{op} [{op} a b] c] [{op} a [{op} b c]]]")); + return Err(format!( + "ac {op}: `{assoc}` is not [= [{op} [{op} a b] c] [{op} a [{op} b c]]]" + )); } let comm_shape = (app(a.clone(), b.clone()), app(b, a.clone())); if !law_has_shape(law(comm)?, &[comm_shape]) { - return Err(format!("ac {op}: `{comm}` is not [= [{op} a b] [{op} b a]]")); + return Err(format!( + "ac {op}: `{comm}` is not [= [{op} a b] [{op} b a]]" + )); } let (mut unit, mut unit_law) = (None, None); if with_unit { let u = items[5].clone(); let ok = match &u.kind { ExprKind::Int(_) => true, - ExprKind::Symbol(s) => defs.types.values().flatten().any(|k| &k.name == s && k.fields.is_empty()), + ExprKind::Symbol(s) => defs + .types + .values() + .flatten() + .any(|k| &k.name == s && k.fields.is_empty()), _ => false, }; if !ok { - return Err(format!("ac {op}: unit `{u}` is not a nullary constructor or literal")); + return Err(format!( + "ac {op}: unit `{u}` is not a nullary constructor or literal" + )); } - let Some(ul) = names[6] else { return Err(bad()) }; - let shapes = [(app(a.clone(), u.clone()), a.clone()), (app(u.clone(), a.clone()), a.clone())]; + let Some(ul) = names[6] else { + return Err(bad()); + }; + let shapes = [ + (app(a.clone(), u.clone()), a.clone()), + (app(u.clone(), a.clone()), a.clone()), + ]; if !law_has_shape(law(ul)?, &shapes) { - return Err(format!("ac {op}: `{ul}` is not [= [{op} n {u}] n] or [= [{op} {u} n] n]")); + return Err(format!( + "ac {op}: `{ul}` is not [= [{op} n {u}] n] or [= [{op} {u} n] n]" + )); } unit = Some(u); unit_law = Some(ul.to_string()); } - Ok(AcDecl { op: op.into(), assoc: assoc.into(), comm: comm.into(), unit, unit_law }) + Ok(AcDecl { + op: op.into(), + assoc: assoc.into(), + comm: comm.into(), + unit, + unit_law, + }) } /// `op` plus every fn of defs.oo whose body transitively mentions it: a goal @@ -405,7 +467,10 @@ pub struct Options { impl Default for Options { fn default() -> Self { - Options { bound: 6, seed: 0x5EED } + Options { + bound: 6, + seed: 0x5EED, + } } } @@ -435,7 +500,8 @@ fn read_forms(path: &Path, required: bool) -> Result, String> { Err(_) if !required => return Ok(vec![]), Err(e) => return Err(format!("{}: {e}", path.display())), }; - crate::parser::parse(&src).map_err(|e| format!("{}: parse error: {}", path.display(), e.message)) + crate::parser::parse(&src) + .map_err(|e| format!("{}: parse error: {}", path.display(), e.message)) } fn oo_files(dir: &Path) -> Vec { @@ -553,7 +619,9 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { for path in oo_files(&dir.join("proofs")) { let file = path.display().to_string(); for e in read_forms(&path, true)? { - let ExprKind::List(items) = &e.kind else { continue }; + let ExprKind::List(items) = &e.kind else { + continue; + }; if head_sym(&e) != Some("proof") { continue; } @@ -563,10 +631,12 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { }; match laws.iter().find(|l| &l.name == name) { None => errors.push(format!("{file}: proof for unknown law `{name}`")), - Some(l) if l.origin == Origin::Builtins => { - errors.push(format!("{file}: `{name}` is a bridge law; bridge laws are bounded-only")) + Some(l) if l.origin == Origin::Builtins => errors.push(format!( + "{file}: `{name}` is a bridge law; bridge laws are bounded-only" + )), + Some(_) if proofs.contains_key(name) => { + errors.push(format!("{file}: duplicate proof `{name}`")) } - Some(_) if proofs.contains_key(name) => errors.push(format!("{file}: duplicate proof `{name}`")), Some(_) => { proofs.insert(name.clone(), items[2..].to_vec()); } @@ -608,16 +678,23 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { let mut param_types: HashMap> = HashMap::new(); for law in &laws { let kinds = bounded::param_kinds(&prelude, &law.params, &law.lhs, &law.rhs, &defs); - let inferred = infer::law_param_types(&defs, &defs.fn_order, &law.params, &law.lhs, &law.rhs); + let inferred = + infer::law_param_types(&defs, &defs.fn_order, &law.params, &law.lhs, &law.rhs); let types = law .params .iter() .zip(&kinds) .filter_map(|(p, k)| match k { - bounded::Kind::List(t, _, _) => Some((p.clone(), kernel::Ty::app(t, vec![kernel::Ty::named("Int")]))), + bounded::Kind::List(t, _, _) => Some(( + p.clone(), + kernel::Ty::app(t, vec![kernel::Ty::named("Int")]), + )), bounded::Kind::Adt(t, _) => { let n = defs.type_params.get(t).map_or(0, |v| v.len()); - Some((p.clone(), kernel::Ty::app(t, vec![kernel::Ty::named("Int"); n]))) + Some(( + p.clone(), + kernel::Ty::app(t, vec![kernel::Ty::named("Int"); n]), + )) } bounded::Kind::Typed(t, _) => Some((p.clone(), checker_ty(t))), _ => None, @@ -634,7 +711,16 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { None => types, }; param_types.insert(law.name.clone(), types); - let b = bounded::check_law(&prelude, &law.params, &kinds, &law.lhs, &law.rhs, &defs, opts.bound, opts.seed); + let b = bounded::check_law( + &prelude, + &law.params, + &kinds, + &law.lhs, + &law.rhs, + &defs, + opts.bound, + opts.seed, + ); let status = match (&b.counterexample, law.origin) { (Some(_), _) => "falsified", (None, Origin::Builtins) if b.error.is_none() => "bounded", @@ -673,10 +759,17 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { } } let reach = reaching(&d.op, &defs); - let names: Vec = proofs.keys().filter(|n| !excl.contains(*n)).cloned().collect(); + let names: Vec = proofs + .keys() + .filter(|n| !excl.contains(*n)) + .cloned() + .collect(); for n in names { let mut syms = HashSet::new(); - for l in laws.iter().filter(|l| l.name == n || deps[&n].contains(&l.name)) { + for l in laws + .iter() + .filter(|l| l.name == n || deps[&n].contains(&l.name)) + { kernel::symbols(&l.lhs, &mut syms); kernel::symbols(&l.rhs, &mut syms); } @@ -725,7 +818,14 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { names.sort_by_key(|n| laws.iter().position(|l| &l.name == *n)); for n in names { if !state.contains_key(n.as_str()) { - dfs(n, &deps, &mut state, &mut Vec::new(), &mut cyclic, &mut order); + dfs( + n, + &deps, + &mut state, + &mut Vec::new(), + &mut cyclic, + &mut order, + ); } } @@ -754,7 +854,14 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { Outcome::Stuck { .. } => return None, }; let l = laws.iter().find(|l| l.name == cite)?; - Some((Rule { params: l.params.clone(), lhs: l.lhs.clone(), rhs: l.rhs.clone() }, adm)) + Some(( + Rule { + params: l.params.clone(), + lhs: l.lhs.clone(), + rhs: l.rhs.clone(), + }, + adm, + )) }; let goal = kernel::Goal { law_name: name, @@ -770,9 +877,15 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { for &i in ac_for.get(name).into_iter().flatten() { let d = &ac_decls[i]; let st: Vec> = d.laws().iter().map(|l| outcome.get(l)).collect(); - if st.iter().all(|o| matches!(o, Some(Outcome::Proven | Outcome::Admitted))) { + if st + .iter() + .all(|o| matches!(o, Some(Outcome::Proven | Outcome::Admitted))) + { ac_tainted |= st.iter().any(|o| matches!(o, Some(Outcome::Admitted))); - pdefs.ac.push(AcOp { op: d.op.clone(), unit: d.unit.clone() }); + pdefs.ac.push(AcOp { + op: d.op.clone(), + unit: d.unit.clone(), + }); } } let o = match kernel::check_proof(&goal, &proofs[name], &pdefs, &lemmas) { @@ -800,13 +913,24 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { rep.stuck = Some((case.clone(), term.clone(), reason.clone())); } (None, Origin::Laws) if rep.status == "unknown" && !proofs.contains_key(&rep.name) => { - rep.note = Some(rep.note.take().map_or("no proof".into(), |n| format!("no proof; {n}"))); + rep.note = Some( + rep.note + .take() + .map_or("no proof".into(), |n| format!("no proof; {n}")), + ); } _ => {} } } - Ok(Report { run: now_rfc3339(), defs_hash, sound, laws: reports, errors, defs }) + Ok(Report { + run: now_rfc3339(), + defs_hash, + sound, + laws: reports, + errors, + defs, + }) } // ─── Reporting ───────────────────────────────────────────────────────────── @@ -852,7 +976,10 @@ impl Report { m.insert("rhs".into(), bounded::value_json(rv, &self.defs)); } if let Some((case, term, reason)) = &l.stuck { - m.insert("stuck".into(), json!({ "case": case, "term": term, "reason": reason })); + m.insert( + "stuck".into(), + json!({ "case": case, "term": term, "reason": reason }), + ); } if l.checked > 0 { m.insert("inputs".into(), J::from(l.checked)); @@ -881,7 +1008,11 @@ impl Report { pub fn to_text(&self) -> String { let mut s = String::new(); - for (title, origin) in [("laws", Origin::Laws), ("bridge (bounded only)", Origin::Builtins), ("canary", Origin::Canary)] { + for (title, origin) in [ + ("laws", Origin::Laws), + ("bridge (bounded only)", Origin::Builtins), + ("canary", Origin::Canary), + ] { let ls: Vec<_> = self.laws.iter().filter(|l| l.origin == origin).collect(); if ls.is_empty() { continue; @@ -891,10 +1022,15 @@ impl Report { s.push_str(&format!(" {:<10} {}", l.status, l.name)); if let Some((asg, lv, rv)) = &l.counterexample { let a: Vec = asg.iter().map(|(k, v)| format!("{k}={v}")).collect(); - s.push_str(&format!("\n counterexample {}\n lhs = {lv}\n rhs = {rv}", a.join(" "))); + s.push_str(&format!( + "\n counterexample {}\n lhs = {lv}\n rhs = {rv}", + a.join(" ") + )); } if let Some((case, term, reason)) = &l.stuck { - s.push_str(&format!(" case {case}: stuck at\n L = {term}\n {reason}")); + s.push_str(&format!( + " case {case}: stuck at\n L = {term}\n {reason}" + )); } if let Some(n) = &l.note { s.push_str(&format!(" ({n})")); diff --git a/crates/loon-lang/src/verify/tests.rs b/crates/loon-lang/src/verify/tests.rs index 22c7c4f..46048e9 100644 --- a/crates/loon-lang/src/verify/tests.rs +++ b/crates/loon-lang/src/verify/tests.rs @@ -22,11 +22,27 @@ fn defs() -> Defs { Defs::from_exprs(&crate::parser::parse(DEFS).unwrap()).unwrap() } -fn prove(defs: &Defs, params: &[&str], lhs: &str, rhs: &str, steps: &str, lemmas: &kernel::Lemmas) -> Outcome { +fn prove( + defs: &Defs, + params: &[&str], + lhs: &str, + rhs: &str, + steps: &str, + lemmas: &kernel::Lemmas, +) -> Outcome { let params: Vec = params.iter().map(|s| s.to_string()).collect(); - let types: HashMap = params.iter().map(|p| (p.clone(), kernel::Ty::named("List"))).collect(); + let types: HashMap = params + .iter() + .map(|p| (p.clone(), kernel::Ty::named("List"))) + .collect(); let (l, r) = (p(lhs), p(rhs)); - let goal = Goal { law_name: "t", params: ¶ms, param_types: &types, lhs: &l, rhs: &r }; + let goal = Goal { + law_name: "t", + params: ¶ms, + param_types: &types, + lhs: &l, + rhs: &r, + }; let steps = crate::parser::parse(steps).unwrap(); check_proof(&goal, &steps, defs, lemmas) } @@ -50,7 +66,10 @@ fn unfold_normalizes_nil_case() { let t = kernel::unfold(&p("[append Nil ys]"), "append", &d, &mut used).unwrap(); assert!(term_eq(&kernel::normalize(&t, &d), &p("ys"))); let t = kernel::unfold(&p("[append [Cons a b] ys]"), "append", &d, &mut used).unwrap(); - assert!(term_eq(&kernel::normalize(&t, &d), &p("[Cons a [append b ys]]"))); + assert!(term_eq( + &kernel::normalize(&t, &d), + &p("[Cons a [append b ys]]") + )); } #[test] @@ -62,11 +81,19 @@ fn unfold_refuses_non_total() { #[test] fn rewrite_with_rule() { let d = defs(); - let ih = Rule { params: vec![], lhs: p("[append rest Nil]"), rhs: p("rest") }; + let ih = Rule { + params: vec![], + lhs: p("[append rest Nil]"), + rhs: p("rest"), + }; let t = kernel::rewrite(&p("[Cons x [append rest Nil]]"), &ih, 0, &d).unwrap(); assert!(term_eq(&t, &p("[Cons x rest]"))); // :at selects the Nth preorder match - let r = Rule { params: vec!["a".into()], lhs: p("[f a]"), rhs: p("a") }; + let r = Rule { + params: vec!["a".into()], + lhs: p("[f a]"), + rhs: p("a"), + }; let t = kernel::rewrite(&p("[g [f 1] [f 2]]"), &r, 1, &d).unwrap(); assert!(term_eq(&t, &p("[g [f 1] 2]"))); assert!(kernel::rewrite(&p("[g 1]"), &r, 0, &d).is_err()); @@ -109,18 +136,50 @@ fn stuck_reports_term() { #[test] fn missing_case_is_stuck() { let d = defs(); - let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[induction xs [Nil [unfold append]]]", &none); + let o = prove( + &d, + &["xs"], + "[append xs Nil]", + "xs", + "[induction xs [Nil [unfold append]]]", + &none, + ); assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("missing case Cons"))); } #[test] fn admit_taints() { let d = defs(); - let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[induction xs [Nil [unfold append]] [Cons [admit]]]", &none); + let o = prove( + &d, + &["xs"], + "[append xs Nil]", + "xs", + "[induction xs [Nil [unfold append]] [Cons [admit]]]", + &none, + ); assert_eq!(o, Outcome::Admitted); // Citing an admitted lemma taints too. - let lem = |n: &str| (n == "an").then(|| (Rule { params: vec!["xs".into()], lhs: p("[append xs Nil]"), rhs: p("xs") }, true)); - let o = prove(&d, &["ys"], "[append [append ys Nil] Nil]", "ys", "[rewrite an] [rewrite an]", &lem); + let lem = |n: &str| { + (n == "an").then(|| { + ( + Rule { + params: vec!["xs".into()], + lhs: p("[append xs Nil]"), + rhs: p("xs"), + }, + true, + ) + }) + }; + let o = prove( + &d, + &["ys"], + "[append [append ys Nil] Nil]", + "ys", + "[rewrite an] [rewrite an]", + &lem, + ); assert_eq!(o, Outcome::Admitted); } @@ -130,23 +189,47 @@ fn ih_only_inside_induction() { let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[rewrite ih]", &none); assert!(matches!(o, Outcome::Stuck { .. })); // `cases` gives no ih - let o = prove(&d, &["xs"], "[append xs Nil]", "xs", "[cases xs [Nil] [Cons [unfold append] [rewrite ih]]]", &none); + let o = prove( + &d, + &["xs"], + "[append xs Nil]", + "xs", + "[cases xs [Nil] [Cons [unfold append] [rewrite ih]]]", + &none, + ); assert!(matches!(o, Outcome::Stuck { .. })); } #[test] fn induction_refuses_non_total_goal() { let d = defs(); - let o = prove(&d, &["xs"], "[spin xs]", "[spin xs]", "[induction xs [Nil] [Cons]]", &none); - assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("structurally recursive"))); + let o = prove( + &d, + &["xs"], + "[spin xs]", + "[spin xs]", + "[induction xs [Nil] [Cons]]", + &none, + ); + assert!( + matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("structurally recursive")) + ); } #[test] fn canary_cannot_be_proven() { let d = defs(); - for steps in ["", "[refl]", "[induction xs [Nil] [Cons [rewrite ih]]]", "[unfold reverse] [unfold append]"] { + for steps in [ + "", + "[refl]", + "[induction xs [Nil] [Cons [rewrite ih]]]", + "[unfold reverse] [unfold append]", + ] { let o = prove(&d, &["xs"], "[reverse xs]", "xs", steps, &none); - assert!(matches!(o, Outcome::Stuck { .. }), "steps {steps:?} gave {o:?}"); + assert!( + matches!(o, Outcome::Stuck { .. }), + "steps {steps:?} gave {o:?}" + ); } let o = prove(&d, &[], "1", "2", "", &none); assert!(matches!(o, Outcome::Stuck { .. })); @@ -214,8 +297,14 @@ fn cycle_rejected() { "cycle", &[ ("defs.oo", DEFS), - ("laws/l.oo", "[law a [xs] [= [append xs Nil] xs]]\n[law b [xs] [= xs [append xs Nil]]]"), - ("proofs/p.oo", "[proof a [rewrite b :rev]]\n[proof b [rewrite a :rev]]"), + ( + "laws/l.oo", + "[law a [xs] [= [append xs Nil] xs]]\n[law b [xs] [= xs [append xs Nil]]]", + ), + ( + "proofs/p.oo", + "[proof a [rewrite b :rev]]\n[proof b [rewrite a :rev]]", + ), ], ); let r = run_dir(&dir, &Options::default()).unwrap(); @@ -265,10 +354,20 @@ fn plus_canonical_form() { #[test] fn plus_normalization_does_not_prove_falsehoods() { let d = defs(); - let r = prove(&d, &["xs"], "[+ 1 [length xs]]", "[length xs]", "[refl]", &none); + let r = prove( + &d, + &["xs"], + "[+ 1 [length xs]]", + "[length xs]", + "[refl]", + &none, + ); assert!(!matches!(r, Outcome::Proven), "1 + n = n must not close"); let r = prove(&d, &["xs"], "[+ a b]", "[+ a c]", "[refl]", &none); - assert!(!matches!(r, Outcome::Proven), "a + b = a + c must not close"); + assert!( + !matches!(r, Outcome::Proven), + "a + b = a + c must not close" + ); } // --- nat agent: bounded generation for non-list ADTs --- @@ -292,7 +391,10 @@ fn bounded_enumerates_nat() { [law mul-is-add [m n] [= [mul m n] [add m n]]] "#, ), - ("proofs/p.oo", "[proof add-zero-right [induction n [Z] [S [unfold add] [rewrite ih]]]]"), + ( + "proofs/p.oo", + "[proof add-zero-right [induction n [Z] [S [unfold add] [rewrite ih]]]]", + ), ], ); let r = run_dir(&dir, &Options::default()).unwrap(); @@ -300,7 +402,11 @@ fn bounded_enumerates_nat() { assert_eq!(status(&r, "add-zero-right").status, "proven"); // `p` is only a non-scrutinized argument; it must still be generated as a Nat. let d = status(&r, "mul-dist"); - assert!(!d.note.as_deref().unwrap_or("").contains("bounded"), "{:?}", d.note); + assert!( + !d.note.as_deref().unwrap_or("").contains("bounded"), + "{:?}", + d.note + ); assert!(d.checked > 10); let w = status(&r, "mul-is-add"); assert_eq!(w.status, "falsified"); @@ -358,11 +464,25 @@ fn ty(s: &str) -> kernel::Ty { } } -fn prove_typed(defs: &Defs, params: &[(&str, &str)], lhs: &str, rhs: &str, steps: &str, lemmas: &kernel::Lemmas) -> Outcome { +fn prove_typed( + defs: &Defs, + params: &[(&str, &str)], + lhs: &str, + rhs: &str, + steps: &str, + lemmas: &kernel::Lemmas, +) -> Outcome { let names: Vec = params.iter().map(|(n, _)| n.to_string()).collect(); - let types: HashMap = params.iter().map(|(n, t)| (n.to_string(), ty(t))).collect(); + let types: HashMap = + params.iter().map(|(n, t)| (n.to_string(), ty(t))).collect(); let (l, r) = (p(lhs), p(rhs)); - let goal = Goal { law_name: "t", params: &names, param_types: &types, lhs: &l, rhs: &r }; + let goal = Goal { + law_name: "t", + params: &names, + param_types: &types, + lhs: &l, + rhs: &r, + }; let steps = crate::parser::parse(steps).unwrap(); check_proof(&goal, &steps, defs, lemmas) } @@ -411,7 +531,10 @@ fn reduce_match_nested_patterns_and_wildcard() { assert_eq!(n(&m.replace('S', "[Cons 1 Nil]")), "[miss]"); assert_eq!(n(&m.replace('S', "Nil")), "[miss]"); // Undecided inner pattern: must not fall through to `_`. - assert_eq!(n(&m.replace('S', "[Cons 1 t]")), m.replace('S', "[Cons 1 t]")); + assert_eq!( + n(&m.replace('S', "[Cons 1 t]")), + m.replace('S', "[Cons 1 t]") + ); } #[test] @@ -433,7 +556,11 @@ fn cases_on_constructor_field_with_inferred_type() { let d = cdefs(); let o = prove_typed( &d, - &[("c1", "[List Instr]"), ("c2", "[List Instr]"), ("s", "[List Int]")], + &[ + ("c1", "[List Instr]"), + ("c2", "[List Instr]"), + ("s", "[List Int]"), + ], "[exec [append c1 c2] s]", "[exec c2 [exec c1 s]]", EXEC_APPEND_PROOF, @@ -449,9 +576,19 @@ fn cases_on_constructor_field_with_inferred_type() { EXEC_APPEND_PROOF, &none, ); - assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("type of `x`")), "{o:?}"); + assert!( + matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("type of `x`")), + "{o:?}" + ); // `cases` on an Int is refused. - let o = prove_typed(&d, &[("s", "[List Int]")], "s", "s", "[cases s [Nil] [Cons [cases x [A] [B]]]]", &none); + let o = prove_typed( + &d, + &[("s", "[List Int]")], + "s", + "s", + "[cases s [Nil] [Cons [cases x [A] [B]]]]", + &none, + ); assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); } @@ -462,7 +599,11 @@ fn halting_exec_does_not_distribute() { let d = cdefs(); let o = prove_typed( &d, - &[("c1", "[List Instr]"), ("c2", "[List Instr]"), ("s", "[List Int]")], + &[ + ("c1", "[List Instr]"), + ("c2", "[List Instr]"), + ("s", "[List Int]"), + ], "[exec-halt [append c1 c2] s]", "[exec-halt c2 [exec-halt c1 s]]", &EXEC_APPEND_PROOF.replace("exec", "exec-halt"), @@ -488,7 +629,10 @@ fn two_hypotheses_for_two_recursive_fields() { assert_eq!(goal(ok), Outcome::Proven); // Plain `ih` is ambiguous with two hypotheses. let o = goal("[induction e [Lit] [Add [unfold compile] [rewrite exec-append] [rewrite ih]]]"); - assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("ambiguous")), "{o:?}"); + assert!( + matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("ambiguous")), + "{o:?}" + ); // The stuck report lists the hypotheses in scope. let o = goal("[induction e [Lit] [Add [unfold compile]]]"); match o { @@ -504,7 +648,10 @@ fn two_hypotheses_for_two_recursive_fields() { assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); // Unknown hypothesis names are refused, not looked up as laws. let o = goal("[induction e [Lit] [Add [rewrite ih-zz]]]"); - assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("ih-zz")), "{o:?}"); + assert!( + matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("ih-zz")), + "{o:?}" + ); } #[test] @@ -538,8 +685,18 @@ fn no_hypothesis_for_indirectly_recursive_fields() { // Rose's field `(List Rose)` mentions Rose but is a list, not a Rose: // induction on Rose must not offer a hypothesis about it. let d = cdefs(); - let o = prove_typed(&d, &[("t", "Rose")], "[f t]", "[g t]", "[induction t [Node [rewrite ih]]]", &none); - assert!(matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("no induction hypothesis")), "{o:?}"); + let o = prove_typed( + &d, + &[("t", "Rose")], + "[f t]", + "[g t]", + "[induction t [Node [rewrite ih]]]", + &none, + ); + assert!( + matches!(o, Outcome::Stuck { ref reason, .. } if reason.contains("no induction hypothesis")), + "{o:?}" + ); } #[test] @@ -553,14 +710,40 @@ fn infer_law_param_types() { &p("[exec c2 [exec c1 s]]"), ) .unwrap(); - let ts: Vec = ts.iter().map(|t| format!("{:?}", super::infer::to_ty(t))).collect(); - assert!(ts[0].contains("\"List\"") && ts[0].contains("\"Instr\""), "{ts:?}"); - assert!(ts[2].contains("\"List\"") && ts[2].contains("\"Int\""), "{ts:?}"); + let ts: Vec = ts + .iter() + .map(|t| format!("{:?}", super::infer::to_ty(t))) + .collect(); + assert!( + ts[0].contains("\"List\"") && ts[0].contains("\"Instr\""), + "{ts:?}" + ); + assert!( + ts[2].contains("\"List\"") && ts[2].contains("\"Int\""), + "{ts:?}" + ); // compile uses append at Instr; a plain list law stays polymorphic. - let ts = super::infer::law_param_types(&d, &d.fn_order, &["xs".into()], &p("[append xs Nil]"), &p("xs")).unwrap(); - assert_eq!(super::infer::to_ty(&ts[0]), kernel::Ty::app("List", vec![kernel::Ty::unknown()])); + let ts = super::infer::law_param_types( + &d, + &d.fn_order, + &["xs".into()], + &p("[append xs Nil]"), + &p("xs"), + ) + .unwrap(); + assert_eq!( + super::infer::to_ty(&ts[0]), + kernel::Ty::app("List", vec![kernel::Ty::unknown()]) + ); // Ill-typed laws do not infer. - assert!(super::infer::law_param_types(&d, &d.fn_order, &["e".into()], &p("[eval e]"), &p("[Cons 1 Nil]")).is_none()); + assert!(super::infer::law_param_types( + &d, + &d.fn_order, + &["e".into()], + &p("[eval e]"), + &p("[Cons 1 Nil]") + ) + .is_none()); } #[test] @@ -569,11 +752,17 @@ fn typed_generator_enumerates_any_adt() { let d = cdefs(); let expr = Type::Con("Expr".into(), vec![]); assert!(super::bounded::typed_values(&expr, 0, &d, 0).is_empty()); - let one: Vec = super::bounded::typed_values(&expr, 1, &d, 0).iter().map(|e| e.to_string()).collect(); + let one: Vec = super::bounded::typed_values(&expr, 1, &d, 0) + .iter() + .map(|e| e.to_string()) + .collect(); assert_eq!(one, vec!["[Lit 0]", "[Lit 1]", "[Lit 2]"]); assert_eq!(super::bounded::typed_values(&expr, 3, &d, 0).len(), 9); // Add of two Lits let code = Type::Con("List".into(), vec![Type::Con("Instr".into(), vec![])]); - let c1: Vec = super::bounded::typed_values(&code, 1, &d, 0).iter().map(|e| e.to_string()).collect(); + let c1: Vec = super::bounded::typed_values(&code, 1, &d, 0) + .iter() + .map(|e| e.to_string()) + .collect(); assert_eq!(c1, vec!["[Cons IAdd Nil]"]); } @@ -598,7 +787,12 @@ fn pipeline_falsifies_false_compiler_law() { // the true law survives the bounded check on instruction lists let t = status(&r, "exec-append"); let bounded_err = t.note.as_deref().is_some_and(|n| n.contains("bounded")); - assert!(t.counterexample.is_none() && !bounded_err && t.checked > 100, "{:?} {}", t.note, t.checked); + assert!( + t.counterexample.is_none() && !bounded_err && t.checked > 100, + "{:?} {}", + t.note, + t.checked + ); } // ─── AC normalization of declared operators ──────────────────────────────── @@ -611,7 +805,10 @@ const NAT_DEFS: &str = r#" fn nat_ac(unit: bool) -> Defs { let mut d = Defs::from_exprs(&crate::parser::parse(NAT_DEFS).unwrap()).unwrap(); - d.ac.push(AcOp { op: "add".into(), unit: unit.then(|| kernel::sym("Z")) }); + d.ac.push(AcOp { + op: "add".into(), + unit: unit.then(|| kernel::sym("Z")), + }); d } @@ -623,11 +820,23 @@ fn prove_nat(d: &Defs, params: &[&str], lhs: &str, rhs: &str, steps: &str) -> Ou #[test] fn ac_closes_permuted_nesting() { let d = nat_ac(false); - let o = prove_nat(&d, &["a", "b", "c"], "[add [add a b] c]", "[add c [add b a]]", ""); + let o = prove_nat( + &d, + &["a", "b", "c"], + "[add [add a b] c]", + "[add c [add b a]]", + "", + ); assert_eq!(o, Outcome::Proven); // not without the declaration let plain = Defs::from_exprs(&crate::parser::parse(NAT_DEFS).unwrap()).unwrap(); - let o = prove_nat(&plain, &["a", "b", "c"], "[add [add a b] c]", "[add c [add b a]]", ""); + let o = prove_nat( + &plain, + &["a", "b", "c"], + "[add [add a b] c]", + "[add c [add b a]]", + "", + ); assert!(matches!(o, Outcome::Stuck { .. })); } @@ -635,7 +844,10 @@ fn ac_closes_permuted_nesting() { fn ac_does_not_prove_falsehoods() { let d = nat_ac(true); let o = prove_nat(&d, &["a", "b", "c"], "[add a b]", "[add a c]", "[refl]"); - assert!(!matches!(o, Outcome::Proven), "a + b = a + c must not close"); + assert!( + !matches!(o, Outcome::Proven), + "a + b = a + c must not close" + ); let o = prove_nat(&d, &["a", "b"], "[mul a b]", "[add a b]", ""); assert!(!matches!(o, Outcome::Proven)); let o = prove_nat(&d, &["a"], "[add a a]", "a", ""); @@ -673,7 +885,12 @@ const AC_PROOFS_GOOD: &str = r#" fn ac_dir(tag: &str, laws: &str, proofs: &str) -> Report { let dir = tmp_dir( tag, - &[("defs.oo", NAT_DEFS), ("canary.oo", "[law canary [] [= 1 2]]"), ("laws/n.oo", laws), ("proofs/p.oo", proofs)], + &[ + ("defs.oo", NAT_DEFS), + ("canary.oo", "[law canary [] [= 1 2]]"), + ("laws/n.oo", laws), + ("proofs/p.oo", proofs), + ], ); run_dir(&dir, &Options::default()).unwrap() } @@ -686,7 +903,12 @@ fn ac_active_after_its_laws_are_proven() { let r = ac_dir("ac-on", AC_LAWS, &proofs); assert!(r.errors.is_empty(), "{:?}", r.errors); assert_eq!(status(&r, "add-comm").status, "proven"); - assert_eq!(status(&r, "add-rotate").status, "proven", "{:?}", status(&r, "add-rotate").stuck); + assert_eq!( + status(&r, "add-rotate").status, + "proven", + "{:?}", + status(&r, "add-rotate").stuck + ); } #[test] @@ -709,10 +931,22 @@ fn ac_not_active_in_proofs_of_its_own_laws() { #[test] fn ac_malformed_decl_rejected() { for (decl, frag) in [ - ("[ac add add-comm add-comm]", "add-comm` is not [= [add [add"), - ("[ac add add-assoc add-assoc]", "add-assoc` is not [= [add a b]"), - ("[ac add add-assoc add-comm :unit Z add-succ-right]", "add-succ-right` is not"), - ("[ac add add-assoc add-comm :unit S add-zero-right]", "unit `S`"), + ( + "[ac add add-comm add-comm]", + "add-comm` is not [= [add [add", + ), + ( + "[ac add add-assoc add-assoc]", + "add-assoc` is not [= [add a b]", + ), + ( + "[ac add add-assoc add-comm :unit Z add-succ-right]", + "add-succ-right` is not", + ), + ( + "[ac add add-assoc add-comm :unit S add-zero-right]", + "unit `S`", + ), ("[ac add add-assoc nope]", "`nope` is not a law"), ("[ac Z add-assoc add-comm]", "not a two-argument fn"), ("[ac add add-assoc]", "malformed"), @@ -720,13 +954,23 @@ fn ac_malformed_decl_rejected() { let laws = AC_LAWS.replace("[ac add add-assoc add-comm :unit Z add-zero-right]", decl); let proofs = format!("{AC_PROOFS_GOOD}\n[proof add-comm [induction m [Z [unfold add] [rewrite add-zero-right :rev]] [S [unfold add] [rewrite ih] [rewrite add-succ-right :rev]]]]"); let r = ac_dir("ac-bad", &laws, &proofs); - assert!(r.errors.iter().any(|e| e.contains(frag)), "{decl}: {:?}", r.errors); + assert!( + r.errors.iter().any(|e| e.contains(frag)), + "{decl}: {:?}", + r.errors + ); assert_eq!(status(&r, "add-rotate").status, "unknown", "{decl}"); } // A comm law with the same shape but over a different op is rejected too. - let laws = format!("{AC_LAWS}\n[law mul-comm [m n] [= [mul m n] [mul n m]]]\n[ac add add-assoc mul-comm]"); + let laws = format!( + "{AC_LAWS}\n[law mul-comm [m n] [= [mul m n] [mul n m]]]\n[ac add add-assoc mul-comm]" + ); let r = ac_dir("ac-bad2", &laws, AC_PROOFS_GOOD); - assert!(r.errors.iter().any(|e| e.contains("mul-comm` is not")), "{:?}", r.errors); + assert!( + r.errors.iter().any(|e| e.contains("mul-comm` is not")), + "{:?}", + r.errors + ); } #[test] From d3d56f4cd76c8d2bbd09243c9adbf3ca78978528 Mon Sep 17 00:00:00 2001 From: Cam Pedersen Date: Wed, 28 Oct 2026 16:52:37 -0400 Subject: [PATCH 3/4] feat(verify): conditional laws, mutual induction, and the meta-model corpus Rungs 1 and 2 of docs/plans/2026-10-28-self-verifying-kernel.md. - `[law name [params] :given [[= a b] ...] [= l r]]`: hypotheses are ground rules h1, h2, ... inside their own proof, with constructor injectivity giving h1.1, h1.2, ... Citing a conditional law or ih raises obligations discharged by normalization, an in-scope hypothesis, or a settled unconditional law. Bounded evaluation skips vacuous inputs and never proves by vacuity. - Totality for mutually recursive groups: SCCs with one measure parameter per member, every in-group call passing a strict subterm. - Mutual induction: `[proof p :mutual q [induction ...]]` pairs supply each other's law at constructor fields of the split value; the group settles together or not at all, and members are not citable by name. - verify/meta: Term/Subst model with subst-empty, subst-compose (term and list versions) and apply-match-var proven; general apply-match stuck pending case splits on non-variable scrutinees and :given inside mutual groups. - verify/laws/cond.oo: append-cancel-left, rev-inj, add-cancel-left. 27 proven in verify/, 9 in verify/meta/, both sound. Co-Authored-By: Claude Fable 5.1 --- crates/loon-lang/src/verify/bounded.rs | 52 +- crates/loon-lang/src/verify/infer.rs | 77 +- crates/loon-lang/src/verify/kernel.rs | 711 ++++++++++++++++-- crates/loon-lang/src/verify/mod.rs | 236 +++++- crates/loon-lang/src/verify/tests.rs | 658 ++++++++++++++++ .../plans/2026-10-28-self-verifying-kernel.md | 179 +++++ docs/plans/2026-10-28-verify-autoresearch.md | 40 + verify/laws/cond.oo | 21 + verify/meta/canary.oo | 4 + verify/meta/defs.oo | 177 +++++ verify/meta/laws/subst.oo | 32 + verify/meta/proofs/subst.oo | 64 ++ verify/proofs/cond.oo | 22 + 13 files changed, 2145 insertions(+), 128 deletions(-) create mode 100644 docs/plans/2026-10-28-self-verifying-kernel.md create mode 100644 verify/laws/cond.oo create mode 100644 verify/meta/canary.oo create mode 100644 verify/meta/defs.oo create mode 100644 verify/meta/laws/subst.oo create mode 100644 verify/meta/proofs/subst.oo create mode 100644 verify/proofs/cond.oo diff --git a/crates/loon-lang/src/verify/bounded.rs b/crates/loon-lang/src/verify/bounded.rs index 0cafd72..2ecfe43 100644 --- a/crates/loon-lang/src/verify/bounded.rs +++ b/crates/loon-lang/src/verify/bounded.rs @@ -40,6 +40,8 @@ pub struct Bounded { /// (assignment, lhs value, rhs value) pub counterexample: Option<(Vec<(String, Expr)>, String, String)>, pub error: Option, + /// Inputs skipped because they violate a hypothesis. + pub vacuous: usize, } /// Rename reference fns to `vref-NAME`, and `builtin-NAME` to `NAME`. @@ -81,13 +83,15 @@ fn mangle_children(e: &mut Expr, defs: &Defs) { pub fn param_kinds( prelude_src: &str, params: &[String], - lhs: &Expr, - rhs: &Expr, + eqs: &[(&Expr, &Expr)], defs: &Defs, ) -> Vec { + // `eqs[0]` is the conclusion; any further equations are hypotheses. + let (lhs, rhs) = eqs[0]; // Prefer verify's own inference (generalizes top-level fns); fall back - // to the language checker when it cannot type the law. - if let Some(ts) = super::infer::law_param_types(defs, &defs.fn_order, params, lhs, rhs) { + // to the language checker when it cannot type the law (which then sees + // only the conclusion). + if let Some(ts) = super::infer::law_param_types_eqs(defs, &defs.fn_order, params, eqs) { return ts .iter() .map(|t| kind_of(&super::infer::to_checker(t), defs)) @@ -598,6 +602,7 @@ pub fn check_law( kinds: &[Kind], lhs: &Expr, rhs: &Expr, + hyps: &[(Expr, Expr)], defs: &Defs, bound: usize, seed: u64, @@ -614,6 +619,13 @@ pub fn check_law( } let ins = inputs(kinds, bound, seed); let (ml, mr) = (mangle(lhs, defs), mangle(rhs, defs)); + // Per input: each hypothesis's two sides, then the conclusion's. + let mut pairs: Vec<(Expr, Expr)> = hyps + .iter() + .map(|(a, b)| (mangle(a, defs), mangle(b, defs))) + .collect(); + pairs.push((ml, mr)); + let width = pairs.len() * 2; // Each chunk returns its printed values joined by `|` (values here are // ints, bools, vectors and ADTs, none of which print a `|`). The result // comes back as main's value, so nothing is written to stdout. @@ -625,11 +637,13 @@ pub fn check_law( for input in chunk { let m: HashMap = params.iter().cloned().zip(input.iter().cloned()).collect(); - src.push_str(&format!( - "\n {} \"|\" {} \"|\"", - subst(&ml, &m, defs), - subst(&mr, &m, defs) - )); + for (a, b) in &pairs { + src.push_str(&format!( + "\n {} \"|\" {} \"|\"", + subst(a, &m, defs), + subst(b, &m, defs) + )); + } } src.push_str("]]"); chunk_names.push(name); @@ -656,32 +670,42 @@ pub fn check_law( }; let lines: Vec = out.split('|').map(str::to_string).collect(); let lines = &lines[..lines.len().saturating_sub(1)]; - if lines.len() != ins.len() * 2 { + if lines.len() != ins.len() * width { return Bounded { error: Some(format!( "expected {} values, got {}", - ins.len() * 2, + ins.len() * width, lines.len() )), ..Default::default() }; } + // An input violating a hypothesis is vacuous: skipped, counted apart. + let (mut checked, mut vacuous) = (0, 0); for (i, input) in ins.iter().enumerate() { - let (l, r) = (&lines[2 * i], &lines[2 * i + 1]); + let vals = &lines[width * i..width * (i + 1)]; + if vals[..width - 2].chunks(2).any(|p| p[0] != p[1]) { + vacuous += 1; + continue; + } + checked += 1; + let (l, r) = (&vals[width - 2], &vals[width - 1]); if l != r { return Bounded { - checked: i + 1, + checked, counterexample: Some(( params.iter().cloned().zip(input.iter().cloned()).collect(), l.clone(), r.clone(), )), error: None, + vacuous, }; } } Bounded { - checked: ins.len(), + checked, + vacuous, ..Default::default() } } diff --git a/crates/loon-lang/src/verify/infer.rs b/crates/loon-lang/src/verify/infer.rs index a8afd4b..4edc549 100644 --- a/crates/loon-lang/src/verify/infer.rs +++ b/crates/loon-lang/src/verify/infer.rs @@ -155,7 +155,7 @@ impl Inf<'_> { &mut self, e: &Expr, env: &HashMap, - current: Option<(&str, &T)>, + current: &HashMap, ) -> Option { let int = T::Con("Int".into(), vec![]); match &e.kind { @@ -165,10 +165,8 @@ impl Inf<'_> { if let Some(t) = env.get(s) { return Some(t.clone()); } - if let Some((n, t)) = current { - if n == s { - return Some(t.clone()); - } + if let Some(t) = current.get(s) { + return Some(t.clone()); } if self.defs.is_ctor(s) { let (fs, r) = self.ctor(s)?; @@ -273,43 +271,68 @@ pub fn law_param_types( params: &[String], lhs: &Expr, rhs: &Expr, +) -> Option> { + law_param_types_eqs(defs, fn_order, params, &[(lhs, rhs)]) +} + +/// `law_param_types` for a law with hypotheses: every equation (conclusion +/// and `:given` hypotheses) is typed in one environment, both sides unified. +pub fn law_param_types_eqs( + defs: &Defs, + fn_order: &[String], + params: &[String], + eqs: &[(&Expr, &Expr)], ) -> Option> { let mut inf = Inf { defs, subst: Vec::new(), schemes: HashMap::new(), }; - for name in fn_order { - let Some(f) = defs.fns.get(name) else { - continue; - }; - let mut env = HashMap::new(); - let mut pts = Vec::new(); - for p in &f.params { - let t = inf.fresh(); - env.insert(p.clone(), t.clone()); - pts.push(t); + // Mutually recursive groups (callees first) are typed together: every + // member is monomorphic inside the group and generalized after it. A + // group with a member that fails to type gets no schemes. + for group in super::kernel::fn_sccs(defs, fn_order) { + let mut current: HashMap = HashMap::new(); + let mut sigs = Vec::new(); + for name in &group { + let f = &defs.fns[name]; + let mut env = HashMap::new(); + let mut pts = Vec::new(); + for p in &f.params { + let t = inf.fresh(); + env.insert(p.clone(), t.clone()); + pts.push(t); + } + let r = inf.fresh(); + pts.push(r.clone()); + let ft = T::Con(ARROW.into(), pts); + current.insert(name.clone(), ft.clone()); + sigs.push((name, env, r, ft)); } - let r = inf.fresh(); - pts.push(r.clone()); - let ft = T::Con(ARROW.into(), pts); - let Some(bt) = inf.expr(&f.body, &env, Some((name, &ft))) else { - continue; - }; - if inf.unify(&bt, &r).is_none() { + let ok = sigs.iter().all(|(name, env, r, _)| { + inf.expr(&defs.fns[*name].body, env, ¤t) + .and_then(|bt| inf.unify(&bt, r)) + .is_some() + }); + if !ok { continue; } - let sc = inf.generalize(&ft); - inf.schemes.insert(name.clone(), sc); + for (name, _, _, ft) in &sigs { + let sc = inf.generalize(ft); + inf.schemes.insert((*name).clone(), sc); + } } let mut env = HashMap::new(); let pts: Vec = params.iter().map(|_| inf.fresh()).collect(); for (p, t) in params.iter().zip(&pts) { env.insert(p.clone(), t.clone()); } - let l = inf.expr(lhs, &env, None)?; - let r = inf.expr(rhs, &env, None)?; - inf.unify(&l, &r)?; + for (lhs, rhs) in eqs { + let l = inf.expr(lhs, &env, &HashMap::new())?; + let r = inf.expr(rhs, &env, &HashMap::new())?; + inf.unify(&l, &r)?; + } + Some(pts.iter().map(|t| inf.resolve(t)).collect()) } diff --git a/crates/loon-lang/src/verify/kernel.rs b/crates/loon-lang/src/verify/kernel.rs index 41890ec..f467fe5 100644 --- a/crates/loon-lang/src/verify/kernel.rs +++ b/crates/loon-lang/src/verify/kernel.rs @@ -527,82 +527,200 @@ pub fn eval_normalize(e: &Expr, defs: &Defs, used: &mut HashSet, fuel: & // ─── Totality (structural recursion) ─────────────────────────────────────── -/// Compute the set of total functions: structurally recursive on one fixed -/// parameter, calling only total definitions, with no mutual recursion. -pub fn total_fns(defs: &Defs) -> HashSet { - let mut total = HashSet::new(); - let mut state: HashMap = HashMap::new(); // 1 visiting, 2 done - let names: Vec = defs.fns.keys().cloned().collect(); - for n in names { - check_total(&n, defs, &mut state, &mut total); - } - total +/// Fns of defs.oo mentioned in `f`'s body (other than names its params shadow). +fn callees(f: &FnDef, defs: &Defs) -> Vec { + let mut s = HashSet::new(); + symbols(&f.body, &mut s); + let mut v: Vec = s + .into_iter() + .filter(|c| defs.fns.contains_key(c) && !f.params.contains(c)) + .collect(); + v.sort(); + v } -fn check_total( - name: &str, - defs: &Defs, - state: &mut HashMap, - total: &mut HashSet, -) -> bool { - match state.get(name) { - Some(2) => return total.contains(name), - Some(1) => return false, // mutual recursion - _ => {} +/// Strongly connected components of the call graph of defs.oo, callees +/// first (Tarjan). Members of a component are listed in `order` order. +pub fn fn_sccs(defs: &Defs, order: &[String]) -> Vec> { + struct T<'a> { + defs: &'a Defs, + index: HashMap, + low: HashMap, + stack: Vec, + on: HashSet, + out: Vec>, + } + fn visit(t: &mut T, v: &str) { + let i = t.index.len(); + t.index.insert(v.to_string(), i); + t.low.insert(v.to_string(), i); + t.stack.push(v.to_string()); + t.on.insert(v.to_string()); + for w in callees(&t.defs.fns[v], t.defs) { + if !t.index.contains_key(&w) { + visit(t, &w); + let lw = t.low[&w]; + let lv = t.low.get_mut(v).unwrap(); + *lv = (*lv).min(lw); + } else if t.on.contains(&w) { + let iw = t.index[&w]; + let lv = t.low.get_mut(v).unwrap(); + *lv = (*lv).min(iw); + } + } + if t.low[v] == t.index[v] { + let mut comp = Vec::new(); + while let Some(w) = t.stack.pop() { + t.on.remove(&w); + let done = w == v; + comp.push(w); + if done { + break; + } + } + t.out.push(comp); + } } - state.insert(name.to_string(), 1); - let f = &defs.fns[name]; - let mut callees = HashSet::new(); - symbols(&f.body, &mut callees); - let mut ok = callees + let mut t = T { + defs, + index: HashMap::new(), + low: HashMap::new(), + stack: Vec::new(), + on: HashSet::new(), + out: Vec::new(), + }; + let mut roots: Vec = order .iter() - .filter(|c| c.as_str() != name && defs.fns.contains_key(c.as_str())) - .filter(|c| !f.params.contains(c)) - .all(|c| check_total(c, defs, state, total)); - ok = ok && structural(f, name, defs); - state.insert(name.to_string(), 2); - if ok { - total.insert(name.to_string()); + .filter(|n| defs.fns.contains_key(*n)) + .cloned() + .collect(); + let mut rest: Vec = defs + .fns + .keys() + .filter(|n| !roots.contains(n)) + .cloned() + .collect(); + rest.sort(); + roots.extend(rest); + for r in &roots { + if !t.index.contains_key(r) { + visit(&mut t, r); + } + } + let pos = |n: &String| roots.iter().position(|r| r == n); + for comp in t.out.iter_mut() { + comp.sort_by_key(pos); } - ok + t.out } -fn structural(f: &FnDef, name: &str, defs: &Defs) -> bool { - if f.params.iter().any(|p| p == name) { - return false; +/// Compute the set of total functions. Each strongly connected component +/// of the call graph (a single fn, or a group of mutually recursive fns) is +/// total when every fn it calls outside itself is total and it is +/// structurally recursive as a group (`structural_group`). +pub fn total_fns(defs: &Defs) -> HashSet { + let mut total: HashSet = HashSet::new(); + for group in fn_sccs(defs, &defs.fn_order) { + let ext_ok = group.iter().all(|n| { + callees(&defs.fns[n], defs) + .iter() + .all(|c| group.contains(c) || total.contains(c)) + }); + if ext_ok && structural_group(&group, defs) { + total.extend(group); + } } - let mut calls = Vec::new(); - if !collect_self_calls(&f.body, name, &HashMap::new(), defs, &mut calls) { - return false; + total +} + +/// The structural rule for a recursive group (one fn, or several mutually +/// recursive fns, e.g. `subst` on a term and `subst-list` on its argument +/// list). The group is accepted when there is a choice of one *measure* +/// parameter per member such that every call from member f to member g +/// passes, in g's measure position, a pattern-bound strict subterm of f's +/// measure parameter (a variable bound by a constructor pattern of a `match` +/// on that parameter, or on such a variable, transitively). +/// +/// Soundness: values are finite constructor trees and a strict subterm has +/// strictly fewer constructor nodes, so along any chain of calls inside the +/// group the size of the measure argument strictly decreases; every chain +/// is finite, and calls leaving the group go to fns already known total. +/// For a single fn this is exactly "every self-call passes a strict subterm +/// of one fixed parameter". +fn structural_group(group: &[String], defs: &Defs) -> bool { + let mut calls: Vec<(usize, usize, Vec>)> = Vec::new(); + for (i, n) in group.iter().enumerate() { + let f = &defs.fns[n]; + if f.params.iter().any(|p| group.contains(p)) { + return false; + } + let mut cs = Vec::new(); + if !collect_group_calls(&f.body, f, group, &HashMap::new(), defs, &mut cs) { + return false; + } + for (callee, args) in cs { + let j = group.iter().position(|g| *g == callee).unwrap(); + if args.len() != defs.fns[&callee].params.len() { + return false; + } + calls.push((i, j, args)); + } } if calls.is_empty() { return true; } - // Some fixed parameter index i such that every self-call's i-th arg is a - // strict subterm of parameter i. - (0..f.params.len()).any(|i| { - calls - .iter() - .all(|args| args.len() == f.params.len() && matches!(&args[i], Some(p) if *p == i)) - }) + let arities: Vec = group.iter().map(|n| defs.fns[n].params.len()).collect(); + if arities.contains(&0) { + return false; + } + // Try every measure assignment (odometer), up to a small cap. + let combos = arities + .iter() + .try_fold(1usize, |acc, a| acc.checked_mul(*a)); + if combos.is_none_or(|c| c > 1 << 16) { + return false; + } + let mut d = vec![0usize; group.len()]; + loop { + if calls.iter().all(|(i, j, args)| args[d[*j]] == Some(d[*i])) { + return true; + } + let mut k = 0; + loop { + if k == d.len() { + return false; + } + d[k] += 1; + if d[k] < arities[k] { + break; + } + d[k] = 0; + k += 1; + } + } } -/// Walk `e`, tracking which variables are strict subterms of which param -/// (`env`: var -> param index). Each self-call records, per argument, the -/// param it is a strict subterm of. Returns false on a non-call self-reference -/// or on rebinding that would make tracking unsound. -fn collect_self_calls( +/// Walk `e` (part of `f`'s body), tracking which variables are strict +/// subterms of which param of `f` (`env`: var -> param index). Each call to +/// a member of `group` records the callee and, per argument, the param it +/// is a strict subterm of. Returns false on a non-call reference to a group +/// member or on rebinding that would make tracking unsound. +fn collect_group_calls( e: &Expr, - name: &str, + f: &FnDef, + group: &[String], env: &HashMap, defs: &Defs, - calls: &mut Vec>>, + calls: &mut Vec<(String, Vec>)>, ) -> bool { - let f = &defs.fns[name]; + let rec = |c: &Expr, env: &HashMap, calls: &mut Vec<_>| { + collect_group_calls(c, f, group, env, defs, calls) + }; match &e.kind { - ExprKind::Symbol(s) => s != name, - ExprKind::List(items) if head_sym(e) == Some(name) => { - calls.push( + ExprKind::Symbol(s) => !group.contains(s), + ExprKind::List(items) if head_sym(e).is_some_and(|h| group.iter().any(|g| g == h)) => { + calls.push(( + head_sym(e).unwrap().to_string(), items[1..] .iter() .map(|a| match &a.kind { @@ -610,13 +728,11 @@ fn collect_self_calls( _ => None, }) .collect(), - ); - items[1..] - .iter() - .all(|a| collect_self_calls(a, name, env, defs, calls)) + )); + items[1..].iter().all(|a| rec(a, env, calls)) } ExprKind::List(items) if head_sym(e) == Some("match") && items.len() >= 2 => { - if !collect_self_calls(&items[1], name, env, defs, calls) { + if !rec(&items[1], env, calls) { return false; } let scrut_param = match &items[1].kind { @@ -639,8 +755,8 @@ fn collect_self_calls( let mut inner = env.clone(); for v in &bound { inner.remove(v); - if f.params.contains(v) { - return false; // shadowing a param: refuse + if f.params.contains(v) || group.contains(v) { + return false; // shadowing a param or a group fn: refuse } if is_ctor_pat { if let Some(i) = scrut_param.or(scrut_sub) { @@ -649,7 +765,7 @@ fn collect_self_calls( } } if let Some(b) = pair.get(1) { - if !collect_self_calls(b, name, &inner, defs, calls) { + if !rec(b, &inner, calls) { return false; } } @@ -668,24 +784,24 @@ fn collect_self_calls( { return false; } - items - .iter() - .all(|c| collect_self_calls(c, name, env, defs, calls)) + items.iter().all(|c| rec(c, env, calls)) } - _ => children(e) - .into_iter() - .all(|c| collect_self_calls(c, name, env, defs, calls)), + _ => children(e).into_iter().all(|c| rec(c, env, calls)), } } // ─── Rewriting ───────────────────────────────────────────────────────────── /// A rewrite rule: universally quantified `params` act as pattern variables. +/// `hyps` are the rule's conditions (a conditional law's `:given`): each, +/// instantiated under the match, is an obligation discharged at the use site +/// (see `discharge`). Unconditional rules have none. #[derive(Clone, Debug)] pub struct Rule { pub params: Vec, pub lhs: Expr, pub rhs: Expr, + pub hyps: Vec<(Expr, Expr)>, } /// First-order matching. At an application of an active user AC operator @@ -784,6 +900,48 @@ fn rewrite_nth( done.then_some(out) } +type OnMatch<'a> = dyn FnMut(&HashMap) -> Result + 'a; + +/// Like `rewrite_nth`, but hands the match's bindings to `on_match`, which +/// builds the replacement (or refuses it). +fn rewrite_nth_by( + t: &Expr, + rule: &Rule, + target: usize, + seen: &mut usize, + defs: &Defs, + on_match: &mut OnMatch, +) -> Option> { + let mut b = HashMap::new(); + if match_term(&rule.lhs, t, &rule.params, &mut b, defs) { + if *seen == target { + return Some(on_match(&b)); + } + *seen += 1; + } + let mut res: Option> = None; + let out = map_children(t, &mut |c| { + if res.is_some() { + return c.clone(); + } + match rewrite_nth_by(c, rule, target, seen, defs, on_match) { + Some(Ok(r)) => { + res = Some(Ok(r.clone())); + r + } + Some(Err(e)) => { + res = Some(Err(e)); + c.clone() + } + None => c.clone(), + } + }); + match res { + Some(Ok(_)) => Some(Ok(out)), + r => r, + } +} + pub fn rewrite(t: &Expr, rule: &Rule, at: usize, defs: &Defs) -> Result { let mut lhs_vars = HashSet::new(); symbols(&rule.lhs, &mut lhs_vars); @@ -947,6 +1105,8 @@ pub struct Goal<'a> { pub param_types: &'a HashMap, pub lhs: &'a Expr, pub rhs: &'a Expr, + /// The law's `:given` hypotheses, over its params. + pub hyps: &'a [(Expr, Expr)], } /// Look up a citable law by name: returns (rule, admitted?). @@ -955,9 +1115,59 @@ pub type Lemmas<'a> = dyn Fn(&str) -> Option<(Rule, bool)> + 'a; struct Ctx<'a> { defs: &'a Defs, lemmas: &'a Lemmas<'a>, + /// Every citable law (name, rule, admitted?), for discharging obligations + /// by an instance of a proven law. + known: &'a [(String, Rule, bool)], + /// The other laws of this proof's `:mutual` group (empty if none). + partners: &'a [Mutual], admitted: bool, } +/// Another law of a `:mutual` group, as a source of induction hypotheses. +/// +/// Mutual induction: laws P1..Pk, each proven by a proof that is a single +/// `[induction Vi ...]` on a param Vi of type Ti, are proven together. In +/// the induction cases of Pi, every constructor field whose type is exactly +/// Tj gets the hypothesis "Pj at that field" (Pj's other params stay +/// quantified), cited as `ih-FIELD` (`ih-FIELD-PJ` when the field already +/// has Pi's own hypothesis); fields of type Ti get Pi's own `ih` as usual. +/// Soundness: by strong induction on the number of constructor nodes n, +/// prove "every Pi holds at every value of size n": each case of each proof +/// uses some Pj only at a constructor field of the value being split, which +/// is strictly smaller. Hence all of P1..Pk hold, and only together: the +/// driver (`verify/mod.rs`) makes no member citable until every member's +/// proof has closed, and none if any is stuck. +#[derive(Clone, Debug)] +pub struct Mutual { + pub name: String, + pub params: Vec, + /// The param the partner's proof does induction on, and its type. + pub var: String, + pub var_ty: Ty, + pub lhs: Expr, + pub rhs: Expr, +} + +/// Is `t` fully known (no `?` anywhere)? +fn ty_known(t: &Ty) -> bool { + t.name != "?" && t.args.iter().all(ty_known) +} + +/// The variable of a proof that is exactly one `[induction V ...]` step. +pub fn sole_induction_var(steps: &[Expr]) -> Option { + let [step] = steps else { return None }; + let ExprKind::List(items) = &step.kind else { + return None; + }; + if head_sym(step) != Some("induction") { + return None; + } + match items.get(1).map(|e| &e.kind) { + Some(ExprKind::Symbol(v)) => Some(v.clone()), + _ => None, + } +} + #[derive(Clone)] struct State { l: Expr, @@ -969,13 +1179,64 @@ struct State { /// Induction hypotheses in scope, keyed by the recursive field they are /// about. Cited as `ih-FIELD`; plain `ih` names the only one. ihs: Vec<(String, Rule)>, + /// The law's own hypotheses `h1`, `h2`, ..., with the splits so far + /// substituted in. Their variables are the law's params as fixed values, + /// never pattern variables. Constructor components are derived on demand + /// by `hyps_in_scope`. + hyps: Vec<(String, Expr, Expr)>, case: String, } pub fn check_proof(goal: &Goal, steps: &[Expr], defs: &Defs, lemmas: &Lemmas) -> Outcome { + check_proof_with(goal, steps, defs, lemmas, &[]) +} + +/// `check_proof`, with `known` the laws an obligation may be discharged by. +pub fn check_proof_with( + goal: &Goal, + steps: &[Expr], + defs: &Defs, + lemmas: &Lemmas, + known: &[(String, Rule, bool)], +) -> Outcome { + check_proof_mutual(goal, steps, defs, lemmas, known, &[]) +} + +/// `check_proof_with` for one law of a `:mutual` group (see `Mutual`): +/// `partners` are the group's other laws. With partners, the proof must be +/// a single `induction` on a law param of fully known type, and the law +/// must have no hypotheses. +pub fn check_proof_mutual( + goal: &Goal, + steps: &[Expr], + defs: &Defs, + lemmas: &Lemmas, + known: &[(String, Rule, bool)], + partners: &[Mutual], +) -> Outcome { + if !partners.is_empty() { + let bad = |reason: String| Outcome::Stuck { + case: "root".into(), + term: format!("{}", goal.lhs), + reason, + }; + let Some(v) = sole_induction_var(steps) else { + return bad("a :mutual proof must be exactly one [induction VAR ...] step".into()); + }; + if !goal.params.contains(&v) || !goal.param_types.get(&v).is_some_and(ty_known) { + return bad(format!( + ":mutual induction variable `{v}` must be a law param of known type" + )); + } + if !goal.hyps.is_empty() { + return bad(":mutual laws may not have :given hypotheses".into()); + } + } let mut ctx = Ctx { defs, lemmas, + known, + partners, admitted: false, }; let st = State { @@ -984,6 +1245,12 @@ pub fn check_proof(goal: &Goal, steps: &[Expr], defs: &Defs, lemmas: &Lemmas) -> params: goal.params.to_vec(), types: goal.param_types.clone(), ihs: Vec::new(), + hyps: goal + .hyps + .iter() + .enumerate() + .map(|(i, (a, b))| (format!("h{}", i + 1), a.clone(), b.clone())) + .collect(), case: "root".into(), }; let _ = goal.law_name; @@ -996,8 +1263,9 @@ pub fn check_proof(goal: &Goal, steps: &[Expr], defs: &Defs, lemmas: &Lemmas) -> fn stuck(st: &State, reason: impl Into) -> Outcome { let mut reason = reason.into(); - if !st.ihs.is_empty() { - let names: Vec = st.ihs.iter().map(|(f, _)| format!("ih-{f}")).collect(); + let mut names: Vec = st.ihs.iter().map(|(f, _)| format!("ih-{f}")).collect(); + names.extend(st.hyps.iter().map(|(n, a, b)| format!("{n}: [= {a} {b}]"))); + if !names.is_empty() { reason = format!("{reason} [hypotheses: {}]", names.join(" ")); } Outcome::Stuck { @@ -1027,6 +1295,227 @@ fn lookup_ih(st: &State, name: &str) -> Option> { ) } +// ─── Hypotheses and obligations ──────────────────────────────────────────── +// +// A conditional law `[law N [ps] :given [[= A1 B1] ...] [= L R]]` reads +// "for all ps, A1 = B1 ∧ ... → L = R". +// +// Inside N's own proof each hypothesis is a ground rewrite rule `hK` (no +// pattern variables: its free symbols are the law's params, i.e. fixed +// unknown values), substituted by `induction`/`cases` exactly like the goal. +// `hN` rewrites in the goal's canonical form (`normalize`). Constructor +// injectivity: when a hypothesis's two sides, evaluation-normalized (total +// fns applied to constructors unfolded; meaning-preserving), are the same +// constructor applied to the same number of arguments, its K-th argument +// pair is the hypothesis `hN.K` (recursively, `hN.K.J`). Distinct +// constructors are not used (no reasoning by contradiction yet). +// +// Citing a conditional rule elsewhere (a law, or `ih` of a conditional law) +// matches its LHS as usual; each hypothesis instantiated under the match is +// an obligation, discharged right there (`discharge`). Rule params that the +// LHS does not bind may be bound by discharging against an in-scope +// hypothesis (`ih` of `[= ys zs]` given `[= [f ys] [f zs]]` picks `zs` from +// the hypothesis); anything still unbound is an error. + +/// A cited rule's name. `h1.2` parses as a dot access; spell it back. +fn rule_name(e: &Expr) -> Option { + match &e.kind { + ExprKind::Symbol(s) => Some(s.clone()), + ExprKind::DotAccess(inner, f) => Some(format!("{}.{f}", rule_name(inner)?)), + _ => None, + } +} + +/// Is `name` hypothesis syntax: `h` followed by `N(.K)*`? +fn is_hyp_name(name: &str) -> bool { + name.strip_prefix('h').is_some_and(|r| { + !r.is_empty() + && r.split('.') + .all(|p| !p.is_empty() && p.bytes().all(|c| c.is_ascii_digit())) + }) +} + +/// The hypotheses in scope: each `hN` in canonical form, then its +/// evaluation-normalized form under the same name (used only when +/// discharging obligations, since lookup takes the first), then its +/// constructor components (`hN.K`). +fn hyps_in_scope(st: &State, defs: &Defs) -> Vec<(String, Expr, Expr)> { + fn add(out: &mut Vec<(String, Expr, Expr)>, n: String, a: Expr, b: Expr, defs: &Defs) { + if let (Some((ca, xa)), Some((cb, xb))) = (ctor_of(&a, defs), ctor_of(&b, defs)) { + if ca == cb && xa.len() == xb.len() { + let comps: Vec<(Expr, Expr)> = xa.iter().cloned().zip(xb.iter().cloned()).collect(); + for (k, (x, y)) in comps.into_iter().enumerate() { + add(out, format!("{n}.{}", k + 1), x, y, defs); + } + } + } + out.push((n, a, b)); + } + let mut used = used_symbols(st); + let mut out = Vec::new(); + for (n, a, b) in &st.hyps { + let (a, b) = (normalize(a, defs), normalize(b, defs)); + out.push((n.clone(), a.clone(), b.clone())); + let mut fuel = 10_000; + let a = eval_normalize(&a, defs, &mut used, &mut fuel); + let b = eval_normalize(&b, defs, &mut used, &mut fuel); + add(&mut out, n.clone(), a, b, defs); + } + + out +} + +/// Does ground `pat` occur in `t` (up to the matcher's AC handling)? +fn occurs(pat: &Expr, t: &Expr, defs: &Defs) -> bool { + match_term(pat, t, &[], &mut HashMap::new(), defs) + || children(t).into_iter().any(|c| occurs(pat, c, defs)) +} + +/// Resolve `hN` / `hN.K` to a ground rule. `None` if not hypothesis syntax. +/// `hN` has a canonical and an evaluated form; the first with a side +/// occurring in the goal is used (either is the same equation). +fn lookup_hyp(st: &State, name: &str, defs: &Defs) -> Option> { + if !is_hyp_name(name) { + return None; + } + let cands: Vec<_> = hyps_in_scope(st, defs) + .into_iter() + .filter(|(n, _, _)| n == name) + .collect(); + let pick = cands + .iter() + .position(|(_, a, b)| occurs(a, &st.l, defs) || occurs(b, &st.l, defs)) + .unwrap_or(0); + Some( + cands + .into_iter() + .nth(pick) + .map(|(_, a, b)| Rule { + params: vec![], + lhs: a, + rhs: b, + hyps: vec![], + }) + .ok_or_else(|| stuck(st, format!("no hypothesis `{name}` in scope"))), + ) +} + +/// Discharge one obligation `[= a b]`, whose symbols in `free` are still +/// unbound rule params (pattern variables, bound into `b2` on success). +/// In order: (a) no free variables and both sides evaluate to the same +/// normal form; (b) it is an instance of an in-scope hypothesis or one of +/// its constructor components, either orientation (this is the only rule +/// that may bind free variables); (c) no free variables and it is an +/// instance of a known unconditional law, either orientation (citing an +/// admitted law taints the proof). No nested proofs: anything else fails. +fn discharge( + ctx: &mut Ctx, + hyps: &[(String, Expr, Expr)], + a: &Expr, + b: &Expr, + free: &[String], + b2: &mut HashMap, +) -> bool { + let defs = ctx.defs; + let (a, b) = (subst(a, b2, defs), subst(b, b2, defs)); + let mut used = HashSet::new(); + symbols(&a, &mut used); + symbols(&b, &mut used); + let mut fuel = 10_000; + let a = eval_normalize(&normalize(&a, defs), defs, &mut used, &mut fuel); + let b = eval_normalize(&normalize(&b, defs), defs, &mut used, &mut fuel); + let open: Vec = free + .iter() + .filter(|v| used.contains(*v) && !b2.contains_key(*v)) + .cloned() + .collect(); + if open.is_empty() && term_eq(&a, &b) { + return true; + } + for (_, l, r) in hyps { + for (x, y) in [(l, r), (r, l)] { + let mut m = b2.clone(); + if match_term(&a, x, &open, &mut m, defs) && match_term(&b, y, &open, &mut m, defs) { + *b2 = m; + return true; + } + } + } + if !open.is_empty() { + return false; + } + for (_, rule, adm) in ctx.known { + if !rule.hyps.is_empty() { + continue; + } + let (l, r) = (normalize(&rule.lhs, defs), normalize(&rule.rhs, defs)); + for (x, y) in [(&l, &r), (&r, &l)] { + let mut m = HashMap::new(); + if match_term(x, &a, &rule.params, &mut m, defs) + && match_term(y, &b, &rule.params, &mut m, defs) + { + ctx.admitted |= *adm; + return true; + } + } + } + false +} + +/// Rewrite with a conditional rule: the `at`-th match, then discharge each +/// instantiated hypothesis in order. +fn rewrite_cond(ctx: &mut Ctx, st: &State, rule: &Rule, at: usize) -> Result { + let hyps = hyps_in_scope(st, ctx.defs); + let mut used = used_symbols(st); + for (a, b) in &rule.hyps { + symbols(a, &mut used); + symbols(b, &mut used); + } + symbols(&rule.lhs, &mut used); + symbols(&rule.rhs, &mut used); + let defs = ctx.defs; + let mut on_match = |bind: &HashMap| -> Result { + // Unbound params get fresh names so they cannot be confused with + // goal symbols of the same spelling. + let mut bind = bind.clone(); + let mut fresh = Vec::new(); + let mut back = HashMap::new(); + for p in &rule.params { + if !bind.contains_key(p) { + let f = fresh_name(p, &mut used); + bind.insert(p.clone(), sym(&f)); + back.insert(f.clone(), p.clone()); + fresh.push(f); + } + } + let mut b2 = HashMap::new(); + for (a, b) in &rule.hyps { + let (a, b) = (subst(a, &bind, defs), subst(b, &bind, defs)); + if !discharge(ctx, &hyps, &a, &b, &fresh, &mut b2) { + let (a, b) = (subst(&a, &b2, defs), subst(&b, &b2, defs)); + return Err(format!("obligation [= {a} {b}] not discharged")); + } + } + let mut rv = HashSet::new(); + symbols(&rule.rhs, &mut rv); + for f in &fresh { + if !b2.contains_key(f) && rv.contains(&back[f]) { + return Err(format!( + "rule would introduce unbound variable `{}`", + back[f] + )); + } + } + let bind: HashMap = bind + .into_iter() + .map(|(k, v)| (k, subst(&v, &b2, defs))) + .collect(); + Ok(subst(&rule.rhs, &bind, defs)) + }; + rewrite_nth_by(&st.l, rule, at, &mut 0, defs, &mut on_match) + .unwrap_or_else(|| Err("rule does not match".to_string())) +} + fn closes(st: &State, defs: &Defs) -> bool { let mut used = HashSet::new(); symbols(&st.l, &mut used); @@ -1047,6 +1536,14 @@ fn used_symbols(st: &State) -> HashSet { used.insert(f.clone()); symbols(&ih.lhs, &mut used); symbols(&ih.rhs, &mut used); + for (a, b) in &ih.hyps { + symbols(a, &mut used); + symbols(b, &mut used); + } + } + for (_, a, b) in &st.hyps { + symbols(a, &mut used); + symbols(b, &mut used); } used } @@ -1068,9 +1565,10 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome .map_err(|e| stuck(&st, format!("unfold {f}: {e}")))?; } "rewrite" => { - let Some(ExprKind::Symbol(name)) = items.get(1).map(|e| &e.kind) else { + let Some(name) = items.get(1).and_then(rule_name) else { return Err(stuck(&st, "rewrite needs a rule name")); }; + let name = &name; let (mut rev, mut at) = (false, 0usize); let mut j = 2; while j < items.len() { @@ -1094,6 +1592,8 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome } let rule = if let Some(ih) = lookup_ih(&st, name) { ih? + } else if let Some(h) = lookup_hyp(&st, name, ctx.defs) { + h? } else { let (rule, adm) = (ctx.lemmas)(name).ok_or_else(|| { stuck(&st, format!("`{name}` is not a law proven earlier")) @@ -1111,15 +1611,22 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome params: rule.params, lhs: rhs, rhs: lhs, + hyps: rule.hyps, } } else { Rule { params: rule.params, lhs, rhs, + hyps: rule.hyps, } }; - st.l = rewrite(&st.l, &rule, at, ctx.defs) + let res = if rule.hyps.is_empty() { + rewrite(&st.l, &rule, at, ctx.defs) + } else { + rewrite_cond(ctx, &st, &rule, at) + }; + st.l = res .map(|l| normalize(&l, ctx.defs)) .map_err(|e| stuck(&st, format!("rewrite {name}: {e}")))?; } @@ -1218,7 +1725,7 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() sym(&ctor.name) } else { let mut v = vec![sym(&ctor.name)]; - v.extend(fields); + v.extend(fields.iter().cloned()); list(v) }; let m = HashMap::from([(var.clone(), value)]); @@ -1226,7 +1733,11 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() // Induction: one hypothesis per recursive field, each quantified over // the remaining law params. Cases: hypotheses already in scope carry // over, specialized at the split value unless they quantify `var`. - let ihs: Vec<(String, Rule)> = if induction { + // For a conditional law, `ih` is the whole law at the smaller + // argument: its hypotheses (the current `h*`, at the recursive field) + // are generalized over the other params together with the conclusion, + // and become obligations wherever `ih` is cited. + let mut ihs: Vec<(String, Rule)> = if induction { rec_fields .iter() .map(|rf| { @@ -1237,6 +1748,11 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() params: params.clone(), lhs: subst(&st.l, &im, ctx.defs), rhs: subst(&st.r, &im, ctx.defs), + hyps: st + .hyps + .iter() + .map(|(_, a, b)| (subst(a, &im, ctx.defs), subst(b, &im, ctx.defs))) + .collect(), }, ) }) @@ -1252,18 +1768,59 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() lhs: subst(&ih.lhs, &m, ctx.defs), rhs: subst(&ih.rhs, &m, ctx.defs), params: ih.params.clone(), + hyps: ih + .hyps + .iter() + .map(|(a, b)| (subst(a, &m, ctx.defs), subst(b, &m, ctx.defs))) + .collect(), } }; (f.clone(), ih) }) .collect() }; + // The root induction of a `:mutual` proof: partner hypotheses. + if induction && st.case == "root" { + for (k, f) in fields.iter().enumerate() { + let (ExprKind::Symbol(fname), Some(Some(fty))) = (&f.kind, ftys.get(k)) else { + continue; + }; + for pt in ctx.partners.iter().filter(|pt| &pt.var_ty == fty) { + let mut im = HashMap::from([(pt.var.clone(), sym(fname))]); + let mut ps = Vec::new(); + for q in pt.params.iter().filter(|q| **q != pt.var) { + let nq = fresh_name(q, &mut used); + im.insert(q.clone(), sym(&nq)); + ps.push(nq); + } + let key = if ihs.iter().any(|(k, _)| k == fname) { + format!("{fname}-{}", pt.name) + } else { + fname.clone() + }; + ihs.push(( + key, + Rule { + params: ps, + lhs: normalize(&subst(&pt.lhs, &im, ctx.defs), ctx.defs), + rhs: normalize(&subst(&pt.rhs, &im, ctx.defs), ctx.defs), + hyps: vec![], + }, + )); + } + } + } let child = State { l: normalize(&subst(&st.l, &m, ctx.defs), ctx.defs), r: normalize(&subst(&st.r, &m, ctx.defs), ctx.defs), params, types, ihs, + hyps: st + .hyps + .iter() + .map(|(n, a, b)| (n.clone(), subst(a, &m, ctx.defs), subst(b, &m, ctx.defs))) + .collect(), case: if st.case == "root" { ctor.name.clone() } else { diff --git a/crates/loon-lang/src/verify/mod.rs b/crates/loon-lang/src/verify/mod.rs index 04948e4..47b7939 100644 --- a/crates/loon-lang/src/verify/mod.rs +++ b/crates/loon-lang/src/verify/mod.rs @@ -208,11 +208,14 @@ pub struct Law { pub params: Vec, pub lhs: Expr, pub rhs: Expr, + /// `:given` hypotheses, each `[= A B]` over the params. + pub hyps: Vec<(Expr, Expr)>, pub origin: Origin, pub file: String, } -/// Parse `[law NAME [PARAMS...] [= LHS RHS]]`. +/// Parse `[law NAME [PARAMS...] [= LHS RHS]]` or the conditional form +/// `[law NAME [PARAMS...] :given [[= A1 B1] ...] [= LHS RHS]]`. pub fn parse_law(e: &Expr, origin: Origin, file: &str) -> Option> { let ExprKind::List(items) = &e.kind else { return None; @@ -234,7 +237,32 @@ pub fn parse_law(e: &Expr, origin: Origin, file: &str) -> Option Err(format!("{file}: law {name}: params must be symbols")), }) .collect::, _>>()?; - let eq = items.get(3).filter(|_| items.len() == 4); + let mut hyps = Vec::new(); + let mut rest = &items[3.min(items.len())..]; + if let Some(ExprKind::Keyword(k)) = rest.first().map(|e| &e.kind) { + if k != "given" { + return Err(format!("{file}: law {name}: unknown option `:{k}`")); + } + let Some(ExprKind::List(hs)) = rest.get(1).map(|e| &e.kind) else { + return Err(format!( + "{file}: law {name}: `:given` needs a list of [= A B]" + )); + }; + for h in hs { + match &h.kind { + ExprKind::List(v) if v.len() == 3 && head_sym(h) == Some("=") => { + hyps.push((v[1].clone(), v[2].clone())) + } + _ => { + return Err(format!( + "{file}: law {name}: hypothesis `{h}` is not [= A B]" + )) + } + } + } + rest = &rest[2.min(rest.len())..]; + } + let eq = rest.first().filter(|_| rest.len() == 1); let Some(ExprKind::List(eqv)) = eq.map(|e| &e.kind) else { return Err(format!("{file}: law {name}: expected [= LHS RHS]")); }; @@ -246,6 +274,7 @@ pub fn parse_law(e: &Expr, origin: Origin, file: &str) -> Option, pub note: Option, pub checked: usize, + /// Bounded inputs that violated a hypothesis (conditional laws only). + pub vacuous: usize, } pub struct Report { @@ -586,6 +617,8 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { let mut errors = Vec::new(); let mut laws: Vec = Vec::new(); let mut proofs: HashMap> = HashMap::new(); + // `[proof NAME :mutual OTHER ...]` / `:mutual [A B ...]` declarations. + let mut mutual_decl: HashMap> = HashMap::new(); let mut extra_fns: Vec = Vec::new(); let mut ac_forms: Vec<(Expr, String)> = Vec::new(); @@ -638,7 +671,29 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { errors.push(format!("{file}: duplicate proof `{name}`")) } Some(_) => { - proofs.insert(name.clone(), items[2..].to_vec()); + let mut steps = &items[2..]; + if matches!(steps.first().map(|x| &x.kind), Some(ExprKind::Keyword(k)) if k == "mutual") + { + let names: Vec = match steps.get(1).map(|x| &x.kind) { + Some(ExprKind::Symbol(s)) => vec![s.clone()], + Some(ExprKind::List(v)) => v + .iter() + .filter_map(|x| match &x.kind { + ExprKind::Symbol(s) => Some(s.clone()), + _ => None, + }) + .collect(), + _ => { + errors.push(format!( + "{file}: proof {name}: `:mutual` needs a law name or a list of them" + )); + vec![] + } + }; + mutual_decl.insert(name.clone(), names); + steps = &steps[2.min(steps.len())..]; + } + proofs.insert(name.clone(), steps.to_vec()); } } } @@ -677,9 +732,10 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { let mut reports: Vec = Vec::new(); let mut param_types: HashMap> = HashMap::new(); for law in &laws { - let kinds = bounded::param_kinds(&prelude, &law.params, &law.lhs, &law.rhs, &defs); - let inferred = - infer::law_param_types(&defs, &defs.fn_order, &law.params, &law.lhs, &law.rhs); + let mut eqs: Vec<(&Expr, &Expr)> = vec![(&law.lhs, &law.rhs)]; + eqs.extend(law.hyps.iter().map(|(a, b)| (a, b))); + let kinds = bounded::param_kinds(&prelude, &law.params, &eqs, &defs); + let inferred = infer::law_param_types_eqs(&defs, &defs.fn_order, &law.params, &eqs); let types = law .params .iter() @@ -717,23 +773,34 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { &kinds, &law.lhs, &law.rhs, + &law.hyps, &defs, opts.bound, opts.seed, ); let status = match (&b.counterexample, law.origin) { (Some(_), _) => "falsified", - (None, Origin::Builtins) if b.error.is_none() => "bounded", + (None, Origin::Builtins) if b.error.is_none() && b.checked > 0 => "bounded", _ => "unknown", }; + let all_vacuous = b.error.is_none() && b.checked == 0 && b.vacuous > 0; + let note = if all_vacuous { + Some(format!( + "vacuous: all {} bounded inputs violate a hypothesis; not sent to the kernel", + b.vacuous + )) + } else { + b.error.map(|e| format!("bounded: {e}")) + }; reports.push(LawReport { name: law.name.clone(), origin: law.origin, status, counterexample: b.counterexample, stuck: None, - note: b.error.map(|e| format!("bounded: {e}")), + note, checked: b.checked, + vacuous: b.vacuous, }); } @@ -784,6 +851,59 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { } } } + // `:mutual` groups (kernel::Mutual): every member must name the same + // group. A member depends on whatever any member cites; a proof citing a + // member depends on every member (none is citable before all close). + let mut groups: HashMap> = HashMap::new(); + for (n, listed) in &mutual_decl { + let mut g: Vec = listed.clone(); + g.push(n.clone()); + g.sort(); + g.dedup(); + let same = |m: &String| { + let mut h = mutual_decl.get(m).cloned().unwrap_or_default(); + h.push(m.clone()); + h.sort(); + h.dedup(); + h == g + }; + if g.len() < 2 || !g.iter().all(|m| proofs.contains_key(m) && same(m)) { + errors.push(format!( + "proof {n}: `:mutual` group {g:?} is not declared identically by every member's proof" + )); + continue; + } + groups.insert(n.clone(), g); + } + let base = deps.clone(); + for (n, g) in &groups { + let mut u: Vec = Vec::new(); + for c in g + .iter() + .flat_map(|m| base.get(m).cloned().unwrap_or_default()) + { + if !g.contains(&c) && !u.contains(&c) { + u.push(c); + } + } + deps.insert(n.clone(), u); + } + for (n, ds) in deps.iter_mut() { + let own = groups.get(n).cloned().unwrap_or_default(); + let extra: Vec = ds + .iter() + .filter_map(|c| groups.get(c)) + .flatten() + .filter(|m| !own.contains(m) && !ds.contains(m)) + .cloned() + .collect(); + for m in extra { + if !ds.contains(&m) { + ds.push(m); + } + } + } + let mut pending: HashMap = HashMap::new(); let mut order = Vec::new(); let mut state: HashMap = HashMap::new(); let mut cyclic: HashSet = HashSet::new(); @@ -836,6 +956,9 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { if rep.status == "falsified" && law.origin != Origin::Canary { continue; // falsified laws are not sent to the kernel } + if !law.hyps.is_empty() && rep.checked == 0 && rep.vacuous > 0 { + continue; // never proven by vacuity + } if cyclic.contains(name) { outcome.insert( name.clone(), @@ -859,16 +982,39 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { params: l.params.clone(), lhs: l.lhs.clone(), rhs: l.rhs.clone(), + hyps: l.hyps.clone(), }, adm, )) }; + // Laws an obligation may be discharged by: everything settled so far. + let known: Vec<(String, Rule, bool)> = laws + .iter() + .filter_map(|l| { + let adm = match outcome.get(&l.name)? { + Outcome::Proven => false, + Outcome::Admitted => true, + Outcome::Stuck { .. } => return None, + }; + Some(( + l.name.clone(), + Rule { + params: l.params.clone(), + lhs: l.lhs.clone(), + rhs: l.rhs.clone(), + hyps: l.hyps.clone(), + }, + adm, + )) + }) + .collect(); let goal = kernel::Goal { law_name: name, params: &law.params, param_types: ¶m_types[name], lhs: &law.lhs, rhs: &law.rhs, + hyps: &law.hyps, }; // Activate each relevant `ac` decl whose laws are proven (or admitted, // which taints this proof). @@ -888,11 +1034,77 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { }); } } - let o = match kernel::check_proof(&goal, &proofs[name], &pdefs, &lemmas) { + let partners: Vec = groups + .get(name) + .into_iter() + .flatten() + .filter(|m| *m != name) + .filter_map(|m| { + let l = laws.iter().find(|l| &l.name == m)?; + let var = kernel::sole_induction_var(&proofs[m])?; + Some(kernel::Mutual { + name: m.clone(), + params: l.params.clone(), + var_ty: param_types.get(m)?.get(&var)?.clone(), + var, + lhs: l.lhs.clone(), + rhs: l.rhs.clone(), + }) + }) + .collect(); + let o = match kernel::check_proof_mutual( + &goal, + &proofs[name], + &pdefs, + &lemmas, + &known, + &partners, + ) { Outcome::Proven if ac_tainted => Outcome::Admitted, o => o, }; - outcome.insert(name.clone(), o); + let Some(g) = groups.get(name) else { + outcome.insert(name.clone(), o); + continue; + }; + // A group settles when its last member has been checked: proven + // only if every member closed. + pending.insert(name.clone(), o); + if !g.iter().all(|m| pending.contains_key(m)) { + continue; + } + let failed = g + .iter() + .find(|m| matches!(pending[*m], Outcome::Stuck { .. })) + .cloned(); + let adm = g.iter().any(|m| pending[m] == Outcome::Admitted); + for m in g { + let o = match (&failed, pending.remove(m).unwrap()) { + (_, o @ Outcome::Stuck { .. }) => o, + (Some(f), _) => Outcome::Stuck { + case: "root".into(), + term: format!("{}", laws.iter().find(|l| &l.name == m).unwrap().lhs), + reason: format!("its :mutual partner `{f}` is not proven"), + }, + (None, _) if adm => Outcome::Admitted, + (None, o) => o, + }; + outcome.insert(m.clone(), o); + } + } + + // Members of a group some member of which was never checked (falsified, + // or in a cycle) stay unproven. + for (m, o) in pending.drain() { + let o = match o { + o @ Outcome::Stuck { .. } => o, + _ => Outcome::Stuck { + case: "root".into(), + term: format!("{}", laws.iter().find(|l| l.name == m).unwrap().lhs), + reason: "a :mutual partner was not checked".into(), + }, + }; + outcome.insert(m, o); } let mut sound = true; @@ -984,6 +1196,10 @@ impl Report { if l.checked > 0 { m.insert("inputs".into(), J::from(l.checked)); } + if l.vacuous > 0 { + m.insert("inputs_vacuous".into(), J::from(l.vacuous)); + } + if let Some(n) = &l.note { m.insert("note".into(), J::String(n.clone())); } diff --git a/crates/loon-lang/src/verify/tests.rs b/crates/loon-lang/src/verify/tests.rs index 46048e9..f8a962b 100644 --- a/crates/loon-lang/src/verify/tests.rs +++ b/crates/loon-lang/src/verify/tests.rs @@ -42,6 +42,7 @@ fn prove( param_types: &types, lhs: &l, rhs: &r, + hyps: &[], }; let steps = crate::parser::parse(steps).unwrap(); check_proof(&goal, &steps, defs, lemmas) @@ -85,6 +86,7 @@ fn rewrite_with_rule() { params: vec![], lhs: p("[append rest Nil]"), rhs: p("rest"), + hyps: vec![], }; let t = kernel::rewrite(&p("[Cons x [append rest Nil]]"), &ih, 0, &d).unwrap(); assert!(term_eq(&t, &p("[Cons x rest]"))); @@ -93,6 +95,7 @@ fn rewrite_with_rule() { params: vec!["a".into()], lhs: p("[f a]"), rhs: p("a"), + hyps: vec![], }; let t = kernel::rewrite(&p("[g [f 1] [f 2]]"), &r, 1, &d).unwrap(); assert!(term_eq(&t, &p("[g [f 1] 2]"))); @@ -167,6 +170,7 @@ fn admit_taints() { params: vec!["xs".into()], lhs: p("[append xs Nil]"), rhs: p("xs"), + hyps: vec![], }, true, ) @@ -482,6 +486,7 @@ fn prove_typed( param_types: &types, lhs: &l, rhs: &r, + hyps: &[], }; let steps = crate::parser::parse(steps).unwrap(); check_proof(&goal, &steps, defs, lemmas) @@ -494,6 +499,7 @@ fn exec_append_lemma(n: &str) -> Option<(Rule, bool)> { params: vec!["c1".into(), "c2".into(), "s".into()], lhs: p("[exec [append c1 c2] s]"), rhs: p("[exec c2 [exec c1 s]]"), + hyps: vec![], }, false, ) @@ -980,3 +986,655 @@ fn ac_citing_admitted_law_taints() { assert_eq!(status(&r, "add-comm").status, "admitted"); assert_eq!(status(&r, "add-rotate").status, "admitted"); } + +// ─── Conditional laws (`:given` hypotheses) ──────────────────────────────── + +const COND_DEFS: &str = r#" +[type List T [Cons T (List T)] Nil] +[type Nat Z [S Nat]] +[fn append [xs ys] + [match xs + Nil ys + [Cons x rest] [Cons x [append rest ys]]]] +[fn reverse [xs] + [match xs + Nil Nil + [Cons x rest] [append [reverse rest] [Cons x Nil]]]] +[fn length [xs] + [match xs + Nil 0 + [Cons x rest] [+ 1 [length rest]]]] +[fn add [m n] + [match m + Z n + [S k] [S [add k n]]]] +"#; + +fn cond_defs() -> Defs { + Defs::from_exprs(&crate::parser::parse(COND_DEFS).unwrap()).unwrap() +} + +/// Prove `[= lhs rhs]` given `hyps` (list params), with `known` the laws an +/// obligation may be discharged by. +fn prove_h( + params: &[&str], + hyps: &[(&str, &str)], + lhs: &str, + rhs: &str, + steps: &str, + lemmas: &kernel::Lemmas, + known: &[(String, Rule, bool)], +) -> Outcome { + let d = cond_defs(); + let params: Vec = params.iter().map(|s| s.to_string()).collect(); + let types: HashMap = params + .iter() + .map(|p| (p.clone(), ty("[List Int]"))) + .collect(); + let hyps: Vec<(Expr, Expr)> = hyps.iter().map(|(a, b)| (p(a), p(b))).collect(); + let (l, r) = (p(lhs), p(rhs)); + let goal = Goal { + law_name: "t", + params: ¶ms, + param_types: &types, + lhs: &l, + rhs: &r, + hyps: &hyps, + }; + let steps = crate::parser::parse(steps).unwrap(); + kernel::check_proof_with(&goal, &steps, &d, lemmas, known) +} + +fn rule(params: &[&str], hyps: &[(&str, &str)], lhs: &str, rhs: &str) -> Rule { + Rule { + params: params.iter().map(|s| s.to_string()).collect(), + lhs: p(lhs), + rhs: p(rhs), + hyps: hyps.iter().map(|(a, b)| (p(a), p(b))).collect(), + } +} + +fn rev_inj(n: &str) -> Option<(Rule, bool)> { + (n == "rev-inj").then(|| { + ( + rule( + &["xs", "ys"], + &[("[reverse xs]", "[reverse ys]")], + "xs", + "ys", + ), + false, + ) + }) +} + +fn stuck_with(o: &Outcome, needle: &str) -> bool { + matches!(o, Outcome::Stuck { reason, .. } if reason.contains(needle)) +} + +#[test] +fn hypothesis_usable_only_in_its_own_proof() { + // With the hypothesis: proven. + let o = prove_h( + &["xs", "ys"], + &[("xs", "ys")], + "[append xs Nil]", + "[append ys Nil]", + "[rewrite h1]", + &none, + &[], + ); + assert_eq!(o, Outcome::Proven); + // Without (another law's proof): `h1` does not exist. + let o = prove_h( + &["xs", "ys"], + &[], + "[append xs Nil]", + "[append ys Nil]", + "[rewrite h1]", + &none, + &[], + ); + assert!(stuck_with(&o, "no hypothesis `h1`"), "{o:?}"); + // Through the pipeline: a proof citing another law's hypothesis. + let dir = tmp_dir( + "cond-scope", + &[ + ("defs.oo", COND_DEFS), + ( + "laws/l.oo", + "[law cons-inj [x xs ys] :given [[= [Cons x xs] [Cons x ys]]] [= xs ys]] + [law borrow [xs ys] [= [append xs Nil] [append ys Nil]]]", + ), + ( + "proofs/p.oo", + "[proof cons-inj [rewrite h1.2]] [proof borrow [rewrite h1]]", + ), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + assert_eq!(status(&r, "cons-inj").status, "proven"); + assert_ne!(status(&r, "borrow").status, "proven"); +} + +#[test] +fn hypothesis_rewrites_only_its_exact_instance() { + // h1 is about `xs`, not a pattern: it must not rewrite [reverse ys]. + let o = prove_h( + &["xs", "ys"], + &[("[reverse xs]", "Nil")], + "[reverse ys]", + "Nil", + "[rewrite h1]", + &none, + &[], + ); + assert!(stuck_with(&o, "does not match"), "{o:?}"); + // Induction substitutes into hypotheses like into the goal: in the Cons + // case h1 is about [Cons x rest], not xs. + let o = prove_h( + &["xs", "ys"], + &[("[append xs ys]", "ys")], + "[append xs ys]", + "ys", + "[cases xs [Nil] [Cons [rewrite h1]]]", + &none, + &[], + ); + assert_eq!(o, Outcome::Proven, "{o:?}"); +} + +#[test] +fn citing_conditional_law_needs_its_obligation() { + let o = prove_h( + &["a", "b"], + &[], + "a", + "b", + "[rewrite rev-inj]", + &rev_inj, + &[], + ); + assert!(stuck_with(&o, "obligation [= [reverse a]"), "{o:?}"); +} + +#[test] +fn obligation_discharged_by_hypothesis() { + let o = prove_h( + &["a", "b"], + &[("[reverse a]", "[reverse b]")], + "a", + "b", + "[rewrite rev-inj]", + &rev_inj, + &[], + ); + assert_eq!(o, Outcome::Proven, "{o:?}"); + // Either orientation of the hypothesis. + let o = prove_h( + &["a", "b"], + &[("[reverse b]", "[reverse a]")], + "a", + "b", + "[rewrite rev-inj]", + &rev_inj, + &[], + ); + assert_eq!(o, Outcome::Proven, "{o:?}"); +} + +#[test] +fn obligation_discharged_by_normalization_or_proven_law() { + let cond = |n: &str| match n { + "by-eval" => Some(( + rule(&["xs"], &[("[append Nil xs]", "xs")], "[h xs]", "xs"), + false, + )), + "by-law" => Some(( + rule(&["xs"], &[("[append xs Nil]", "xs")], "[h xs]", "xs"), + false, + )), + _ => None, + }; + // (a) both sides evaluate to the same term + let o = prove_h(&["a"], &[], "[h a]", "a", "[rewrite by-eval]", &cond, &[]); + assert_eq!(o, Outcome::Proven, "{o:?}"); + // needs induction, not evaluation: stuck without a known law + let o = prove_h(&["a"], &[], "[h a]", "a", "[rewrite by-law]", &cond, &[]); + assert!(stuck_with(&o, "obligation [= [append a Nil] a]"), "{o:?}"); + // (c) an instance of a proven law + let known = vec![( + "append-nil".to_string(), + rule(&["xs"], &[], "[append xs Nil]", "xs"), + false, + )]; + let o = prove_h(&["a"], &[], "[h a]", "a", "[rewrite by-law]", &cond, &known); + assert_eq!(o, Outcome::Proven, "{o:?}"); + // ... and an admitted one taints + let known = vec![( + "append-nil".to_string(), + rule(&["xs"], &[], "[append xs Nil]", "xs"), + true, + )]; + let o = prove_h(&["a"], &[], "[h a]", "a", "[rewrite by-law]", &cond, &known); + assert_eq!(o, Outcome::Admitted, "{o:?}"); +} + +#[test] +fn constructor_injectivity_on_hypotheses() { + let o = prove_h( + &["xs", "ys"], + &[("[Cons a xs]", "[Cons b ys]")], + "xs", + "ys", + "[rewrite h1.2]", + &none, + &[], + ); + assert_eq!(o, Outcome::Proven, "{o:?}"); + // no third component; distinct constructors give no components + let o = prove_h( + &["xs", "ys"], + &[("[Cons a xs]", "[Cons b ys]")], + "xs", + "ys", + "[rewrite h1.3]", + &none, + &[], + ); + assert!(stuck_with(&o, "no hypothesis `h1.3`"), "{o:?}"); + let o = prove_h( + &["xs", "ys"], + &[("[Cons a xs]", "Nil")], + "xs", + "ys", + "[rewrite h1.2]", + &none, + &[], + ); + assert!(stuck_with(&o, "no hypothesis `h1.2`"), "{o:?}"); +} + +#[test] +fn ih_of_conditional_law_carries_obligations() { + let law = + "[law append-cancel-left [xs ys zs] :given [[= [append xs ys] [append xs zs]]] [= ys zs]]"; + let dir = tmp_dir( + "cond-ih", + &[ + ("defs.oo", COND_DEFS), + ("laws/l.oo", law), + ( + "proofs/p.oo", + "[proof append-cancel-left [induction xs [Nil [rewrite h1]] [Cons [rewrite ih]]]]", + ), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + assert_eq!(status(&r, "append-cancel-left").status, "proven"); + // With the hypothesis dropped from the ih's reach (cases: no ih), stuck. + let o = prove_h( + &["xs", "ys", "zs"], + &[("[append xs ys]", "[append xs zs]")], + "ys", + "zs", + "[induction xs [Nil [rewrite h1]] [Cons [rewrite ih :at 0] [rewrite h1]]]", + &none, + &[], + ); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); +} + +#[test] +fn vacuous_conditional_law_is_not_proven() { + let dir = tmp_dir( + "cond-vacuous", + &[ + ("defs.oo", COND_DEFS), + ( + "laws/l.oo", + "[law vac [xs] :given [[= [Cons 1 xs] Nil]] [= xs [Cons 2 Nil]]]", + ), + ("proofs/p.oo", "[proof vac [admit]]"), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + let v = status(&r, "vac"); + assert_eq!(v.status, "unknown"); + assert_eq!(v.checked, 0); + assert!(v.vacuous > 0); + assert!(v.note.as_deref().unwrap().contains("vacuous")); + let j = r.to_json(); + let jl = j["laws"] + .as_array() + .unwrap() + .iter() + .find(|l| l["name"] == "vac") + .unwrap(); + assert!(jl["inputs_vacuous"].as_u64().unwrap() > 0); +} + +#[test] +fn false_conditional_law_falsified_and_unprovable() { + let law = "[law bogus [xs ys] :given [[= [length xs] [length ys]]] [= xs ys]]"; + let dir = tmp_dir( + "cond-bogus", + &[ + ("defs.oo", COND_DEFS), + ("laws/l.oo", law), + ("proofs/p.oo", "[proof bogus [rewrite h1]]"), + ], + ); + let r = run_dir(&dir, &Options::default()).unwrap(); + let b = status(&r, "bogus"); + assert_eq!(b.status, "falsified"); + assert!(b.vacuous > 0, "inputs with unequal lengths are vacuous"); + // The kernel, run directly: h1 is about [length xs], not xs. + let o = prove_h( + &["xs", "ys"], + &[("[length xs]", "[length ys]")], + "xs", + "ys", + "[rewrite h1]", + &none, + &[], + ); + assert!(stuck_with(&o, "does not match"), "{o:?}"); +} + +// ─── Nested recursion: mutual totality, mutual induction, the meta corpus ── + +const META_DEFS: &str = include_str!("../../../../verify/meta/defs.oo"); + +fn meta_defs() -> Defs { + Defs::from_exprs(&crate::parser::parse(META_DEFS).unwrap()).unwrap() +} + +#[test] +fn totality_accepts_mutual_groups_that_decrease() { + let d = meta_defs(); + for f in [ + "subst", + "subst-list", + "matcht", + "match-list", + "term-eq", + "terms-eq", + "apply-match", + "compose", + ] { + assert!(d.total.contains(f), "{f} should be total"); + } + let src = r#" +[type Nat [S Nat] Z] +[fn ev [n] [match n Z Z [S k] [od k]]] +[fn od [n] [match n Z Z [S k] [ev k]]] +[fn ev-bad [n] [match n Z Z [S k] [od-bad n]]] +[fn od-bad [n] [match n Z Z [S k] [ev-bad k]]] +[fn f [a b] [match a Z Z [S k] [g b k]]] +[fn g [a b] [match b Z Z [S k] [f k a]]] +[fn f-bad [a b] [match a Z Z [S k] [g-bad b k]]] +[fn g-bad [a b] [match b Z Z [S k] [f-bad a k]]] +[fn calls-bad [n] [ev-bad n]] +"#; + let d = Defs::from_exprs(&crate::parser::parse(src).unwrap()).unwrap(); + assert!(d.total.contains("ev") && d.total.contains("od")); + // od-bad passes n itself back: no strict decrease around the cycle. + assert!(!d.total.contains("ev-bad") && !d.total.contains("od-bad")); + // The measure may sit at a different position in each member... + assert!(d.total.contains("f") && d.total.contains("g")); + // ...but it must be one position per fn: here f's would have to be b. + assert!(!d.total.contains("f-bad") && !d.total.contains("g-bad")); + assert!(!d.total.contains("calls-bad")); +} + +#[test] +fn infer_types_mutually_recursive_fns() { + let d = meta_defs(); + let ts = super::infer::law_param_types( + &d, + &d.fn_order, + &["t".into(), "s".into()], + &p("[subst t s]"), + &p("t"), + ) + .unwrap(); + let ts: Vec = ts.iter().map(super::infer::to_ty).collect(); + assert_eq!( + ts, + vec![kernel::Ty::named("Term"), kernel::Ty::named("Subst")] + ); +} + +#[test] +fn typed_generator_enumerates_nested_generics() { + use crate::types::Type; + let d = meta_defs(); + let subst = Type::Con("Subst".into(), vec![]); + let s6: Vec = super::bounded::typed_values(&subst, 6, &d, 0) + .iter() + .map(|e| e.to_string()) + .collect(); + assert!(s6.contains(&"[Subst [Cons [Pair [Sym Z] [V [Sym Z]]] Nil]]".to_string())); + let term = Type::Con("Term".into(), vec![]); + let t2: Vec = super::bounded::typed_values(&term, 2, &d, 0) + .iter() + .map(|e| e.to_string()) + .collect(); + assert!(t2.contains(&"[C [Sym Z] Nil]".to_string())); +} + +/// Check one law of a mutual group in the kernel directly. +fn prove_mutual( + d: &Defs, + (params, lhs, rhs): (&[(&str, &str)], &str, &str), + steps: &str, + partners: &[kernel::Mutual], +) -> Outcome { + let names: Vec = params.iter().map(|(n, _)| n.to_string()).collect(); + let types: HashMap = + params.iter().map(|(n, t)| (n.to_string(), ty(t))).collect(); + let (l, r) = (p(lhs), p(rhs)); + let goal = Goal { + law_name: "t", + params: &names, + param_types: &types, + lhs: &l, + rhs: &r, + hyps: &[], + }; + let steps = crate::parser::parse(steps).unwrap(); + kernel::check_proof_mutual(&goal, &steps, d, &none, &[], partners) +} + +fn partner( + name: &str, + params: &[&str], + var: &str, + var_ty: &str, + l: &str, + r: &str, +) -> kernel::Mutual { + kernel::Mutual { + name: name.into(), + params: params.iter().map(|s| s.to_string()).collect(), + var: var.into(), + var_ty: ty(var_ty), + lhs: p(l), + rhs: p(r), + } +} + +#[test] +fn mutual_induction_supplies_hypotheses_across_types() { + let d = meta_defs(); + let term_law = partner("pt", &["t"], "t", "Term", "[subst t [Subst Nil]]", "t"); + let list_law = partner( + "pl", + &["ts"], + "ts", + "[List Term]", + "[subst-list ts [Subst Nil]]", + "ts", + ); + let o = prove_mutual( + &d, + (&[("t", "Term")], "[subst t [Subst Nil]]", "t"), + "[induction t [V] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]", + std::slice::from_ref(&list_law), + ); + assert_eq!(o, Outcome::Proven); + let o = prove_mutual( + &d, + ( + &[("ts", "[List Term]")], + "[subst-list ts [Subst Nil]]", + "ts", + ), + "[induction ts [Nil] [Cons [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]]]", + std::slice::from_ref(&term_law), + ); + assert_eq!(o, Outcome::Proven); + // Without the partner there is no hypothesis for the (List Term) field. + let o = prove_mutual( + &d, + (&[("t", "Term")], "[subst t [Subst Nil]]", "t"), + "[induction t [V] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]", + &[], + ); + assert!(matches!(o, Outcome::Stuck { .. })); + // A mutual proof must be a single induction. + let o = prove_mutual( + &d, + (&[("t", "Term")], "[subst t [Subst Nil]]", "t"), + "[unfold subst]", + std::slice::from_ref(&list_law), + ); + assert!(matches!(&o, Outcome::Stuck { reason, .. } if reason.contains("exactly one"))); +} + +#[test] +fn mutual_induction_cannot_prove_a_false_pair() { + // subst t s = t and subst-list ts s = ts are both false. The list half + // closes relative to its partner (that is all a member proof shows), but + // the term half cannot: at a variable, subst consults s. + let d = meta_defs(); + let term_law = partner("bt", &["t", "s"], "t", "Term", "[subst t s]", "t"); + let list_law = partner( + "bl", + &["ts", "s"], + "ts", + "[List Term]", + "[subst-list ts s]", + "ts", + ); + let o = prove_mutual( + &d, + ( + &[("ts", "[List Term]"), ("s", "Subst")], + "[subst-list ts s]", + "ts", + ), + "[induction ts [Nil] [Cons [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]]]", + std::slice::from_ref(&term_law), + ); + assert_eq!(o, Outcome::Proven); + for steps in [ + "[induction t [V] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]", + "[induction t [V [unfold subst] [cases s [Subst]]] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]", + "[induction t [V [rewrite ih-rest]] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]", + ] { + let o = prove_mutual( + &d, + (&[("t", "Term"), ("s", "Subst")], "[subst t s]", "t"), + steps, + std::slice::from_ref(&list_law), + ); + assert!(matches!(o, Outcome::Stuck { .. }), "{steps}: {o:?}"); + } +} + +const META_LAWS: &str = r#" +[law subst-empty [t] [= [subst t [Subst Nil]] t]] +[law subst-list-empty [ts] [= [subst-list ts [Subst Nil]] ts]] +[law use-empty [f ts] [= [subst [C f ts] [Subst Nil]] [C f ts]]] +"#; + +const META_LIST_PROOF: &str = "[proof subst-list-empty :mutual subst-empty + [induction ts [Nil] [Cons [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]]]]"; + +const META_USE_PROOF: &str = "[proof use-empty [rewrite subst-empty]]"; + +fn meta_run(tag: &str, term_proof: &str, list_proof: &str) -> Report { + let proofs = format!("{term_proof}\n{list_proof}\n{META_USE_PROOF}"); + let dir = tmp_dir( + tag, + &[ + ("defs.oo", META_DEFS), + ("canary.oo", "[law canary-subst [t s] [= [subst t s] t]]"), + ("laws/l.oo", META_LAWS), + ("proofs/p.oo", &proofs), + ], + ); + run_dir(&dir, &Options::default()).unwrap() +} + +#[test] +fn pipeline_mutual_group_proves_together() { + let r = meta_run( + "mutual-ok", + "[proof subst-empty :mutual subst-list-empty + [induction t [V] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]]", + META_LIST_PROOF, + ); + assert!(r.errors.is_empty(), "{:?}", r.errors); + assert!(r.sound); + assert_eq!(status(&r, "subst-empty").status, "proven"); + assert_eq!(status(&r, "subst-list-empty").status, "proven"); + // Citable once the whole group has closed. + assert_eq!(status(&r, "use-empty").status, "proven"); + // The bounded generator reaches Term and Subst values. + assert_eq!(status(&r, "canary-subst").status, "falsified"); +} + +#[test] +fn pipeline_mutual_group_fails_together() { + // The term half is incomplete: the list half closes on its own, but + // neither is proven, and nothing citing them is either. + let r = meta_run( + "mutual-stuck", + "[proof subst-empty :mutual subst-list-empty + [induction t [V] [C [unfold subst]] [A [unfold subst] [rewrite ih-rest]]]]", + META_LIST_PROOF, + ); + assert!(r.sound); + assert_eq!(status(&r, "subst-empty").status, "unknown"); + let l = status(&r, "subst-list-empty"); + assert_eq!(l.status, "unknown"); + assert!(l + .stuck + .as_ref() + .unwrap() + .2 + .contains("partner `subst-empty`")); + assert_eq!(status(&r, "use-empty").status, "unknown"); + // A member may not cite its partner by name inside the group. + let r = meta_run( + "mutual-cite", + "[proof subst-empty :mutual subst-list-empty + [induction t [V] [C [unfold subst] [rewrite subst-list-empty]] [A [unfold subst] [rewrite ih-rest]]]]", + META_LIST_PROOF, + ); + assert_eq!(status(&r, "subst-empty").status, "unknown"); + assert_eq!(status(&r, "subst-list-empty").status, "unknown"); + // Groups must be declared by every member. + let r = meta_run( + "mutual-asym", + "[proof subst-empty + [induction t [V] [C [unfold subst] [rewrite ih-rest]] [A [unfold subst] [rewrite ih-rest]]]]", + META_LIST_PROOF, + ); + assert!(!r.errors.is_empty()); + assert_eq!(status(&r, "subst-empty").status, "unknown"); + assert_eq!(status(&r, "subst-list-empty").status, "unknown"); +} diff --git a/docs/plans/2026-10-28-self-verifying-kernel.md b/docs/plans/2026-10-28-self-verifying-kernel.md new file mode 100644 index 0000000..b01c409 --- /dev/null +++ b/docs/plans/2026-10-28-self-verifying-kernel.md @@ -0,0 +1,179 @@ +# The kernel proves itself + +*October 2026 — design and ladder; companion to `2026-10-28-verify-autoresearch.md`* + +## The claim + +Model the proof kernel in Loon, define what it means for a law to hold, and +prove in Loon that every proof object the model accepts is of a law that +holds. Then run that proof through `loon prove`. + +It is circular in the way every self-verified checker is (Milawa, 2009, did +it by hand). The payoff is not an escape from trust but a shrinking of it: +today trust is "read `crates/loon-lang/src/verify/*.rs`". After, trust is +"the Loon evaluator agrees with `verify/meta/defs.oo` on one file", and +every soft spot in the Rust kernel (AC canonicalization, commutative +matching, inferred field types in `cases`) becomes a lemma that either goes +through or names the bug. + +Nobody has done this where the proofs come from search rather than a human. + +## The model + +First-order terms, no lambdas, so no beta. Everything structural. + +```loon +[type Term [V Sym] [C Sym (List Term)] [A Sym (List Term)]] +;; variable, constructor application, function application + +[type Fn [Def Sym (List Sym) Term]] ; name, params, body (a match tree is a Term) +[type Prog [Prog (List Fn)]] +[type Subst [Subst (List (Pair Sym Term))]] + +[fn subst [t s]] ; capture-free: no binders in Term +[fn matcht [pat t]] ; Option Subst, first-order +[fn step [prog t]] ; one leftmost-outermost reduction +[fn evaln [n prog t]] ; n steps, structural on n (the fuel) +``` + +A law `[= L R]` with params `xs` *holds* in `prog` when for every closing +substitution σ and every fuel n large enough, `evaln n prog (subst L σ)` and +`evaln n prog (subst R σ)` reach the same normal form. Fuel keeps every +function in the model structurally recursive; "large enough" is quantified +by a law param, so no analysis sneaks in. + +Proof objects are the ADT the Rust kernel already parses, re-stated: + +```loon +[type Step [Unfold Sym] [Rewrite Rule Bool Nat] [Induction Sym (List Case)] [Cases Sym (List Case)] [Refl] [Admit]] +[type Case [Case Sym (List Step)]] +[type Rule [Ih Sym] [Lemma Sym]] +[fn check [prog lemmas goal steps]] ; the model kernel: Bool +``` + +Soundness, the thing to prove: + +``` +check prog lemmas goal steps = T +∧ every lemma holds +∧ no Admit in steps +→ goal holds +``` + +That is an implication, so **hypotheses in laws** come first (rung 1). + +## The ladder + +Each rung is a `verify/meta/` corpus addition with its own `loon prove` +run, so there is a demo at every step. + +0. **Done today**: the Rust kernel, `loon prove`, 22 laws, AC closing. +1. **Hypotheses in laws.** `[law name [params] :given [[= a b] ...] [= L R]]`. + Hypotheses are rewrite rules available only inside that proof; citing + a hypothesis-carrying law instantiates its hypotheses as obligations + that must themselves be proven or match an in-scope hypothesis. Kernel + change in `verify/kernel.rs` and `mod.rs`; grammar in the main plan. +2. **Substitution lemmas** (no hypotheses needed). `subst (subst t s1) s2 = + subst t (compose s1 s2)`, `subst t empty = t`, and the match soundness + trick stated unconditionally: `apply-match p t = t` where `apply-match` + substitutes the match result back into `p` and returns `t` on failure. +3. **Evaluation lemmas.** Fuel monotonicity: once a term reaches normal + form at fuel n it stays there at n+k. Unfold correctness: one `Unfold` + step on a redex is one `step` of the evaluator. +4. **Rewrite soundness.** If a rule holds, rewriting a subterm with it + preserves holding. Needs rung 1 and a congruence lemma: evaluation + respects subterm replacement. +5. **Induction soundness.** For the ADTs in the model program, the case + split plus hypotheses is the structural induction principle. Needs + well-founded induction in the Rust kernel to even state (induction on + proof objects is structural; induction *about* induction over an + arbitrary ADT needs a size measure). +6. **The theorem.** Soundness of `check` by structural induction on steps, + assembling rungs 2 to 5. +7. **Close the loop.** Encode the proof of rung 6 as a proof object the + model accepts; run `loon prove` on it; publish the two hashes. + +Deliberately out of scope for the model, and therefore admitted gaps in the +self-check: AC canonicalization, commutative matching, the HM in +`infer.rs`. Each gets a rung later or stays a stated trust assumption. The +first version of the theorem is about the *core* kernel: unfold, rewrite, +induction, cases, refl. + +## What the Rust kernel must grow + +- Hypotheses in laws (rung 1). +- `Pair` and `Option` in `defs.oo`-style ADTs; `Bool` as `[type B T F]`. +- Well-founded induction, or a size-measure induction principle (rung 5). +- Nested structural recursion through `List Term` (a `Term` holds a list of + `Term`s): the totality checker must accept recursion through `map`-like + helpers, and `induction` on `Term` must supply hypotheses for the elements + of a `List Term` field. Today a field like `(List Rose)` gets no + hypothesis. Rung 2 will hit this on the first lemma. + +## Rung 2, as built + +`verify/meta/` (`loon prove verify/meta`): `defs.oo` declares `Term`, `Sym` +(naturals), `Pair`, `Option`, `B` (`T`/`F`), `Subst` (an association list), +and `subst`/`subst-list`, `apply-var`, `map-rhs`, `compose`, `term-eq`/ +`terms-eq`, `matcht`/`match-list` (non-linear: a repeated variable must +match equal terms, checked by `add-binding`/`union`), `apply-match`. +Proven: `subst-empty` and `subst-compose`, each with its list version, +plus helper lemmas (`nat-eq-refl`, `sym-eq-refl`, `subst-if`, +`subst-apply-var`) and `apply-match-var` (match soundness for a variable +pattern). `compose s1 s2` is `s1`'s bindings with `s2` applied, then all of +`s2`'s; lookup takes the first binding, which gives the usual +composition. + +Still open: `apply-match` in general (bounded-checked on ~1100 inputs, not +proven). After the constructor test the goal is +`[match [if-b [sym-eq f g] [match-list ps ts] None] ...]`: it needs +`sym-eq f g = T → f = g` and `match-list ps ts = Some s → subst-list ps s += ts`, implications, i.e. rung 1's `:given` plus case analysis on a +non-variable scrutinee (`cases` only splits variables today). + +Kernel growth it forced: + +- **Totality of mutually recursive groups.** The call graph's strongly + connected components are checked together: a group is total when its + outside callees are total and some choice of one *measure* param per member + makes every call between members pass, in the callee's measure position, a + pattern-bound strict subterm of the caller's measure param. The measure + argument's size strictly decreases along every call chain in the group. + For one fn this is the old rule. `subst` (measure `t`) calls + `subst-list` on the `ts` field; `subst-list` (measure `ts`) calls `subst` + on the head and itself on the tail. +- **Mutual induction.** `[proof P :mutual Q [induction t ...]]` and + `[proof Q :mutual P [induction ts ...]]` (or `:mutual [Q R ...]`) form a + group, declared identically by every member. Each member's proof must be + one `induction` on a param of fully known type, and the laws unconditional. + In an induction case of P, a constructor field whose type is exactly Q's + induction type gets Q at that field as `ih-FIELD` (Q's other params + quantified, renamed apart); P's own `ih` is as before. Sound by strong + induction on value size: each case uses a group law only at a constructor + field of the value being split. The driver makes no member citable (nor + any proof citing one checkable) until every member closed, and marks all + unproven if any is stuck. A false pair (`subst t s = t` with its list + version) fails: the list half closes relative to the term half, the term + half cannot. +- **Inference of mutually recursive fns.** `infer.rs` types each component + together (monomorphic inside, generalized after), so laws over `subst` + get param types and bounded inputs. +- The bounded generator already enumerated `Term`, `Subst` and `(List (Pair + Sym Term))` by size; redeclaring `Option` in defs.oo does not clash with + the evaluation program's prelude (no renaming needed). + +For rung 3: a `Fn`/`Prog` model with `step` and fuel-indexed `evaln`; +`cases` on a non-variable scrutinee (or a `B`-valued lemma split), which +`apply-match` needs too; and `:given` (rung 1) inside mutual groups, which +the mutual scheme refuses today. + +## Risks, said plainly + +- The model kernel will not be the Rust kernel. It is a re-statement. The + honest claim is "the Rust kernel implements the model", checked by running + both on the same corpus and comparing verdicts, not by proof. +- Fuel-based evaluation makes "holds" a statement about all large fuels. The + lemmas get a `fuel` param everywhere. Tedious, not deep. +- Nested induction (Term through List Term) is where the current totality + checker and induction rule are weakest. Expect rung 2 to be mostly kernel + work. diff --git a/docs/plans/2026-10-28-verify-autoresearch.md b/docs/plans/2026-10-28-verify-autoresearch.md index bca8b9f..d169df7 100644 --- a/docs/plans/2026-10-28-verify-autoresearch.md +++ b/docs/plans/2026-10-28-verify-autoresearch.md @@ -175,6 +175,46 @@ Semantics, per goal `[= L R]`: *earlier in dependency order*. Citing an `admitted` law makes the citing proof `admitted`. Cycles are rejected. +Conditional laws (hypotheses): + +``` +law := [law NAME [PARAMS...] [= L R]] + | [law NAME [PARAMS...] :given [[= A1 B1] [= A2 B2] ...] [= L R]] +RULE := ... + | hN ; the law's own N-th hypothesis (1-based) + | hN.K ; K-th constructor component of hN (also hN.K.J) +``` + +Reads "for all PARAMS, A1 = B1 ∧ ... → L = R". Rules: + +- Inside the law's own proof, `hN` is a ground rewrite rule: its free + symbols are the law's params as fixed values, never pattern variables, so + `[= [f xs] ys]` rewrites exactly `[f xs]`. `induction`/`cases` + substitute into hypotheses exactly as into the goal. `hN` is cited only in + its own proof; elsewhere `hN` is "no hypothesis in scope". Stuck reports + list hypotheses in scope. +- Constructor injectivity: if `hN`'s sides, evaluation-normalized, are the + same constructor with the same arity, its K-th argument pair is `hN.K` + (recursively). Distinct constructors yield nothing (no ex falso yet). +- Citing a conditional law (or the `ih` of one) matches its LHS as usual; + each hypothesis instantiated under the match is an obligation `[= A B]` + discharged on the spot by, in order: (a) both sides evaluation-normalize + to the same term; (b) it is an instance of an in-scope `hN`/`hN.K`, + either orientation; (c) it is an instance of an already-settled + unconditional law, either orientation (an admitted one taints). Params + the LHS leaves unbound may be bound only by (b); still unbound in the RHS + is an error. Otherwise the step is stuck with the obligation printed. + No nested proof blocks for obligations in this rung, and (c) only uses + laws already settled when the citing proof runs (it adds no dependency + edge), and never conditional ones. +- Induction on a conditional law: `ih` is the whole law at the recursive + field, hypotheses generalized over the other params together with the + conclusion; they become obligations wherever `ih` is cited. +- Bounded evaluation skips inputs that violate a hypothesis and counts them + as `inputs_vacuous`; only inputs satisfying every hypothesis can falsify. + If every input is vacuous the law is `unknown` with a note and is not + sent to the kernel: never proven by vacuity. + AC declarations (a top-level form in `laws/*.oo`): ``` diff --git a/verify/laws/cond.oo b/verify/laws/cond.oo new file mode 100644 index 0000000..cf2ccf7 --- /dev/null +++ b/verify/laws/cond.oo @@ -0,0 +1,21 @@ +; Conditional laws: `:given` hypotheses over the law's params. + +[law cons-inj [x xs ys] + :given [[= [Cons x xs] [Cons x ys]]] + [= xs ys]] + +[law append-cancel-left [xs ys zs] + :given [[= [append xs ys] [append xs zs]]] + [= ys zs]] + +[law rev-inj [xs ys] + :given [[= [reverse xs] [reverse ys]]] + [= xs ys]] + +[law rev-inj-append [xs ys zs] + :given [[= [reverse xs] [reverse ys]]] + [= [append xs zs] [append ys zs]]] + +[law add-cancel-left [m n p] + :given [[= [add m n] [add m p]]] + [= n p]] diff --git a/verify/meta/canary.oo b/verify/meta/canary.oo new file mode 100644 index 0000000..3765ed2 --- /dev/null +++ b/verify/meta/canary.oo @@ -0,0 +1,4 @@ +; Canaries: false laws. If the kernel ever accepts one, the run is unsound. + +[law canary [] [= T F]] +[law canary-subst [t s] [= [subst t s] t]] diff --git a/verify/meta/defs.oo b/verify/meta/defs.oo new file mode 100644 index 0000000..57f3c0b --- /dev/null +++ b/verify/meta/defs.oo @@ -0,0 +1,177 @@ +; Meta-model of the proof kernel's term language (rung 2 of +; docs/plans/2026-10-28-self-verifying-kernel.md). Frozen: its hash is in +; every report. First-order terms only: no binders, so substitution is +; capture-free by construction. +; +; Conventions forced by the kernel and the VM (see verify/defs.oo): +; one constructor pattern level per `match` (the VM does not bind variables +; in nested constructor patterns), so pairs and wrappers are taken apart by +; an inner `match`. + +[type List T [Cons T (List T)] Nil] +[type Nat [S Nat] Z] +[type B T F] +[type Pair X Y [Pair X Y]] +[type Option X [Some X] None] + +; Symbols are naturals. +[type Sym [Sym Nat]] + +; Variable, constructor application, function application. +[type Term [V Sym] [C Sym (List Term)] [A Sym (List Term)]] + +; A substitution is an association list; the first binding of a symbol wins. +[type Subst [Subst (List (Pair Sym Term))]] + +[fn if-b [b u w] + [match b + T u + F w]] + +[fn and-b [a b] + [match a + T b + F F]] + +[fn nat-eq [m n] + [match m + Z [match n + Z T + [S b] F] + [S a] [match n + Z F + [S b] [nat-eq a b]]]] + +[fn sym-eq [a b] + [match a + [Sym m] [match b + [Sym n] [nat-eq m n]]]] + +[fn append [xs ys] + [match xs + Nil ys + [Cons x rest] [Cons x [append rest ys]]]] + +; The binding of `x` in `bs`, if any. +[fn lookup [x bs] + [match bs + Nil None + [Cons p rest] [match p + [Pair y u] [if-b [sym-eq x y] [Some u] [lookup x rest]]]]] + +; `lookup` with the variable itself as the default: what `subst` does at a +; variable. A separate fn so that `subst` never matches on an Option. +[fn apply-var [x bs] + [match bs + Nil [V x] + [Cons p rest] [match p + [Pair y u] [if-b [sym-eq x y] u [apply-var x rest]]]]] + +; Substitution, by nested structural recursion through the (List Term) +; field: `subst` and `subst-list` are one mutually recursive group. +[fn subst [t s] + [match t + [V x] [match s + [Subst bs] [apply-var x bs]] + [C f ts] [C f [subst-list ts s]] + [A f ts] [A f [subst-list ts s]]]] + +[fn subst-list [ts s] + [match ts + Nil Nil + [Cons t rest] [Cons [subst t s] [subst-list rest s]]]] + +; Apply `s` to every right-hand side of `bs`. +[fn map-rhs [bs s] + [match bs + Nil Nil + [Cons p rest] [match p + [Pair y u] [Cons [Pair y [subst u s]] [map-rhs rest s]]]]] + +; compose s1 s2 = s2 after s1: s1's bindings with s2 applied, then all of +; s2's (shadowed where s1 already binds the symbol). +[fn compose [s1 s2] + [match s1 + [Subst bs1] [match s2 + [Subst bs2] [Subst [append [map-rhs bs1 s2] bs2]]]]] + +; Structural term equality. +[fn term-eq [a b] + [match a + [V x] [match b + [V y] [sym-eq x y] + [C g us] F + [A g us] F] + [C f ts] [match b + [V y] F + [C g us] [and-b [sym-eq f g] [terms-eq ts us]] + [A g us] F] + [A f ts] [match b + [V y] F + [C g us] F + [A g us] [and-b [sym-eq f g] [terms-eq ts us]]]]] + +[fn terms-eq [ts us] + [match ts + Nil [match us + Nil T + [Cons u ur] F] + [Cons t rest] [match us + Nil F + [Cons u ur] [and-b [term-eq t u] [terms-eq rest ur]]]]] + +; Add x := u to bs, failing if bs binds x to something else. +[fn add-binding [x u bs] + [match [lookup x bs] + None [Some [Cons [Pair x u] bs]] + [Some w] [if-b [term-eq u w] [Some bs] None]]] + +; Consistent union of two binding lists. +[fn union [bs1 bs2] + [match bs1 + Nil [Some bs2] + [Cons p rest] [match p + [Pair x u] [match [union rest bs2] + None None + [Some r] [add-binding x u r]]]]] + +[fn merge [o1 o2] + [match o1 + None None + [Some s1] [match o2 + None None + [Some s2] [match s1 + [Subst b1] [match s2 + [Subst b2] [match [union b1 b2] + None None + [Some b] [Some [Subst b]]]]]]]] + +; First-order matching of pattern `p` against `t`. A repeated pattern +; variable must match equal terms (non-linear patterns are supported). +[fn matcht [p t] + [match p + [V x] [Some [Subst [Cons [Pair x t] Nil]]] + [C f ps] [match t + [V y] None + [C g ts] [if-b [sym-eq f g] [match-list ps ts] None] + [A g ts] None] + [A f ps] [match t + [V y] None + [C g ts] None + [A g ts] [if-b [sym-eq f g] [match-list ps ts] None]]]] + +[fn match-list [ps ts] + [match ps + Nil [match ts + Nil [Some [Subst Nil]] + [Cons u ur] None] + [Cons q qs] [match ts + Nil None + [Cons u ur] [merge [matcht q u] [match-list qs ur]]]]] + +; Match soundness stated without hypotheses: substituting the match result +; back into the pattern gives the term; on failure, the term itself. +[fn apply-match [p t] + [match [matcht p t] + [Some s] [subst p s] + None t]] diff --git a/verify/meta/laws/subst.oo b/verify/meta/laws/subst.oo new file mode 100644 index 0000000..fb4faae --- /dev/null +++ b/verify/meta/laws/subst.oo @@ -0,0 +1,32 @@ +; Substitution lemmas over the kernel meta-model (verify/meta/defs.oo). + +[law nat-eq-refl [n] [= [nat-eq n n] T]] +[law sym-eq-refl [x] [= [sym-eq x x] T]] + +[law subst-if [b u w s] + [= [subst [if-b b u w] s] [if-b b [subst u s] [subst w s]]]] + +; 1. The empty substitution is the identity (term and list versions). +[law subst-empty [t] [= [subst t [Subst Nil]] t]] +[law subst-list-empty [ts] [= [subst-list ts [Subst Nil]] ts]] + +; 2. Substitution composes (term and list versions), with the variable case +; as its own lemma. +[law subst-apply-var [x bs1 bs2] + [= [subst [apply-var x bs1] [Subst bs2]] + [apply-var x [append [map-rhs bs1 [Subst bs2]] bs2]]]] + +[law subst-compose [t s1 s2] + [= [subst [subst t s1] s2] [subst t [compose s1 s2]]]] +[law subst-list-compose [ts s1 s2] + [= [subst-list [subst-list ts s1] s2] [subst-list ts [compose s1 s2]]]] + +; 3. Match soundness, unconditionally; and the variable-pattern instance. +[law apply-match-var [x t] [= [apply-match [V x] t] t]] +[law apply-match [p t] [= [apply-match p t] t]] + +; false: matching binds the pattern's variables, it does not return the pattern +[law apply-match-bogus [p t] [= [apply-match p t] p]] +; false: composition is not commutative +[law subst-compose-swapped [t s1 s2] + [= [subst [subst t s1] s2] [subst t [compose s2 s1]]]] diff --git a/verify/meta/proofs/subst.oo b/verify/meta/proofs/subst.oo new file mode 100644 index 0000000..0126c5d --- /dev/null +++ b/verify/meta/proofs/subst.oo @@ -0,0 +1,64 @@ +; Proof objects for verify/meta/laws/subst.oo. + +[proof nat-eq-refl + [induction n + [Z] + [S [unfold nat-eq] [rewrite ih]]]] + +[proof sym-eq-refl + [cases x + [Sym [unfold sym-eq] [rewrite nat-eq-refl]]]] + +[proof subst-if + [cases b + [T] + [F]]] + +; Nested induction: a Term's arguments are a (List Term), so the term law +; and the list law are proven together. In the C and A cases `ih-rest` is +; the list law at the argument list; in the Cons case `ih-x` is the term law +; at the head and `ih-rest` the list law at the tail. +[proof subst-empty :mutual subst-list-empty + [induction t + [V] + [C [unfold subst] [rewrite ih-rest]] + [A [unfold subst] [rewrite ih-rest]]]] + +[proof subst-list-empty :mutual subst-empty + [induction ts + [Nil] + [Cons [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]]]] + +[proof subst-apply-var + [induction bs1 + [Nil] + [Cons [cases x1 + [Pair [unfold apply-var] [rewrite subst-if] [rewrite ih]]]]]] + +[proof subst-compose :mutual subst-list-compose + [induction t + [V [cases s1 + [Subst [cases s2 + [Subst [unfold subst] [rewrite subst-apply-var]]]]]] + [C [unfold subst] [unfold subst] [rewrite ih-rest]] + [A [unfold subst] [unfold subst] [rewrite ih-rest]]]] + +[proof subst-list-compose :mutual subst-compose + [induction ts + [Nil] + [Cons [unfold subst-list] [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]]]] + +[proof apply-match-var + [unfold apply-match] [unfold matcht] [unfold subst] [unfold apply-var] + [rewrite sym-eq-refl]] + +; Out of reach this rung (see the plan doc): after the constructor test the +; goal needs "sym-eq f g = T implies f = g" and "match-list ps ts = Some s +; implies subst-list ps s = ts", both implications, which need `:given` +; hypotheses plus case analysis on a non-variable scrutinee. +[proof apply-match + [induction p + [V [unfold apply-match] [unfold matcht] [unfold subst] [unfold apply-var] + [rewrite sym-eq-refl]] + [C [unfold apply-match] [unfold matcht] [cases t [V] [C] [A]]] + [A [unfold apply-match] [unfold matcht] [cases t [V] [C] [A]]]]] diff --git a/verify/proofs/cond.oo b/verify/proofs/cond.oo new file mode 100644 index 0000000..61275ca --- /dev/null +++ b/verify/proofs/cond.oo @@ -0,0 +1,22 @@ +; Constructor injectivity: h1.2 is the second argument pair of h1. +[proof cons-inj [rewrite h1.2]] + +[proof append-cancel-left + [induction xs + [Nil [rewrite h1]] + ; h1 = [Cons x [append rest ys]] = [Cons x [append rest zs]]; ih's + ; obligation [append rest ys] = [append rest ?zs] is h1.2, binding ?zs. + [Cons [rewrite ih]]]] + +[proof rev-inj + [rewrite rev-rev :rev] + [rewrite h1] + [rewrite rev-rev]] + +; Cites rev-inj at the `xs` inside L; its obligation is discharged by h1. +[proof rev-inj-append [rewrite rev-inj :at 2]] + +[proof add-cancel-left + [induction m + [Z [rewrite h1]] + [S [rewrite ih]]]] From bf75442973926b815475e3cb0c266dd0bbb13ce2 Mon Sep 17 00:00:00 2001 From: Cam Pedersen Date: Wed, 28 Oct 2026 18:52:19 -0400 Subject: [PATCH 4/4] =?UTF-8?q?feat(verify):=20rung=203=20=E2=80=94=20matc?= =?UTF-8?q?h=20soundness=20and=20the=20evaluator=20model?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Kernel: `[cases EXPR :as h ...]` splits on any total-fn term of ADT type, naming the equation; `[sym]` swaps goal sides; `[rewrite R :in h]` rewrites inside a hypothesis; a case closes ex falso when a hypothesis equates distinct constructors; `:given` is allowed in mutual groups, partner hypotheses becoming obligations. - Meta corpus: the matcher now threads one binding list (as the Rust matcher does), still with non-linear patterns. Match soundness `apply-match p t = t` is proven through term-eq/sym-eq soundness, agree lemmas, and mutual match-in-sound/match-list-in-sound. - Evaluator model: Clause/Fn/Prog, leftmost-outermost `step`, fuel- indexed `evaln`. Proven: evaln-zero, evaln-normal, evaln-succ-normal, evaln-add (fuel composes), fuel-monotone, step-list-normal-head. verify/: 27 proven; verify/meta: 32 proven; both sound, nothing admitted. Co-Authored-By: Claude Fable 5.1 --- crates/loon-lang/src/verify/infer.rs | 59 +++- crates/loon-lang/src/verify/kernel.rs | 269 +++++++++++++++- crates/loon-lang/src/verify/mod.rs | 1 + crates/loon-lang/src/verify/tests.rs | 294 ++++++++++++++++++ .../plans/2026-10-28-self-verifying-kernel.md | 37 ++- docs/plans/2026-10-28-verify-autoresearch.md | 34 ++ verify/meta/defs.oo | 175 +++++++++-- verify/meta/laws/eval.oo | 26 ++ verify/meta/laws/subst.oo | 40 ++- verify/meta/proofs/eval.oo | 29 ++ verify/meta/proofs/subst.oo | 181 ++++++++++- 11 files changed, 1078 insertions(+), 67 deletions(-) create mode 100644 verify/meta/laws/eval.oo create mode 100644 verify/meta/proofs/eval.oo diff --git a/crates/loon-lang/src/verify/infer.rs b/crates/loon-lang/src/verify/infer.rs index 4edc549..c6b6f73 100644 --- a/crates/loon-lang/src/verify/infer.rs +++ b/crates/loon-lang/src/verify/infer.rs @@ -283,6 +283,23 @@ pub fn law_param_types_eqs( params: &[String], eqs: &[(&Expr, &Expr)], ) -> Option> { + let mut inf = with_schemes(defs, fn_order); + let mut env = HashMap::new(); + let pts: Vec = params.iter().map(|_| inf.fresh()).collect(); + for (p, t) in params.iter().zip(&pts) { + env.insert(p.clone(), t.clone()); + } + for (lhs, rhs) in eqs { + let l = inf.expr(lhs, &env, &HashMap::new())?; + let r = inf.expr(rhs, &env, &HashMap::new())?; + inf.unify(&l, &r)?; + } + + Some(pts.iter().map(|t| inf.resolve(t)).collect()) +} + +/// An inference state with every typable fn of defs.oo generalized. +fn with_schemes<'a>(defs: &'a Defs, fn_order: &[String]) -> Inf<'a> { let mut inf = Inf { defs, subst: Vec::new(), @@ -322,18 +339,40 @@ pub fn law_param_types_eqs( inf.schemes.insert((*name).clone(), sc); } } - let mut env = HashMap::new(); - let pts: Vec = params.iter().map(|_| inf.fresh()).collect(); - for (p, t) in params.iter().zip(&pts) { - env.insert(p.clone(), t.clone()); - } - for (lhs, rhs) in eqs { - let l = inf.expr(lhs, &env, &HashMap::new())?; - let r = inf.expr(rhs, &env, &HashMap::new())?; - inf.unify(&l, &r)?; + inf +} + +fn from_ty(inf: &mut Inf, t: &Ty) -> T { + if t.name == "?" { + return inf.fresh(); } + T::Con( + t.name.clone(), + t.args.iter().map(|a| from_ty(inf, a)).collect(), + ) +} - Some(pts.iter().map(|t| inf.resolve(t)).collect()) +/// The type of an arbitrary term `e` whose variables have the (kernel) +/// types in `env`; other free symbols get fresh type variables. Used by the +/// kernel's `cases EXPR :as NAME` to find the ADT to split over. `None` if +/// it does not type. +pub fn expr_type(defs: &Defs, env: &HashMap, e: &Expr) -> Option { + let mut inf = with_schemes(defs, &defs.fn_order); + let mut syms = std::collections::HashSet::new(); + super::kernel::symbols(e, &mut syms); + let mut tenv = HashMap::new(); + for s in syms { + if defs.is_ctor(&s) || defs.fns.contains_key(&s) { + continue; + } + let t = match env.get(&s) { + Some(t) => from_ty(&mut inf, t), + None => inf.fresh(), + }; + tenv.insert(s, t); + } + let t = inf.expr(e, &tenv, &HashMap::new())?; + Some(to_ty(&inf.resolve(&t))) } /// The kernel's view: unresolved variables become `?`. diff --git a/crates/loon-lang/src/verify/kernel.rs b/crates/loon-lang/src/verify/kernel.rs index f467fe5..471629d 100644 --- a/crates/loon-lang/src/verify/kernel.rs +++ b/crates/loon-lang/src/verify/kernel.rs @@ -1146,6 +1146,9 @@ pub struct Mutual { pub var_ty: Ty, pub lhs: Expr, pub rhs: Expr, + /// The partner's `:given` hypotheses: obligations wherever its + /// hypothesis is cited, exactly like a conditional `ih`. + pub hyps: Vec<(Expr, Expr)>, } /// Is `t` fully known (no `?` anywhere)? @@ -1204,8 +1207,9 @@ pub fn check_proof_with( /// `check_proof_with` for one law of a `:mutual` group (see `Mutual`): /// `partners` are the group's other laws. With partners, the proof must be -/// a single `induction` on a law param of fully known type, and the law -/// must have no hypotheses. +/// a single `induction` on a law param of fully known type. Members may +/// have `:given` hypotheses: a partner's hypothesis `ih-FIELD` carries them +/// as obligations (instantiated at the field), like a conditional `ih`. pub fn check_proof_mutual( goal: &Goal, steps: &[Expr], @@ -1228,9 +1232,6 @@ pub fn check_proof_mutual( ":mutual induction variable `{v}` must be a law param of known type" )); } - if !goal.hyps.is_empty() { - return bad(":mutual laws may not have :given hypotheses".into()); - } } let mut ctx = Ctx { defs, @@ -1375,7 +1376,8 @@ fn occurs(pat: &Expr, t: &Expr, defs: &Defs) -> bool { /// `hN` has a canonical and an evaluated form; the first with a side /// occurring in the goal is used (either is the same equation). fn lookup_hyp(st: &State, name: &str, defs: &Defs) -> Option> { - if !is_hyp_name(name) { + let base = name.split('.').next().unwrap_or(name); + if !is_hyp_name(name) && !st.hyps.iter().any(|(n, _, _)| n == base) { return None; } let cands: Vec<_> = hyps_in_scope(st, defs) @@ -1464,7 +1466,13 @@ fn discharge( /// Rewrite with a conditional rule: the `at`-th match, then discharge each /// instantiated hypothesis in order. -fn rewrite_cond(ctx: &mut Ctx, st: &State, rule: &Rule, at: usize) -> Result { +fn rewrite_cond( + ctx: &mut Ctx, + st: &State, + target: &Expr, + rule: &Rule, + at: usize, +) -> Result { let hyps = hyps_in_scope(st, ctx.defs); let mut used = used_symbols(st); for (a, b) in &rule.hyps { @@ -1512,11 +1520,25 @@ fn rewrite_cond(ctx: &mut Ctx, st: &State, rule: &Rule, at: usize) -> Result bool { + hyps_in_scope(st, defs).iter().any(|(_, a, b)| { + matches!((ctor_of(a, defs), ctor_of(b, defs)), + (Some((ca, xa)), Some((cb, xb))) if ca != cb || xa.len() != xb.len()) + }) +} + fn closes(st: &State, defs: &Defs) -> bool { + if contradictory(st, defs) { + return true; + } let mut used = HashSet::new(); symbols(&st.l, &mut used); symbols(&st.r, &mut used); @@ -1570,10 +1592,27 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome }; let name = &name; let (mut rev, mut at) = (false, 0usize); + let mut into: Option = None; let mut j = 2; while j < items.len() { match &items[j].kind { ExprKind::Keyword(k) if k == "rev" => rev = true, + ExprKind::Keyword(k) if k == "in" => { + j += 1; + match items.get(j).map(|e| &e.kind) { + Some(ExprKind::Symbol(h)) + if st.hyps.iter().any(|(n, _, _)| n == h) => + { + into = Some(h.clone()) + } + _ => { + return Err(stuck( + &st, + "`:in` needs the name of a hypothesis in scope", + )) + } + } + } ExprKind::Keyword(k) if k == "at" => { j += 1; match items.get(j).map(|e| &e.kind) { @@ -1621,15 +1660,25 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome hyps: rule.hyps, } }; + if let Some(h) = into { + if let Err(e) = rewrite_hyp(ctx, &mut st, &h, &rule, at) { + return Err(stuck(&st, format!("rewrite {name} :in {h}: {e}"))); + } + continue; + } let res = if rule.hyps.is_empty() { rewrite(&st.l, &rule, at, ctx.defs) } else { - rewrite_cond(ctx, &st, &rule, at) + let l = st.l.clone(); + rewrite_cond(ctx, &st, &l, &rule, at) }; st.l = res .map(|l| normalize(&l, ctx.defs)) .map_err(|e| stuck(&st, format!("rewrite {name}: {e}")))?; } + "sym" => { + std::mem::swap(&mut st.l, &mut st.r); + } "refl" => { if !closes(&st, ctx.defs) { return Err(stuck(&st, "refl: sides differ")); @@ -1647,6 +1696,10 @@ fn run_steps(ctx: &mut Ctx, mut st: State, steps: &[Expr]) -> Result<(), Outcome format!("steps after `{op}` are not allowed; put them in its cases"), )); } + if op == "cases" && matches!(items.get(1).map(|e| &e.kind), Some(ExprKind::List(_))) + { + return split_expr(ctx, st, items); + } return split(ctx, st, items, op == "induction"); } _ => return Err(stuck(&st, format!("unknown step `{step}`"))), @@ -1804,7 +1857,11 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() params: ps, lhs: normalize(&subst(&pt.lhs, &im, ctx.defs), ctx.defs), rhs: normalize(&subst(&pt.rhs, &im, ctx.defs), ctx.defs), - hyps: vec![], + hyps: pt + .hyps + .iter() + .map(|(a, b)| (subst(a, &im, ctx.defs), subst(b, &im, ctx.defs))) + .collect(), }, )); } @@ -1847,3 +1904,195 @@ fn split(ctx: &mut Ctx, st: State, items: &[Expr], induction: bool) -> Result<() } Ok(()) } + +/// `[rewrite RULE :in NAME]`: rewrite inside hypothesis NAME instead of the +/// goal. The hypothesis is first replaced by its evaluation-normalized form +/// (meaning-preserving), then the `at`-th match of RULE, counting through its +/// left side and then its right side in preorder, is rewritten. Sound: the +/// rule instance holds in this context (its obligations are discharged from +/// the hypotheses in scope), so the new hypothesis follows from the old one; +/// the old one is dropped, which only weakens the context. +fn rewrite_hyp( + ctx: &mut Ctx, + st: &mut State, + name: &str, + rule: &Rule, + at: usize, +) -> Result<(), String> { + let defs = ctx.defs; + let k = st.hyps.iter().position(|(n, _, _)| n == name).unwrap(); + let mut used = used_symbols(st); + let mut fuel = 10_000; + let a = eval_normalize(&normalize(&st.hyps[k].1, defs), defs, &mut used, &mut fuel); + let b = eval_normalize(&normalize(&st.hyps[k].2, defs), defs, &mut used, &mut fuel); + let pair = list(vec![sym("="), a, b]); + let ExprKind::List(v) = &pair.kind else { + unreachable!() + }; + // Matches in `a` are counted first; `at` beyond them falls through to `b`. + let count = |t: &Expr| -> usize { + fn go(t: &Expr, r: &Rule, defs: &Defs) -> usize { + let mut b = HashMap::new(); + let me = usize::from(match_term(&r.lhs, t, &r.params, &mut b, defs)); + me + children(t) + .into_iter() + .map(|c| go(c, r, defs)) + .sum::() + } + go(t, rule, defs) + }; + let na = count(&v[1]); + let (side, at2) = if at < na { (1, at) } else { (2, at - na) }; + let res = if rule.hyps.is_empty() { + rewrite(&v[side], rule, at2, defs) + } else { + rewrite_cond(ctx, st, &v[side], rule, at2) + }; + match res { + Ok(t) => { + let t = normalize(&t, defs); + let (na, nb) = if side == 1 { + (t, v[2].clone()) + } else { + (v[1].clone(), t) + }; + st.hyps[k] = (name.to_string(), na, nb); + Ok(()) + } + Err(e) => Err(e), + } +} + +/// Replace every occurrence of `pat` in `t` by `by`. +fn replace_all(t: &Expr, pat: &Expr, by: &Expr) -> Expr { + if term_eq(t, pat) { + return by.clone(); + } + map_children(t, &mut |c| replace_all(c, pat, by)) +} + +/// `[cases EXPR :as NAME CASE*]`: case analysis on an arbitrary term. +/// +/// EXPR's type is inferred (`infer::expr_type`, from the types of the goal's +/// variables) and must be an ADT of defs.oo. For each constructor K, with +/// fresh field names f1.., the case gets hypothesis NAME `[= EXPR [K f1 ..]]` +/// and every occurrence of EXPR in the goal and in the (evaluation- +/// normalized) hypotheses is replaced by `[K f1 ..]`. +/// +/// Soundness: every fn in EXPR is total (checked: list heads must be +/// constructors, `match`, or total fns of defs.oo, and no symbol may name a +/// non-total fn), so EXPR evaluates to a value of its ADT type, which is one +/// of the constructors applied to some field values. The cases are +/// exhaustive, each with that equation as an assumption, and replacing EXPR +/// by an equal term preserves the goal and the hypotheses. +fn split_expr(ctx: &mut Ctx, st: State, items: &[Expr]) -> Result<(), Outcome> { + let defs = ctx.defs; + let expr = normalize(&items[1], defs); + let name = match (items.get(2).map(|e| &e.kind), items.get(3).map(|e| &e.kind)) { + (Some(ExprKind::Keyword(k)), Some(ExprKind::Symbol(n))) if k == "as" => n.clone(), + _ => return Err(stuck(&st, "cases on a term needs `:as NAME`")), + }; + if name == "ih" || name.starts_with("ih-") || st.hyps.iter().any(|(n, _, _)| *n == name) { + return Err(stuck(&st, format!("`{name}` is already a hypothesis name"))); + } + fn total_only(e: &Expr, defs: &Defs) -> Result<(), String> { + if let ExprKind::Symbol(s) = &e.kind { + if defs.fns.contains_key(s) && !defs.total.contains(s) { + return Err(format!("`{s}` is not structurally recursive")); + } + } + if let ExprKind::List(v) = &e.kind { + match v.first().map(|h| &h.kind) { + Some(ExprKind::Symbol(h)) + if h == "match" || defs.is_ctor(h) || defs.total.contains(h) => {} + _ => { + return Err(format!( + "`{e}` is not an application of a total fn of defs.oo" + )) + } + } + } + children(e) + .into_iter() + .try_for_each(|c| total_only(c, defs)) + } + total_only(&expr, defs).map_err(|e| stuck(&st, format!("cases on a term: {e}")))?; + let Some(ty) = super::infer::expr_type(defs, &st.types, &expr) else { + return Err(stuck(&st, format!("cannot infer the type of `{expr}`"))); + }; + let Some(ctors) = defs.types.get(&ty.name) else { + return Err(stuck( + &st, + format!( + "`{expr}` has type `{}`, not an ADT declared in defs.oo", + ty.name + ), + )); + }; + let cases: Vec<&Expr> = items[4..].iter().collect(); + let mut used0 = used_symbols(&st); + used0.insert(name.clone()); + for ctor in ctors { + let case = cases.iter().find(|c| { + head_sym(c).is_some_and(|h| h == ctor.name || h.eq_ignore_ascii_case(&ctor.name)) + }); + let mut used = used0.clone(); + let mut types = st.types.clone(); + let ftys = field_tys(defs, &ty, &ctor.fields); + let mut fields = Vec::new(); + for (k, rec) in ctor.recursive.iter().enumerate() { + let n = fresh_name(if *rec { "rest" } else { "x" }, &mut used); + if let Some(Some(t)) = ftys.get(k) { + types.insert(n.clone(), t.clone()); + } + fields.push(sym(&n)); + } + let value = if fields.is_empty() { + sym(&ctor.name) + } else { + let mut v = vec![sym(&ctor.name)]; + v.extend(fields); + list(v) + }; + let rp = |t: &Expr| normalize(&replace_all(t, &expr, &value), defs); + let mut hyps = Vec::new(); + for (n, a, b) in &st.hyps { + let mut fuel = 10_000; + let a = eval_normalize(&normalize(a, defs), defs, &mut used, &mut fuel); + let b = eval_normalize(&normalize(b, defs), defs, &mut used, &mut fuel); + hyps.push((n.clone(), rp(&a), rp(&b))); + } + hyps.push((name.clone(), expr.clone(), value.clone())); + let child = State { + l: rp(&st.l), + r: rp(&st.r), + params: st.params.clone(), + types, + ihs: st.ihs.clone(), + hyps, + case: if st.case == "root" { + ctor.name.clone() + } else { + format!("{}/{}", st.case, ctor.name) + }, + }; + let Some(case) = case else { + return Err(stuck(&child, format!("missing case {}", ctor.name))); + }; + let ExprKind::List(cs) = &case.kind else { + unreachable!() + }; + run_steps(ctx, child, &cs[1..])?; + } + if let Some(extra) = cases.iter().find(|c| { + !ctors + .iter() + .any(|k| head_sym(c).is_some_and(|h| h.eq_ignore_ascii_case(&k.name))) + }) { + return Err(stuck( + &st, + format!("case `{extra}` is not a constructor of {}", ty.name), + )); + } + Ok(()) +} diff --git a/crates/loon-lang/src/verify/mod.rs b/crates/loon-lang/src/verify/mod.rs index 47b7939..cea8e2b 100644 --- a/crates/loon-lang/src/verify/mod.rs +++ b/crates/loon-lang/src/verify/mod.rs @@ -1049,6 +1049,7 @@ pub fn run_dir(dir: &Path, opts: &Options) -> Result { var, lhs: l.lhs.clone(), rhs: l.rhs.clone(), + hyps: l.hyps.clone(), }) }) .collect(); diff --git a/crates/loon-lang/src/verify/tests.rs b/crates/loon-lang/src/verify/tests.rs index f8a962b..db9c644 100644 --- a/crates/loon-lang/src/verify/tests.rs +++ b/crates/loon-lang/src/verify/tests.rs @@ -1462,6 +1462,7 @@ fn partner( var_ty: ty(var_ty), lhs: p(l), rhs: p(r), + hyps: vec![], } } @@ -1638,3 +1639,296 @@ fn pipeline_mutual_group_fails_together() { assert_eq!(status(&r, "subst-empty").status, "unknown"); assert_eq!(status(&r, "subst-list-empty").status, "unknown"); } + +// ─── Rung 3: cases on a term, sym, hypothesis rewriting, ex falso ───────── + +fn prove_meta( + params: &[(&str, &str)], + hyps: &[(&str, &str)], + (lhs, rhs): (&str, &str), + steps: &str, + lemmas: &kernel::Lemmas, + partners: &[kernel::Mutual], +) -> Outcome { + let d = meta_defs(); + let names: Vec = params.iter().map(|(n, _)| n.to_string()).collect(); + let types: HashMap = + params.iter().map(|(n, t)| (n.to_string(), ty(t))).collect(); + let hyps: Vec<(Expr, Expr)> = hyps.iter().map(|(a, b)| (p(a), p(b))).collect(); + let (l, r) = (p(lhs), p(rhs)); + let goal = Goal { + law_name: "t", + params: &names, + param_types: &types, + lhs: &l, + rhs: &r, + hyps: &hyps, + }; + let steps = crate::parser::parse(steps).unwrap(); + kernel::check_proof_mutual(&goal, &steps, &d, lemmas, &[], partners) +} + +fn meta_lemmas(n: &str) -> Option<(Rule, bool)> { + let r = match n { + "sym-eq-sound" => rule(&["a", "b"], &[("[sym-eq a b]", "T")], "a", "b"), + "sym-eq-comm" => rule(&["a", "b"], &[], "[sym-eq a b]", "[sym-eq b a]"), + _ => return None, + }; + Some((r, false)) +} + +const TT: [(&str, &str); 2] = [("p", "Term"), ("t", "Term")]; + +#[test] +fn cases_on_term_splits_option() { + let o = prove_meta( + &TT, + &[], + ( + "[match [matcht p t] None None [Some s] [Some s]]", + "[matcht p t]", + ), + "[cases [matcht p t] :as hm [None] [Some]]", + &none, + &[], + ); + assert_eq!(o, Outcome::Proven); + // The split's equation is a hypothesis in each case. + let o = prove_meta( + &TT, + &[], + ("[matcht p t]", "None"), + "[cases [matcht p t] :as hm [None] [Some]]", + &none, + &[], + ); + assert!(stuck_with(&o, "hm: [= [matcht p t] [Some x]]"), "{o:?}"); +} + +#[test] +fn cases_on_bool_term_cannot_prove_false_law() { + let ab = [("a", "Term"), ("b", "Term")]; + let o = prove_meta( + &ab, + &[], + ("[term-eq a b]", "T"), + "[cases [term-eq a b] :as h [T] [F]]", + &none, + &[], + ); + assert!( + matches!(&o, Outcome::Stuck { case, .. } if case == "F"), + "{o:?}" + ); + let o = prove_meta( + &ab, + &[], + ("[term-eq a b]", "T"), + "[cases [term-eq a b] :as h [T]]", + &none, + &[], + ); + assert!(stuck_with(&o, "missing case F"), "{o:?}"); + // A name already in scope, and a missing `:as`, are refused. + let o = prove_meta( + &ab, + &[("[term-eq a b]", "T")], + ("a", "b"), + "[cases [term-eq a b] :as h1 [T] [F]]", + &none, + &[], + ); + assert!(stuck_with(&o, "already a hypothesis"), "{o:?}"); + let o = prove_meta( + &ab, + &[], + ("a", "b"), + "[cases [term-eq a b] [T] [F]]", + &none, + &[], + ); + assert!(stuck_with(&o, ":as NAME"), "{o:?}"); +} + +#[test] +fn cases_on_term_refuses_non_total_fns() { + let o = prove( + &defs(), + &["xs"], + "[spin xs]", + "xs", + "[cases [spin xs] :as h [Nil] [Cons]]", + &none, + ); + assert!(stuck_with(&o, "not an application of a total fn"), "{o:?}"); +} + +#[test] +fn sym_swaps_sides_only() { + let o = prove( + &defs(), + &["xs"], + "xs", + "[append xs Nil]", + "[sym] [induction xs [Nil [unfold append]] [Cons [unfold append] [rewrite ih]]]", + &none, + ); + assert_eq!(o, Outcome::Proven); + let o = prove(&defs(), &["xs"], "xs", "Nil", "[sym]", &none); + assert!(matches!(o, Outcome::Stuck { .. })); +} + +#[test] +fn contradictory_hypothesis_closes_only_when_constructors_differ() { + let ab = [("a", "Sym"), ("b", "Sym")]; + let o = prove_meta( + &ab, + &[("[term-eq [V a] [C a Nil]]", "T")], + ("a", "b"), + "", + &none, + &[], + ); + assert_eq!(o, Outcome::Proven); + let o = prove_meta( + &ab, + &[("[term-eq [V a] [V b]]", "T")], + ("a", "[Sym Z]"), + "", + &none, + &[], + ); + assert!(matches!(o, Outcome::Stuck { .. })); +} + +#[test] +fn rewrite_in_hypothesis() { + let ab = [("a", "Sym"), ("b", "Sym")]; + let o = prove_meta( + &ab, + &[("[sym-eq a b]", "T")], + ("[sym-eq b a]", "T"), + "[rewrite sym-eq-comm :in h1] [rewrite h1]", + &meta_lemmas, + &[], + ); + assert_eq!(o, Outcome::Proven); + // Without the hypothesis rewrite, h1 does not match. + let o = prove_meta( + &ab, + &[("[sym-eq a b]", "T")], + ("[sym-eq b a]", "T"), + "[rewrite h1]", + &meta_lemmas, + &[], + ); + assert!(matches!(o, Outcome::Stuck { .. })); + let o = prove_meta( + &ab, + &[], + ("a", "b"), + "[rewrite sym-eq-comm :in h7]", + &meta_lemmas, + &[], + ); + assert!(stuck_with(&o, "`:in` needs"), "{o:?}"); +} + +const TERM_SOUND: &str = "[induction a + [V [cases b [V [rewrite sym-eq-sound :at 2]] [C] [A]]] + [C [cases b [V] + [C [cases [sym-eq x x1] :as he [T [rewrite sym-eq-sound :at 2] [rewrite ih-rest]] [F]]] + [A]]] + [A [cases b [V] [C] + [A [cases [sym-eq x x1] :as he [T [rewrite sym-eq-sound :at 2] [rewrite ih-rest]] [F]]]]]]"; +const TERMS_SOUND: &str = "[induction ts + [Nil [cases us [Nil] [Cons]]] + [Cons [cases us [Nil] + [Cons [cases [term-eq x x1] :as he [T [rewrite ih-x] [rewrite ih-rest]] [F]]]]]]"; + +fn cond_partner( + name: &str, + params: &[&str], + var: &str, + var_ty: &str, + hyp: (&str, &str), + l: &str, + r: &str, +) -> kernel::Mutual { + let mut m = partner(name, params, var, var_ty, l, r); + m.hyps = vec![(p(hyp.0), p(hyp.1))]; + m +} + +#[test] +fn conditional_mutual_pair_proves() { + let terms = cond_partner( + "terms-eq-sound", + &["ts", "us"], + "ts", + "[List Term]", + ("[terms-eq ts us]", "T"), + "ts", + "us", + ); + let term = cond_partner( + "term-eq-sound", + &["a", "b"], + "a", + "Term", + ("[term-eq a b]", "T"), + "a", + "b", + ); + let o = prove_meta( + &[("a", "Term"), ("b", "Term")], + &[("[term-eq a b]", "T")], + ("a", "b"), + TERM_SOUND, + &meta_lemmas, + std::slice::from_ref(&terms), + ); + assert_eq!(o, Outcome::Proven); + let o = prove_meta( + &[("ts", "[List Term]"), ("us", "[List Term]")], + &[("[terms-eq ts us]", "T")], + ("ts", "us"), + TERMS_SOUND, + &meta_lemmas, + std::slice::from_ref(&term), + ); + assert_eq!(o, Outcome::Proven); +} + +#[test] +fn conditional_mutual_false_pair_fails() { + // False list half: equal lists are not all empty. The term half, + // relying on it, cannot close either. + let terms = cond_partner( + "terms-bogus", + &["ts", "us"], + "ts", + "[List Term]", + ("[terms-eq ts us]", "T"), + "ts", + "Nil", + ); + let o = prove_meta( + &[("a", "Term"), ("b", "Term")], + &[("[term-eq a b]", "T")], + ("a", "b"), + TERM_SOUND, + &meta_lemmas, + std::slice::from_ref(&terms), + ); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); + let o = prove_meta( + &[("ts", "[List Term]"), ("us", "[List Term]")], + &[("[terms-eq ts us]", "T")], + ("ts", "Nil"), + TERMS_SOUND, + &meta_lemmas, + &[], + ); + assert!(matches!(o, Outcome::Stuck { .. }), "{o:?}"); +} diff --git a/docs/plans/2026-10-28-self-verifying-kernel.md b/docs/plans/2026-10-28-self-verifying-kernel.md index b01c409..cc8fafa 100644 --- a/docs/plans/2026-10-28-self-verifying-kernel.md +++ b/docs/plans/2026-10-28-self-verifying-kernel.md @@ -116,7 +116,8 @@ induction, cases, refl. (naturals), `Pair`, `Option`, `B` (`T`/`F`), `Subst` (an association list), and `subst`/`subst-list`, `apply-var`, `map-rhs`, `compose`, `term-eq`/ `terms-eq`, `matcht`/`match-list` (non-linear: a repeated variable must -match equal terms, checked by `add-binding`/`union`), `apply-match`. +match equal terms; since rung 3 the binding list is threaded left to right +by `match-in`/`match-list-in`, like the Rust `match_term`), `apply-match`. Proven: `subst-empty` and `subst-compose`, each with its list version, plus helper lemmas (`nat-eq-refl`, `sym-eq-refl`, `subst-if`, `subst-apply-var`) and `apply-match-var` (match soundness for a variable @@ -124,8 +125,7 @@ pattern). `compose s1 s2` is `s1`'s bindings with `s2` applied, then all of `s2`'s; lookup takes the first binding, which gives the usual composition. -Still open: `apply-match` in general (bounded-checked on ~1100 inputs, not -proven). After the constructor test the goal is +Open at rung 2 (closed in rung 3, below): `apply-match` in general. After the constructor test the goal is `[match [if-b [sym-eq f g] [match-list ps ts] None] ...]`: it needs `sym-eq f g = T → f = g` and `match-list ps ts = Some s → subst-list ps s = ts`, implications, i.e. rung 1's `:given` plus case analysis on a @@ -145,7 +145,9 @@ Kernel growth it forced: - **Mutual induction.** `[proof P :mutual Q [induction t ...]]` and `[proof Q :mutual P [induction ts ...]]` (or `:mutual [Q R ...]`) form a group, declared identically by every member. Each member's proof must be - one `induction` on a param of fully known type, and the laws unconditional. + one `induction` on a param of fully known type (since rung 3 members may + carry `:given` hypotheses; a partner's `ih-FIELD` carries them as + obligations). In an induction case of P, a constructor field whose type is exactly Q's induction type gets Q at that field as `ih-FIELD` (Q's other params quantified, renamed apart); P's own `ih` is as before. Sound by strong @@ -167,6 +169,33 @@ For rung 3: a `Fn`/`Prog` model with `step` and fuel-indexed `evaln`; `apply-match` needs too; and `:given` (rung 1) inside mutual groups, which the mutual scheme refuses today. +## Rung 3 (kernel half), as built + +Kernel: `[cases EXPR :as NAME ...]` on any term of ADT type built from total +fns, `[rewrite RULE :in HYP]`, `[sym]`, ex falso on a hypothesis equating +distinct constructors, and `:given` inside `:mutual` groups (grammar and +soundness in the main plan, section 2.3). + +Model change: matching now threads one binding list (`match-in p t bs`, +`match-list-in ps ts bs`, `bind-var`), which is how the Rust kernel +matches; `matcht`/`match-list` are `wrap-subst` of it from `Nil`. The +merge-of-two-substitutions version needed a domain/union theory that +ballooned; the threaded one only ever prepends a binding for an unbound +variable. Still non-linear: a bound variable must meet an equal term +(`term-eq`). + +`apply-match` is proven. Chain: `nat-eq-sound`, `sym-eq-sound`, +`nat-eq-comm`, `sym-eq-comm`; `term-eq-refl`/`terms-eq-refl` and +`term-eq-sound`/`terms-eq-sound` (mutual, the latter conditional); +`lookup-apply-var`; `agree` (`b` reads like `b0` at every key of `ks`) with +`agree-refl`, `agree-lookup`, `agree-cons-fresh`; `match-in-mono` (mutual, +conditional: agreement with the result gives agreement with the input); +`match-in-sound` (mutual, conditional: any `b` agreeing with the result +maps the pattern to the term); then `apply-match` is a `cases` on +`[match-in p t Nil]` and `match-in-sound` with `agree-refl` discharging the +agreement. The evaluator lemmas `evaln-succ-normal`, `evaln-add`, +`fuel-monotone` are proven with `sym` and `cases [step p t] :as o`. + ## Risks, said plainly - The model kernel will not be the Rust kernel. It is a re-statement. The diff --git a/docs/plans/2026-10-28-verify-autoresearch.md b/docs/plans/2026-10-28-verify-autoresearch.md index d169df7..e6a7289 100644 --- a/docs/plans/2026-10-28-verify-autoresearch.md +++ b/docs/plans/2026-10-28-verify-autoresearch.md @@ -130,6 +130,9 @@ STEP := [unfold FN] ; one unfolding of FN at the leftmost-out | [induction VAR CASE*] ; VAR must be a law param of ADT type | [cases VAR CASE*] ; like induction, no new ih; VAR may be a ; constructor field bound by an earlier split + | [cases EXPR :as NAME CASE*] ; case analysis on a term (see below) + | [rewrite RULE :in HYP] ; rewrite inside hypothesis HYP (also with :rev/:at) + | [sym] ; swap L and R of the current goal | [refl] ; both sides syntactically equal after normalization | [admit] ; close the goal, taint the proof CASE := [CTOR STEP*] ; CTOR is a constructor of VAR's type; nil/cons for Vec @@ -215,6 +218,37 @@ Reads "for all PARAMS, A1 = B1 ∧ ... → L = R". Rules: If every input is vacuous the law is `unknown` with a note and is not sent to the kernel: never proven by vacuity. +Case analysis on a term, hypothesis rewriting, ex falso (rung 3): + +- `[cases EXPR :as NAME CASE*]`, EXPR any non-variable term. Its type is + inferred (`infer::expr_type`, from the types of the goal's variables) and + must be an ADT of defs.oo. Every list head in EXPR must be a constructor, + `match`, or a total fn, and no symbol may name a non-total fn. For each + constructor K with fresh fields f1.., the case gets hypothesis + `NAME : [= EXPR [K f1 ..]]` (cited as `NAME`, components `NAME.K`), and + every occurrence of EXPR in the goal and in the evaluation-normalized + hypotheses is replaced by `[K f1 ..]`. Induction hypotheses are left + alone. Sound because EXPR, built from total fns, evaluates to some value + of its type, i.e. some constructor applied to values: the cases are + exhaustive, and replacing a term by an equal one changes nothing. Lean's + `cases h : e`. Plain `[cases VAR ...]` is unchanged. +- `[rewrite RULE :in HYP]`: HYP (a law hypothesis `hN` or a `cases` name) + is replaced by its evaluation-normalized form, then the `:at`-th match + (counting its left side, then its right side, in preorder) is rewritten. + Obligations of a conditional RULE are discharged as for the goal. Sound: + the rule instance holds in this context, so the new hypothesis follows; + dropping the old one only weakens the context. +- `[sym]` swaps L and R (the kernel only ever rewrites L). +- Ex falso: a case also closes when some hypothesis in scope (or a + constructor component of one), evaluation-normalized, equates two + distinct constructors (`[= None [Some s]]`, `[= T F]`): no values satisfy + it, so the case is vacuous. +- `:mutual` groups may now have `:given` hypotheses: a partner's `ih-FIELD` + is the partner law at that field with its hypotheses as obligations, + instantiated like its conclusion, exactly as a conditional `ih`. The + strong-induction argument is unchanged (each member is used only at a + strictly smaller constructor field, as an implication). + AC declarations (a top-level form in `laws/*.oo`): ``` diff --git a/verify/meta/defs.oo b/verify/meta/defs.oo index 57f3c0b..5ff7421 100644 --- a/verify/meta/defs.oo +++ b/verify/meta/defs.oo @@ -120,54 +120,59 @@ Nil F [Cons u ur] [and-b [term-eq t u] [terms-eq rest ur]]]]] -; Add x := u to bs, failing if bs binds x to something else. -[fn add-binding [x u bs] - [match [lookup x bs] +; Matching threads one binding list left to right, like the Rust kernel's +; `match_term`: a variable already bound must meet a term equal to its +; binding (non-linear patterns are supported), an unbound one is added. +; Every fn here matches on a parameter at the top, so the kernel can +; evaluate it inside hypotheses. + +; Bind x := u given `o`, the current lookup of x in bs. +[fn bind-var [o x u bs] + [match o None [Some [Cons [Pair x u] bs]] [Some w] [if-b [term-eq u w] [Some bs] None]]] -; Consistent union of two binding lists. -[fn union [bs1 bs2] - [match bs1 - Nil [Some bs2] - [Cons p rest] [match p - [Pair x u] [match [union rest bs2] - None None - [Some r] [add-binding x u r]]]]] - -[fn merge [o1 o2] - [match o1 - None None - [Some s1] [match o2 - None None - [Some s2] [match s1 - [Subst b1] [match s2 - [Subst b2] [match [union b1 b2] - None None - [Some b] [Some [Subst b]]]]]]]] - -; First-order matching of pattern `p` against `t`. A repeated pattern -; variable must match equal terms (non-linear patterns are supported). -[fn matcht [p t] +; Match `p` against `t`, extending the bindings `bs`. +[fn match-in [p t bs] [match p - [V x] [Some [Subst [Cons [Pair x t] Nil]]] + [V x] [bind-var [lookup x bs] x t bs] [C f ps] [match t [V y] None - [C g ts] [if-b [sym-eq f g] [match-list ps ts] None] + [C g ts] [if-b [sym-eq f g] [match-list-in ps ts bs] None] [A g ts] None] [A f ps] [match t [V y] None [C g ts] None - [A g ts] [if-b [sym-eq f g] [match-list ps ts] None]]]] + [A g ts] [if-b [sym-eq f g] [match-list-in ps ts bs] None]]]] -[fn match-list [ps ts] +[fn match-list-in [ps ts bs] [match ps Nil [match ts - Nil [Some [Subst Nil]] + Nil [Some bs] [Cons u ur] None] [Cons q qs] [match ts Nil None - [Cons u ur] [merge [matcht q u] [match-list qs ur]]]]] + [Cons u ur] [match [match-in q u bs] + None None + [Some bs1] [match-list-in qs ur bs1]]]]] + +[fn wrap-subst [o] + [match o + None None + [Some bs] [Some [Subst bs]]]] + +; First-order matching of pattern `p` against `t`, from no bindings. +[fn matcht [p t] [wrap-subst [match-in p t Nil]]] + +[fn match-list [ps ts] [wrap-subst [match-list-in ps ts Nil]]] + +; `b` agrees with `b0` on every key of `ks`: `subst` reads both alike there. +[fn agree [ks b0 b] + [match ks + Nil T + [Cons p rest] [match p + [Pair y u] [and-b [term-eq [apply-var y b] [apply-var y b0]] + [agree rest b0 b]]]]] ; Match soundness stated without hypotheses: substituting the match result ; back into the pattern gives the term; on failure, the term itself. @@ -175,3 +180,109 @@ [match [matcht p t] [Some s] [subst p s] None t]] + +; --------------------------------------------------------------------------- +; Rung 3: the evaluator model. +; +; A function is a symbol and a list of clauses. A clause's pattern is matched +; against the whole call term `[A f args]`, so patterns are ordinary terms +; (usually `[A f ps]`) and `matcht` does all the work. +[type Clause [Clause Term Term]] +[type Fn [Def Sym (List Clause)]] +[type Prog [Prog (List Fn)]] + +[fn add [m n] + [match m + Z n + [S k] [S [add k n]]]] + +[fn find-in [f fs] + [match fs + Nil None + [Cons d rest] [match d + [Def g cs] [if-b [sym-eq f g] [Some cs] [find-in f rest]]]]] + +; The clauses of `f` in `p`, if `p` defines it. +[fn find-fn [p f] + [match p + [Prog fs] [find-in f fs]]] + +; Instantiate a clause body with a match result. +[fn inst [o body] + [match o + None None + [Some s] [Some [subst body s]]]] + +[fn or-else [o1 o2] + [match o1 + None o2 + [Some x] [Some x]]] + +; The body of the first clause whose pattern matches `t`, instantiated. +[fn first-match [cs t] + [match cs + Nil None + [Cons c rest] [match c + [Clause pat body] [or-else [inst [matcht pat t] body] + [first-match rest t]]]]] + +[fn rules-for [o t] + [match o + None None + [Some cs] [first-match cs t]]] + +; A root reduction of `t` by `p`'s clauses, if any. +[fn try-rules [p t] + [match t + [V x] None + [C f ts] None + [A f ts] [rules-for [find-fn p f] t]]] + +[fn wrap-c [f o] + [match o + None None + [Some ts] [Some [C f ts]]]] + +[fn wrap-a [f o] + [match o + None None + [Some ts] [Some [A f ts]]]] + +[fn wrap-cons [t o] + [match o + None None + [Some ts] [Some [Cons t ts]]]] + +[fn step-cons [t rest o1 o2] + [match o1 + [Some t2] [Some [Cons t2 rest]] + None [wrap-cons t o2]]] + +; One leftmost-outermost step: a call reduces at the root if a clause +; matches, otherwise the first reducible argument (left to right) steps. +; Variables and normal terms give None. +[fn step [p t] + [match t + [V x] None + [C f ts] [wrap-c f [step-list p ts]] + [A f ts] [or-else [try-rules p [A f ts]] [wrap-a f [step-list p ts]]]]] + +[fn step-list [p ts] + [match ts + Nil None + [Cons t rest] [step-cons t rest [step p t] [step-list p rest]]]] + +; At most `n` steps; stops early at a normal form. +[fn evaln [n p t] + [match n + Z t + [S k] [match [step p t] + None t + [Some t2] [evaln k p t2]]]] + +[fn is-none [o] + [match o + None T + [Some x] F]] + +[fn normal? [p t] [is-none [step p t]]] diff --git a/verify/meta/laws/eval.oo b/verify/meta/laws/eval.oo new file mode 100644 index 0000000..4448049 --- /dev/null +++ b/verify/meta/laws/eval.oo @@ -0,0 +1,26 @@ +; Evaluation lemmas over the evaluator model (verify/meta/defs.oo, rung 3). + +[law evaln-zero [p t] [= [evaln Z p t] t]] + +[law evaln-normal [n p t] :given [[= [step p t] None]] + [= [evaln n p t] t]] + +[law evaln-succ-normal [n p t] :given [[= [step p t] None]] + [= [evaln [S n] p t] [evaln n p t]]] + +; Fuel composes. +[law evaln-add [m n p t] + [= [evaln [add m n] p t] [evaln n p [evaln m p t]]]] + +; Fuel monotonicity: a normal form reached at fuel n stays at n+k. +[law fuel-monotone [n k p t] :given [[= [step p [evaln n p t]] None]] + [= [evaln [add n k] p t] [evaln n p t]]] + +; A normal head leaves the list step to the tail (C/A congruence, later). +[law step-list-normal-head [p t ts] :given [[= [step p t] None]] + [= [step-list p [Cons t ts]] [wrap-cons t [step-list p ts]]]] + +; false: variables are normal, so not every term is reducible +[law normal-bogus [p t] [= [normal? p t] F]] +; false: a step never returns its input unchanged on a variable +[law step-self-bogus [p t] [= [step p t] [Some t]]] diff --git a/verify/meta/laws/subst.oo b/verify/meta/laws/subst.oo index fb4faae..f3a0cf7 100644 --- a/verify/meta/laws/subst.oo +++ b/verify/meta/laws/subst.oo @@ -21,7 +21,45 @@ [law subst-list-compose [ts s1 s2] [= [subst-list [subst-list ts s1] s2] [subst-list ts [compose s1 s2]]]] -; 3. Match soundness, unconditionally; and the variable-pattern instance. +; 3. Match soundness. Equality deciders are sound and symmetric. +[law nat-eq-sound [m n] :given [[= [nat-eq m n] T]] [= m n]] +[law sym-eq-sound [a b] :given [[= [sym-eq a b] T]] [= a b]] +[law nat-eq-comm [m n] [= [nat-eq m n] [nat-eq n m]]] +[law sym-eq-comm [a b] [= [sym-eq a b] [sym-eq b a]]] +[law term-eq-refl [a] [= [term-eq a a] T]] +[law terms-eq-refl [ts] [= [terms-eq ts ts] T]] +[law term-eq-sound [a b] :given [[= [term-eq a b] T]] [= a b]] +[law terms-eq-sound [ts us] :given [[= [terms-eq ts us] T]] [= ts us]] + +; Lookup and agreement of binding lists. +[law lookup-apply-var [x bs w] :given [[= [lookup x bs] [Some w]]] + [= [apply-var x bs] w]] +[law agree-refl [ks b0] [= [agree ks b0 b0] T]] +[law agree-lookup [ks b0 b x w] + :given [[= [lookup x ks] [Some w]] [= [agree ks b0 b] T]] + [= [apply-var x b] [apply-var x b0]]] +[law agree-cons-fresh [ks b0 x u b] + :given [[= [lookup x ks] None] [= [agree ks [Cons [Pair x u] b0] b] T]] + [= [agree ks b0 b] T]] + +; Matching only adds bindings: agreement with the result implies agreement +; with the input. +[law match-in-mono [p t bs bs2 b] + :given [[= [match-in p t bs] [Some bs2]] [= [agree bs2 bs2 b] T]] + [= [agree bs bs b] T]] +[law match-list-in-mono [ps ts bs bs2 b] + :given [[= [match-list-in ps ts bs] [Some bs2]] [= [agree bs2 bs2 b] T]] + [= [agree bs bs b] T]] + +; Soundness: any substitution agreeing with the match result maps the +; pattern to the term. +[law match-in-sound [p t bs bs2 b] + :given [[= [match-in p t bs] [Some bs2]] [= [agree bs2 bs2 b] T]] + [= [subst p [Subst b]] t]] +[law match-list-in-sound [ps ts bs bs2 b] + :given [[= [match-list-in ps ts bs] [Some bs2]] [= [agree bs2 bs2 b] T]] + [= [subst-list ps [Subst b]] ts]] + [law apply-match-var [x t] [= [apply-match [V x] t] t]] [law apply-match [p t] [= [apply-match p t] t]] diff --git a/verify/meta/proofs/eval.oo b/verify/meta/proofs/eval.oo new file mode 100644 index 0000000..1ac5045 --- /dev/null +++ b/verify/meta/proofs/eval.oo @@ -0,0 +1,29 @@ +; Proof objects for verify/meta/laws/eval.oo. + +[proof evaln-zero + [unfold evaln]] + +[proof evaln-normal + [cases n + [Z [unfold evaln]] + [S [unfold evaln] [rewrite h1]]]] + +[proof evaln-succ-normal + [unfold evaln] [rewrite h1] [sym] [rewrite evaln-normal]] + +; Split on the first step: a normal t is a fixpoint on both sides +; (evaln-normal, on R via sym); otherwise both sides step once and ih-rest +; closes it. +[proof evaln-add + [induction m + [Z [unfold add]] + [S [unfold add] [unfold evaln] + [cases [step p t] :as o + [None [sym] [unfold evaln] [rewrite o] [rewrite evaln-normal]] + [Some [rewrite ih-rest] [sym] [unfold evaln] [rewrite o]]]]]] + +[proof fuel-monotone + [rewrite evaln-add] [rewrite evaln-normal]] + +[proof step-list-normal-head + [unfold step-list] [rewrite h1] [unfold step-cons]] diff --git a/verify/meta/proofs/subst.oo b/verify/meta/proofs/subst.oo index 0126c5d..3bb38e9 100644 --- a/verify/meta/proofs/subst.oo +++ b/verify/meta/proofs/subst.oo @@ -48,17 +48,178 @@ [Nil] [Cons [unfold subst-list] [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]]]] +[proof nat-eq-sound + [induction m + [Z [cases n [Z] [S]]] + [S [cases n [Z] [S [rewrite ih]]]]]] + +[proof sym-eq-sound + [cases a [Sym [cases b [Sym [rewrite nat-eq-sound :at 2]]]]]] + +[proof nat-eq-comm + [induction m + [Z [cases n [Z] [S]]] + [S [cases n [Z] [S [unfold nat-eq] [rewrite ih]]]]]] + +[proof sym-eq-comm + [cases a [Sym [cases b [Sym [unfold sym-eq] [rewrite nat-eq-comm]]]]]] + +[proof term-eq-refl :mutual terms-eq-refl + [induction a + [V [unfold term-eq] [rewrite sym-eq-refl]] + [C [unfold term-eq] [rewrite sym-eq-refl] [rewrite ih-rest]] + [A [unfold term-eq] [rewrite sym-eq-refl] [rewrite ih-rest]]]] + +[proof terms-eq-refl :mutual term-eq-refl + [induction ts + [Nil] + [Cons [unfold terms-eq] [rewrite ih-x] [rewrite ih-rest]]]] + +[proof term-eq-sound :mutual terms-eq-sound + [induction a + [V [cases b + [V [rewrite sym-eq-sound :at 2]] + [C] [A]]] + [C [cases b + [V] + [C [cases [sym-eq x x1] :as he + [T [rewrite sym-eq-sound :at 2] [rewrite ih-rest]] + [F]]] + [A]]] + [A [cases b + [V] [C] + [A [cases [sym-eq x x1] :as he + [T [rewrite sym-eq-sound :at 2] [rewrite ih-rest]] + [F]]]]]]] + +[proof terms-eq-sound :mutual term-eq-sound + [induction ts + [Nil [cases us [Nil] [Cons]]] + [Cons [cases us + [Nil] + [Cons [cases [term-eq x x1] :as he + [T [rewrite ih-x] [rewrite ih-rest]] + [F]]]]]]] + +[proof lookup-apply-var + [induction bs + [Nil] + [Cons [cases x1 + [Pair [unfold apply-var] + [cases [sym-eq x x2] :as hs + [T [rewrite h1.1]] + [F [unfold if-b] [rewrite ih]]]]]]]] + +[proof agree-refl + [induction ks + [Nil] + [Cons [cases x + [Pair [unfold agree] [rewrite term-eq-refl] [rewrite ih]]]]]] + +[proof agree-lookup + [induction ks + [Nil] + [Cons [cases x1 + [Pair [cases [sym-eq x x2] :as hs + [T [cases [term-eq [apply-var x2 b] [apply-var x2 b0]] :as ht + [T [rewrite sym-eq-sound :at 2] + [rewrite term-eq-sound] + [rewrite sym-eq-sound :rev :at 2]] + [F]]] + [F [cases [term-eq [apply-var x2 b] [apply-var x2 b0]] :as ht + [T [rewrite ih]] + [F]]]]]]]]] + +[proof agree-cons-fresh + [induction ks + [Nil] + [Cons [cases x1 + [Pair [cases [sym-eq x x2] :as hs + [T] + [F [rewrite sym-eq-comm :in h2] [rewrite hs :in h2] + [cases [term-eq [apply-var x2 b] [apply-var x2 b0]] :as ht + [T [unfold agree] [rewrite ht] [unfold and-b] [rewrite ih]] + [F]]]]]]]]] + +[proof match-in-mono :mutual match-list-in-mono + [induction p + [V [cases [lookup x bs] :as hl + [None [rewrite h1.1 :rev :in h2] [rewrite h1.1 :rev :in h2] + [rewrite h1.1 :rev :in h2] + [rewrite sym-eq-refl :in h2] + [cases [term-eq [apply-var x b] t] :as ht + [T [rewrite agree-cons-fresh]] + [F]]] + [Some [cases [term-eq t x1] :as ht + [T [rewrite h1.1] [rewrite h1.1] [rewrite h2]] + [F]]]]] + [C [cases t + [V] + [C [cases [sym-eq x x1] :as he [T [rewrite ih-rest]] [F]]] + [A]]] + [A [cases t + [V] [C] + [A [cases [sym-eq x x1] :as he [T [rewrite ih-rest]] [F]]]]]]] + +[proof match-list-in-mono :mutual match-in-mono + [induction ps + [Nil [cases ts + [Nil [rewrite h1.1] [rewrite h1.1] [rewrite h2]] + [Cons]]] + [Cons [cases ts + [Nil] + [Cons [cases [match-in x x1 bs] :as hq + [None] + [Some [cases [agree x2 x2 b] :as ha + [T [rewrite ih-x]] + [F [rewrite ih-rest :in ha]]]]]]]]]] + +[proof match-in-sound :mutual match-list-in-sound + [induction p + [V [cases [lookup x bs] :as hl + [None [rewrite h1.1 :rev :in h2] [rewrite h1.1 :rev :in h2] + [rewrite sym-eq-refl :in h2] + [cases [term-eq [apply-var x b] t] :as ht + [T [unfold subst] [rewrite term-eq-sound]] + [F]]] + [Some [cases [term-eq t x1] :as ht + [T [rewrite h1.1 :rev :in h2] [rewrite h1.1 :rev :in h2] + [unfold subst] [rewrite agree-lookup] [rewrite lookup-apply-var] + [rewrite term-eq-sound :rev]] + [F]]]]] + [C [cases t + [V] + [C [cases [sym-eq x x1] :as he + [T [unfold subst] [rewrite sym-eq-sound :at 2] [rewrite ih-rest]] + [F]]] + [A]]] + [A [cases t + [V] [C] + [A [cases [sym-eq x x1] :as he + [T [unfold subst] [rewrite sym-eq-sound :at 2] [rewrite ih-rest]] + [F]]]]]]] + +[proof match-list-in-sound :mutual match-in-sound + [induction ps + [Nil [cases ts [Nil] [Cons]]] + [Cons [cases ts + [Nil] + [Cons [cases [match-in x x1 bs] :as hq + [None] + [Some [cases [agree x2 x2 b] :as ha + [T [unfold subst-list] [rewrite ih-x] [rewrite ih-rest]] + [F [rewrite match-list-in-mono :in ha]]]]]]]]]] + [proof apply-match-var - [unfold apply-match] [unfold matcht] [unfold subst] [unfold apply-var] + [unfold apply-match] [unfold matcht] [unfold match-in] [unfold lookup] + [unfold bind-var] [unfold wrap-subst] [unfold subst] [unfold apply-var] [rewrite sym-eq-refl]] -; Out of reach this rung (see the plan doc): after the constructor test the -; goal needs "sym-eq f g = T implies f = g" and "match-list ps ts = Some s -; implies subst-list ps s = ts", both implications, which need `:given` -; hypotheses plus case analysis on a non-variable scrutinee. +; Match soundness in general: split on the match result; a success is +; sound by `match-in-sound` with the result itself as the substitution +; (`agree-refl` discharges the agreement obligation). [proof apply-match - [induction p - [V [unfold apply-match] [unfold matcht] [unfold subst] [unfold apply-var] - [rewrite sym-eq-refl]] - [C [unfold apply-match] [unfold matcht] [cases t [V] [C] [A]]] - [A [unfold apply-match] [unfold matcht] [cases t [V] [C] [A]]]]] + [unfold apply-match] [unfold matcht] + [cases [match-in p t Nil] :as hm + [None [unfold wrap-subst]] + [Some [unfold wrap-subst] [rewrite match-in-sound]]]]