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..4464e65 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,74 @@ 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..5820bad --- /dev/null +++ b/crates/loon-lang/src/check/termination.rs @@ -0,0 +1,431 @@ +//! 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..bcbbaf6 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,45 @@ 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..2ecfe43 --- /dev/null +++ b/crates/loon-lang/src/verify/bounded.rs @@ -0,0 +1,768 @@ +//! 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, + /// Inputs skipped because they violate a hypothesis. + pub vacuous: usize, +} + +/// 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], + 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 (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)) + .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, + hyps: &[(Expr, 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)); + // 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. + 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(); + 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); + } + 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() * width { + return Bounded { + error: Some(format!( + "expected {} values, got {}", + 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 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, + counterexample: Some(( + params.iter().cloned().zip(input.iter().cloned()).collect(), + l.clone(), + r.clone(), + )), + error: None, + vacuous, + }; + } + } + Bounded { + checked, + vacuous, + ..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..c6b6f73 --- /dev/null +++ b/crates/loon-lang/src/verify/infer.rs @@ -0,0 +1,400 @@ +//! 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: &HashMap, + ) -> 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(t) = current.get(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> { + 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 = 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(), + schemes: HashMap::new(), + }; + // 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 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; + } + for (name, _, _, ft) in &sigs { + let sc = inf.generalize(ft); + inf.schemes.insert((*name).clone(), sc); + } + } + 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(), + ) +} + +/// 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 `?`. +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..471629d --- /dev/null +++ b/crates/loon-lang/src/verify/kernel.rs @@ -0,0 +1,2098 @@ +//! 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) ─────────────────────────────────────── + +/// 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 +} + +/// 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); + } + } + 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(|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); + } + t.out +} + +/// 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); + } + } + 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; + } + 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` (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, + f: &FnDef, + group: &[String], + env: &HashMap, + defs: &Defs, + calls: &mut Vec<(String, Vec>)>, +) -> bool { + let rec = |c: &Expr, env: &HashMap, calls: &mut Vec<_>| { + collect_group_calls(c, f, group, env, defs, calls) + }; + match &e.kind { + 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 { + ExprKind::Symbol(s) => env.get(s).copied(), + _ => None, + }) + .collect(), + )); + items[1..].iter().all(|a| rec(a, env, calls)) + } + ExprKind::List(items) if head_sym(e) == Some("match") && items.len() >= 2 => { + if !rec(&items[1], env, 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) || 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) { + inner.insert(v.clone(), i); + } + } + } + if let Some(b) = pair.get(1) { + if !rec(b, &inner, 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| rec(c, env, 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 +/// 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) +} + +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); + 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, + /// The law's `:given` hypotheses, over its params. + pub hyps: &'a [(Expr, 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>, + /// 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, + /// 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)? +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, + 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)>, + /// 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. 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], + 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" + )); + } + } + let mut ctx = Ctx { + defs, + lemmas, + known, + partners, + 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(), + 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; + 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(); + 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 { + 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"))), + ) +} + +// ─── 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> { + 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) + .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, + 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 { + 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(target, rule, at, &mut 0, defs, &mut on_match) + .unwrap_or_else(|| Err("rule does not match".to_string())) +} + +/// Ex falso: some hypothesis in scope (or a constructor component of one), +/// evaluation-normalized, equates two distinct constructors. Distinct +/// constructor values are never equal, so the hypotheses are inconsistent +/// and the case holds vacuously. +fn contradictory(st: &State, defs: &Defs) -> 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); + 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); + 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 +} + +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(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 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) { + 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 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")) + })?; + 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, + hyps: rule.hyps, + } + } else { + Rule { + params: rule.params, + lhs, + rhs, + 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 { + 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")); + } + 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"), + )); + } + 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}`"))), + } + } + 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.iter().cloned()); + 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`. + // 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| { + 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), + hyps: st + .hyps + .iter() + .map(|(_, a, b)| (subst(a, &im, ctx.defs), subst(b, &im, ctx.defs))) + .collect(), + }, + ) + }) + .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(), + 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: pt + .hyps + .iter() + .map(|(a, b)| (subst(a, &im, ctx.defs), subst(b, &im, ctx.defs))) + .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, + 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 { + 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(()) +} + +/// `[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 new file mode 100644 index 0000000..cea8e2b --- /dev/null +++ b/crates/loon-lang/src/verify/mod.rs @@ -0,0 +1,1276 @@ +//! `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, + /// `: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]]` 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; + }; + 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 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]")); + }; + 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(), + hyps, + 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, + /// Bounded inputs that violated a hypothesis (conditional laws only). + pub vacuous: 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(); + // `[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(); + + 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(_) => { + 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()); + } + } + } + } + + 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 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() + .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, + &law.hyps, + &defs, + opts.bound, + opts.seed, + ); + let status = match (&b.counterexample, law.origin) { + (Some(_), _) => "falsified", + (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, + checked: b.checked, + vacuous: b.vacuous, + }); + } + + // 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); + } + } + } + } + } + // `: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(); + 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 !law.hyps.is_empty() && rep.checked == 0 && rep.vacuous > 0 { + continue; // never proven by vacuity + } + 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(), + 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). + 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 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(), + hyps: l.hyps.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, + }; + 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; + 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 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())); + } + 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..db9c644 --- /dev/null +++ b/crates/loon-lang/src/verify/tests.rs @@ -0,0 +1,1934 @@ +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, + hyps: &[], + }; + 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"), + hyps: vec![], + }; + 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"), + 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]"))); + 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"), + hyps: vec![], + }, + 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, + hyps: &[], + }; + 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]]"), + hyps: vec![], + }, + 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"); +} + +// ─── 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), + hyps: vec![], + } +} + +#[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"); +} + +// ─── 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/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-self-verifying-kernel.md b/docs/plans/2026-10-28-self-verifying-kernel.md new file mode 100644 index 0000000..cc8fafa --- /dev/null +++ b/docs/plans/2026-10-28-self-verifying-kernel.md @@ -0,0 +1,208 @@ +# 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; 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 +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. + +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 +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 (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 + 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. + +## 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 + 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 new file mode 100644 index 0000000..e6a7289 --- /dev/null +++ b/docs/plans/2026-10-28-verify-autoresearch.md @@ -0,0 +1,460 @@ +# 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 + | [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 +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. + +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. + +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`): + +``` +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/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/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/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..5ff7421 --- /dev/null +++ b/verify/meta/defs.oo @@ -0,0 +1,288 @@ +; 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]]]]] + +; 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]]] + +; Match `p` against `t`, extending the bindings `bs`. +[fn match-in [p t bs] + [match p + [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-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-in ps ts bs] None]]]] + +[fn match-list-in [ps ts bs] + [match ps + Nil [match ts + Nil [Some bs] + [Cons u ur] None] + [Cons q qs] [match ts + Nil None + [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. +[fn apply-match [p t] + [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 new file mode 100644 index 0000000..f3a0cf7 --- /dev/null +++ b/verify/meta/laws/subst.oo @@ -0,0 +1,70 @@ +; 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. 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]] + +; 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/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 new file mode 100644 index 0000000..3bb38e9 --- /dev/null +++ b/verify/meta/proofs/subst.oo @@ -0,0 +1,225 @@ +; 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 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 match-in] [unfold lookup] + [unfold bind-var] [unfold wrap-subst] [unfold subst] [unfold apply-var] + [rewrite sym-eq-refl]] + +; 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 + [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]]]] 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/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]]]] 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]]]]