narju/

surface.rs

use smol_str::SmolStr;

use crate::floor::host::{OpDef, Registry};
use crate::floor::read::{self, form_arity};
use crate::floor::{list, list_elements, rc_val, Shared, Val};

pub fn extend(r: Registry) -> Registry {
    r.op(OpDef {
        name: "desugar",
        arity: 1,
        run: |a| desugar_top(&a[0]),
    })
    .op(OpDef {
        name: "desugar-body",
        arity: 1,
        run: |a| match list_elements(&a[0]) {
            Some(forms) => desugar_body(&forms),
            None => Err(err("desugar", "a body is a list of forms")),
        },
    })
}

fn err(tag: &str, detail: impl Into<String>) -> Val {
    Val::Pair(
        rc_val(Val::Sym(SmolStr::new(tag))),
        rc_val(crate::floor::host::Str::val(detail.into())),
    )
}

fn sym(s: &str) -> Val {
    Val::Sym(SmolStr::new(s))
}

fn is(v: &Val, name: &str) -> bool {
    matches!(v, Val::Sym(s) if s == name)
}

struct Gen(usize);

impl Gen {
    fn next(&mut self) -> Val {
        self.0 += 1;
        Val::Sym(SmolStr::new(format!("%{}", self.0)))
    }
}

pub fn desugar_top(v: &Val) -> Result<Val, Val> {
    desugar(v, &mut Gen(0))
}

pub fn desugar_body(forms: &[Val]) -> Result<Val, Val> {
    body(forms, &mut Gen(0))
}

fn let_(name: Val, init: Val, body: Val) -> Val {
    list(&[sym("let"), list(&[name, init]), body])
}

fn desugar(v: &Val, g: &mut Gen) -> Result<Val, Val> {
    let items = match v {
        Val::Pair(_, _) => list_elements(v).ok_or_else(|| err("desugar", "improper form"))?,
        other => return Ok(other.clone()),
    };
    let head = &items[0];
    let args = &items[1..];

    if let Val::Sym(name) = head {
        match name.as_str() {
            // Rewriting inside quoted data would change what the program
            // means, not how it is written.
            "quote" => {
                return match args {
                    [_] => Ok(v.clone()),
                    _ => Err(err("desugar", "quote takes one argument")),
                }
            }
            "quasiquote" => {
                return match args {
                    [t] => quasiquote(t, g),
                    _ => Err(err("desugar", "quasiquote takes one argument")),
                }
            }
            // `quasiquote` consumes the ones it owns, so arriving here means
            // there was no template to belong to.
            "unquote" | "unquote-splicing" => {
                return Err(err("desugar", "unquote outside a template"));
            }
            "lambda" | "clambda" => return lambda(name, args, g),
            "let" => return let_form(args, g),
            "begin" => return body(args, g),
            "cond" => return cond(args, g),
            "case" => return case(args, g),
            "and" => return and(args, g),
            "or" => return or(args, g),
            "list" => {
                let mut acc = Val::Nil;
                for a in args.iter().rev() {
                    acc = list(&[sym("cons"), desugar(a, g)?, acc]);
                }
                return Ok(acc);
            }
            // Both extend what the rest of a body sees, so neither means
            // anything where there is no rest.
            "define" => {
                return Err(err("desugar", "define outside a body"));
            }
            "import" => {
                return Err(err("desugar", "import outside a body"));
            }
            // A floor form at the arity the floor knows it at. Anything else
            // with this name - a shadowed `car`, a wrong-arity call - falls
            // through to application, and `trans` decides.
            _ if form_arity(name).is_some_and(|n| n == args.len()) => {
                let mut out = vec![head.clone()];
                for a in args {
                    out.push(desugar(a, g)?);
                }
                return Ok(list(&out));
            }
            _ => {}
        }
    }

    // The floor takes an application at the arity it is written at, so there
    // is nothing to curry and no argument to invent for a nullary call.
    let mut out = vec![desugar(head, g)?];
    for a in args {
        out.push(desugar(a, g)?);
    }
    Ok(list(&out))
}

fn cons(a: Val, b: Val) -> Val {
    list(&[sym("cons"), a, b])
}

fn quoted(v: Val) -> Val {
    list(&[sym("quote"), v])
}

/// What `(unquote e)` and its relatives look like once the reader has turned
/// the prefix into a form.
fn marked(v: &Val) -> Option<(&str, &Val)> {
    let Val::Pair(head, rest) = v else {
        return None;
    };
    let Val::Sym(name) = &**head else {
        return None;
    };
    match &**rest {
        Val::Pair(e, tail) if matches!(**tail, Val::Nil) => Some((name.as_str(), e)),
        _ => None,
    }
}

/// `` `t ``, as the `cons` calls that rebuild the shape around its holes.
/// Nesting is counted rather than refused, which is the only reason `depth`
/// exists. The floor has no `append`, so a splice gets one emitted per
/// template rather than a free reference to a library that may not be loaded.
fn quasiquote(t: &Val, g: &mut Gen) -> Result<Val, Val> {
    let mut joiner = None;
    let out = quasi(t, 1, g, &mut joiner)?;
    Ok(match joiner {
        None => out,
        Some(j) => let_(j.clone(), join_fn(&j), out),
    })
}

/// Self-bound, so it can recur without a name from anywhere else.
fn join_fn(j: &Val) -> Val {
    let step = cons(
        list(&[sym("car"), sym("xs")]),
        list(&[j.clone(), list(&[sym("cdr"), sym("xs")]), sym("ys")]),
    );
    list(&[
        sym("lambda"),
        list(&[j.clone(), sym("xs"), sym("ys")]),
        list(&[sym("if"), list(&[sym("nil?"), sym("xs")]), sym("ys"), step]),
    ])
}

fn quasi(t: &Val, depth: usize, g: &mut Gen, joiner: &mut Option<Val>) -> Result<Val, Val> {
    if let Some((tag, e)) = marked(t) {
        match tag {
            "unquote" if depth == 1 => return desugar(e, g),
            "unquote" => {
                let inner = quasi(e, depth - 1, g, joiner)?;
                return Ok(cons(quoted(sym("unquote")), cons(inner, Val::Nil)));
            }
            "quasiquote" => {
                let inner = quasi(e, depth + 1, g, joiner)?;
                return Ok(cons(quoted(sym("quasiquote")), cons(inner, Val::Nil)));
            }
            "unquote-splicing" if depth > 1 => {
                let inner = quasi(e, depth - 1, g, joiner)?;
                return Ok(cons(quoted(sym("unquote-splicing")), cons(inner, Val::Nil)));
            }
            // Tail position, where the spine walk below hands one over: there
            // is no list here to join onto.
            "unquote-splicing" => {
                return Err(err("desugar", "unquote-splicing outside a list"));
            }
            _ => {}
        }
    }
    if !matches!(t, Val::Pair(_, _)) {
        return Ok(quoted(t.clone()));
    }

    // Stops at a hole rather than walking through one: `(a . ,b)` and
    // `(a unquote b)` are the same three pairs, so a walk that did not look
    // would take the dotted tail apart into two more elements.
    let mut spine = Vec::new();
    let mut cur = t;
    while let Val::Pair(head, rest) = cur {
        if marked(cur).is_some_and(|(tag, _)| is_hole(tag)) {
            break;
        }
        spine.push(&**head);
        cur = rest;
    }
    // Never `t` itself: every marked form was answered above, so the walk has
    // taken at least one step before it can stop at one.
    let mut acc = quasi(cur, depth, g, joiner)?;
    for head in spine.into_iter().rev() {
        acc = match marked(head) {
            Some(("unquote-splicing", e)) if depth == 1 => {
                let j = joiner.get_or_insert_with(|| g.next()).clone();
                list(&[j, desugar(e, g)?, acc])
            }
            _ => cons(quasi(head, depth, g, joiner)?, acc),
        };
    }
    Ok(acc)
}

fn is_hole(tag: &str) -> bool {
    matches!(tag, "unquote" | "unquote-splicing" | "quasiquote")
}

/// A named lambda is bound to its own name inside the body, which is what the
/// floor's self-binding argument is for. `clambda` takes the same shape.
fn lambda(kw: &str, args: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let (me, params, rest) = match args {
        [Val::Sym(_), p, rest @ ..] if !rest.is_empty() => (args[0].clone(), p, rest),
        [p, rest @ ..] if !rest.is_empty() && !matches!(p, Val::Sym(_)) => (sym("_"), p, rest),
        _ => return Err(err("desugar", "lambda takes a parameter list and a body")),
    };
    // 3-Lisp's spelling. A reflective procedure takes its whole reified call
    // site, so it has no name to recur through and the name position is the
    // marker instead.
    if is(&me, "reflect") {
        if kw != "lambda" {
            return Err(err("desugar", "only lambda can be reflective"));
        }
        return Ok(list(&[sym("rlambda"), params.clone(), body(rest, g)?]));
    }
    let params =
        list_elements(params).ok_or_else(|| err("desugar", "lambda's parameters are a list"))?;
    // The floor binds only names, so a parameter that is a shape is named here
    // and taken apart at the top of the body, as `let` does with one.
    let mut binders = vec![me];
    let mut shapes = Vec::new();
    for p in params {
        match p {
            Val::Sym(_) => binders.push(p),
            _ => {
                let t = g.next();
                binders.push(t.clone());
                shapes.push((p, t));
            }
        }
    }
    let mut b = body(rest, g)?;
    for (pat, t) in shapes.iter().rev() {
        b = bind(pat, t.clone(), b, g)?;
    }
    Ok(list(&[sym(kw), list(&binders), b]))
}

/// `(let ((x a) (y b)) body...)`, and the floor's single-binding
/// `(let (x a) body)`, told apart by whether the first element of the binding
/// list is a symbol - which a binder must be and a binding never is. That test
/// is why the single-binding form takes a name and not a shape. Bindings are
/// sequential because nesting them is what the floor's one-at-a-time binding
/// gives; two that read each other are two `define`s, not a `letrec`.
fn let_form(args: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let (head, rest) = args
        .split_first()
        .ok_or_else(|| err("desugar", "let takes bindings and a body"))?;
    if rest.is_empty() {
        return Err(err("desugar", "let takes bindings and a body"));
    }
    let items = list_elements(head).ok_or_else(|| err("desugar", "let's bindings are a list"))?;

    let bindings = match items.first() {
        Some(Val::Sym(_)) => vec![head.clone()],
        _ => items,
    };

    let mut acc = body(rest, g)?;
    for b in bindings.iter().rev() {
        let parts = list_elements(b).ok_or_else(|| err("desugar", "a binding is (name init)"))?;
        let [name, init] = parts.as_slice() else {
            return Err(err("desugar", "a binding is (name init)"));
        };
        acc = bind(name, desugar(init, g)?, acc, g)?;
    }
    Ok(acc)
}

/// The fold at the end of [`body`] turns each of these into the construct that
/// binds what follows it.
enum Wrap {
    Bind(Val, Val),
    Import(Val),
}

/// `Fun` is a definition whose value is a lambda and so has no effect to
/// reorder, which is the only thing that makes a recursive group possible.
enum Step {
    Fun(Val, Val),
    Bind(Val, Val),
    Import(Val),
    Expr(Val),
}

/// A `define` binds the rest of the sequence, so definition and sequencing are
/// the same construct and neither needs a mutable frame. An `import` extends
/// what follows by a whole frame whose contents are not known here, so the
/// rewrite has the same shape and the work is left to the evaluator. A run of
/// consecutive function definitions goes to [`group`] instead; it ends at
/// anything with an effect or a value that cannot be forward-referenced.
fn body(forms: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let (last, init) = forms
        .split_last()
        .ok_or_else(|| err("desugar", "empty body"))?;
    if definition(last).is_some() || import(last).is_some() {
        return Err(err("desugar", "a body ends in an expression"));
    }

    let mut steps = Vec::with_capacity(init.len());
    for f in init {
        steps.push(match (definition(f), import(f)) {
            (Some((name, expr)), _) => {
                let e = desugar(&expr, g)?;
                match (&name, arity(&e)) {
                    (Val::Sym(_), Some(_)) => Step::Fun(name, e),
                    _ => Step::Bind(name, e),
                }
            }
            (_, Some(expr)) => Step::Import(desugar(&expr, g)?),
            _ => Step::Expr(desugar(f, g)?),
        });
    }

    let mut wraps = Vec::with_capacity(steps.len());
    let mut i = 0;
    while i < steps.len() {
        let run = steps[i..]
            .iter()
            .take_while(|s| matches!(s, Step::Fun(_, _)))
            .count();
        if run > 0 {
            let mut fns = Vec::with_capacity(run);
            for s in &steps[i..i + run] {
                if let Step::Fun(n, e) = s {
                    fns.push((n.clone(), e.clone()));
                }
            }
            group(&fns, &mut wraps, g);
            i += run;
            continue;
        }
        match &steps[i] {
            Step::Bind(n, e) => wraps.push(Wrap::Bind(n.clone(), e.clone())),
            Step::Import(e) => wraps.push(Wrap::Import(e.clone())),
            Step::Expr(e) => wraps.push(Wrap::Bind(sym("_"), e.clone())),
            Step::Fun(_, _) => unreachable!("a run of them was just taken"),
        }
        i += 1;
    }

    let mut acc = desugar(last, g)?;
    for w in wraps.into_iter().rev() {
        acc = match w {
            Wrap::Bind(n, e) => let_(n, e, acc),
            Wrap::Import(e) => list(&[sym("import"), e, acc]),
        };
    }
    Ok(acc)
}

/// A run of consecutive function definitions, as the bindings that make them
/// mutually visible. Sorting so each comes after the ones it reads is free -
/// every value is a lambda, so moving one reorders no effect - and is stable
/// where the reads allow. Definitions that read *each other* cannot be sorted
/// and go to [`knot`], in the largest sets that must be tied together so one
/// cycle does not make a long run pay. A name defined twice leaves the run a
/// plain chain: which one a forward reference meant has no answer here.
fn group(fns: &[(Val, Val)], wraps: &mut Vec<Wrap>, g: &mut Gen) {
    let plain = |wraps: &mut Vec<Wrap>| {
        for (n, e) in fns {
            wraps.push(Wrap::Bind(n.clone(), e.clone()));
        }
    };

    let names: Vec<SmolStr> = fns
        .iter()
        .filter_map(|(n, _)| match n {
            Val::Sym(s) => Some(s.clone()),
            _ => None,
        })
        .collect();
    let n = names.len();
    if n != fns.len()
        || names
            .iter()
            .enumerate()
            .any(|(i, x)| names[..i].contains(x))
    {
        return plain(wraps);
    }

    let mut edges: Vec<Vec<usize>> = Vec::with_capacity(n);
    for (_, e) in fns {
        let mut hit = Vec::new();
        reads(e, &names, &mut hit);
        edges.push(
            hit.iter()
                .filter_map(|x| names.iter().position(|y| y == x))
                .collect(),
        );
    }
    if edges.iter().all(Vec::is_empty) {
        return plain(wraps);
    }

    // A bitmap row rather than a row of bools: a file is one run of
    // definitions and may have a thousand, so the transitive closure is a
    // million word-ors and not a billion byte-ors.
    let w = n.div_ceil(64);
    let mut to = vec![0u64; n * w];
    for (i, es) in edges.iter().enumerate() {
        for &j in es {
            to[i * w + j / 64] |= 1 << (j % 64);
        }
    }
    for k in 0..n {
        for i in 0..n {
            if to[i * w + k / 64] >> (k % 64) & 1 == 1 {
                for c in 0..w {
                    to[i * w + c] |= to[k * w + c];
                }
            }
        }
    }
    let reaches = |i: usize, j: usize| to[i * w + j / 64] >> (j % 64) & 1 == 1;

    // Each name's cycle, named by its earliest member.
    let mut cycle: Vec<usize> = (0..n).collect();
    for i in 0..n {
        if let Some(j) = (0..i).find(|&j| reaches(i, j) && reaches(j, i)) {
            cycle[i] = cycle[j];
        }
    }

    let mut done = vec![false; n];
    let mut left = n;
    while left > 0 {
        let ready = (0..n).find(|&rep| {
            cycle[rep] == rep
                && !done[rep]
                && (0..n)
                    .filter(|&i| cycle[i] == rep)
                    .all(|i| edges[i].iter().all(|&j| cycle[j] == rep || done[j]))
        });
        // The cycles of a graph form one without cycles, so some cycle always
        // has its reads satisfied. Falling back rather than asserting, since
        // being wrong should cost a program its recursion, not its build.
        let Some(rep) = ready else {
            for i in 0..n {
                if !done[i] {
                    wraps.push(Wrap::Bind(fns[i].0.clone(), fns[i].1.clone()));
                }
            }
            return;
        };
        let members: Vec<usize> = (0..n).filter(|&i| cycle[i] == rep).collect();
        for &i in &members {
            done[i] = true;
        }
        left -= members.len();
        match members.as_slice() {
            [i] => wraps.push(Wrap::Bind(fns[*i].0.clone(), fns[*i].1.clone())),
            _ => knot(fns, &members, wraps, g),
        }
    }
}

/// A set of definitions that read each other, as bindings: one self-named
/// lambda taking the index of the member wanted, with each member bound inside
/// to a forwarder that asks the lambda for it. Nothing is assigned, because the
/// floor's cell is not a form the tower's evaluator knows - so the cycle is
/// rebuilt on the way round instead, at one allocation per sibling reach.
///
/// A knot cannot be compiled: every index is a literal, so the specializer
/// resolves siblings statically and goes round until the occurs-check stops it
/// (`a_cycle_refuses_to_compile_and_says_which`, `src/tower.rs`). Sorting is
/// the half that survives compilation, which is why the two are kept separate.
fn knot(fns: &[(Val, Val)], members: &[usize], wraps: &mut Vec<Wrap>, g: &mut Gen) {
    // Named for the cycle it stands for, since the specializer reports this
    // one alongside the members when it refuses to unfold them.
    let grp = match g.next() {
        Val::Sym(n) => {
            let mut s = n.to_string();
            for &i in members {
                if let Val::Sym(m) = &fns[i].0 {
                    s.push('/');
                    s.push_str(m);
                }
            }
            Val::Sym(SmolStr::new(s))
        }
        other => other,
    };
    let idx = g.next();

    let mut b = Val::Num(0);
    for (at, &i) in members.iter().enumerate().rev() {
        b = list(&[
            sym("if"),
            list(&[sym("eq?"), idx.clone(), Val::Num(at as i64)]),
            fns[i].1.clone(),
            b,
        ]);
    }
    for (at, &i) in members.iter().enumerate().rev() {
        let k = arity(&fns[i].1).expect("a run's definitions are lambdas");
        let args: Vec<Val> = (0..k).map(|_| g.next()).collect();
        // Named for the member it stands in for, though its body does not
        // recur: the specializer reports the names on a refused cycle, and
        // those must be the program's rather than the ones invented here.
        let mut binders = vec![fns[i].0.clone()];
        binders.extend(args.iter().cloned());
        let mut call = vec![list(&[grp.clone(), Val::Num(at as i64)])];
        call.extend(args);
        b = let_(
            fns[i].0.clone(),
            list(&[sym("lambda"), list(&binders), list(&call)]),
            b,
        );
    }

    wraps.push(Wrap::Bind(
        grp.clone(),
        list(&[sym("lambda"), list(&[grp.clone(), idx]), b]),
    ));
    for (at, &i) in members.iter().enumerate() {
        wraps.push(Wrap::Bind(
            fns[i].0.clone(),
            list(&[grp.clone(), Val::Num(at as i64)]),
        ));
    }
}

/// A reflective lambda answers `None`: it is applied to its call site rather
/// than to arguments, so a forwarder standing in for it would not be one.
fn arity(e: &Val) -> Option<usize> {
    let items = spine(e);
    match items.as_slice() {
        [head, binders, _] if is(head, "lambda") || is(head, "clambda") => {
            Some(spine(binders).len().checked_sub(1)?)
        }
        _ => None,
    }
}

/// An improper tail is dropped, which only reaches quoted data - and [`reads`]
/// does not look inside that.
fn spine(v: &Val) -> Vec<&Val> {
    let mut out = Vec::new();
    let mut cur = v;
    while let Val::Pair(head, rest) = cur {
        out.push(&**head);
        cur = rest;
    }
    out
}

/// Shared between the pending items of [`reads`] rather than copied into each,
/// so a deep expression costs one link per binder and not one set per node.
struct Scope {
    name: SmolStr,
    rest: Option<Shared<Scope>>,
}

fn shadowed(mut s: Option<&Shared<Scope>>, name: &SmolStr) -> bool {
    while let Some(l) = s {
        if &l.name == name {
            return true;
        }
        s = l.rest.as_ref();
    }
    false
}

fn under(s: &Option<Shared<Scope>>, binders: &[&Val]) -> Option<Shared<Scope>> {
    let mut out = s.clone();
    for b in binders {
        if let Val::Sym(name) = b {
            out = Some(Shared::new(Scope {
                name: name.clone(),
                rest: out,
            }));
        }
    }
    out
}

/// Which of `names` an already-rewritten expression reads without binding them
/// itself. It runs after the rewrite so the binding forms are the floor's three
/// plus `import`, rather than everything the surface has. A name an `import`
/// supplies is still reported, which is the safe direction: the caller may sort
/// a definition it did not have to, never fail to sort one it did.
fn reads(e: &Val, names: &[SmolStr], out: &mut Vec<SmolStr>) {
    let mut work = vec![(e, None::<Shared<Scope>>)];
    while let Some((v, sc)) = work.pop() {
        let Val::Sym(s) = v else {
            if !matches!(v, Val::Pair(_, _)) {
                continue;
            }
            let items = spine(v);
            if let Val::Sym(head) = items[0] {
                match (head.as_str(), items.len()) {
                    ("quote", 2) => continue,
                    ("lambda" | "clambda" | "rlambda", 3) => {
                        work.push((items[2], under(&sc, &spine(items[1]))));
                        continue;
                    }
                    ("let", 3) => {
                        let b = spine(items[1]);
                        if let [name, init] = b.as_slice() {
                            work.push((init, sc.clone()));
                            work.push((items[2], under(&sc, &[name])));
                            continue;
                        }
                    }
                    ("import", 3) => {
                        work.push((items[1], sc.clone()));
                        work.push((items[2], sc));
                        continue;
                    }
                    _ => {}
                }
            }
            work.extend(items.into_iter().map(|x| (x, sc.clone())));
            continue;
        };
        if names.contains(s) && !shadowed(sc.as_ref(), s) && !out.contains(s) {
            out.push(s.clone());
        }
    }
}

fn import(v: &Val) -> Option<Val> {
    let items = list_elements(v)?;
    if !is(items.first()?, "import") {
        return None;
    }
    match &items[1..] {
        [expr] => Some(expr.clone()),
        _ => None,
    }
}

fn definition(v: &Val) -> Option<(Val, Val)> {
    let items = list_elements(v)?;
    if !is(items.first()?, "define") {
        return None;
    }
    match &items[1..] {
        [name @ Val::Sym(_), expr] => Some((name.clone(), expr.clone())),
        [head, rest @ ..] if !rest.is_empty() => {
            let sig = list_elements(head)?;
            let (name, params) = sig.split_first()?;
            let mut lam = vec![sym("lambda"), name.clone(), list(params)];
            lam.extend_from_slice(rest);
            Some((name.clone(), list(&lam)))
        }
        _ => None,
    }
}

fn cond(clauses: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let mut acc = Val::Nil;
    for c in clauses.iter().rev() {
        let parts = list_elements(c).ok_or_else(|| err("desugar", "a cond clause is a list"))?;
        let (test, rest) = parts
            .split_first()
            .ok_or_else(|| err("desugar", "an empty cond clause"))?;
        if rest.is_empty() {
            return Err(err("desugar", "a cond clause needs a body"));
        }
        let then = body(rest, g)?;
        acc = if is(test, "else") {
            then
        } else {
            list(&[sym("if"), desugar(test, g)?, then, acc])
        };
    }
    Ok(acc)
}

/// The key is named once and each clause tests it with `eq?`, so a clause
/// listing several keys costs a comparison apiece and still writes its body
/// once. Clause heads are data, not expressions, and are not evaluated.
fn case(args: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let (subject, clauses) = args
        .split_first()
        .ok_or_else(|| err("desugar", "case takes a key and clauses"))?;
    let key = g.next();

    let mut acc = Val::Nil;
    for c in clauses.iter().rev() {
        let parts = list_elements(c).ok_or_else(|| err("desugar", "a case clause is a list"))?;
        let (keys, rest) = parts
            .split_first()
            .ok_or_else(|| err("desugar", "an empty case clause"))?;
        if rest.is_empty() {
            return Err(err("desugar", "a case clause needs a body"));
        }
        let then = body(rest, g)?;
        if is(keys, "else") {
            acc = then;
            continue;
        }
        let ks =
            list_elements(keys).ok_or_else(|| err("desugar", "a case clause's keys are a list"))?;
        let mut test = Val::Num(0);
        for k in ks.iter().rev() {
            test = list(&[
                sym("if"),
                list(&[sym("eq?"), key.clone(), quoted(k.clone())]),
                Val::Num(1),
                test,
            ]);
        }
        acc = list(&[sym("if"), test, then, acc]);
    }
    Ok(let_(key, desugar(subject, g)?, acc))
}

/// A binder: a symbol names the whole value, a list names its parts by
/// position, a dotted tail names the rest.
///
/// The temporary is not an optimisation and cannot be dropped when the init is
/// already a variable - a pattern may bind a name the init also mentions,
/// `(let (((a b) a)) …)`, and since the emitted bindings nest, the second
/// accessor would read the name the first just rebound. Nothing checks the
/// shape: `car` of a non-pair already raises, naming the accessor rather than
/// the pattern.
fn bind(pat: &Val, init: Val, inner: Val, g: &mut Gen) -> Result<Val, Val> {
    match pat {
        Val::Sym(_) => Ok(let_(pat.clone(), init, inner)),
        // A pattern with no names left still runs its init: a binder position
        // is not a place to decide an expression is dead.
        Val::Nil => Ok(let_(sym("_"), init, inner)),
        Val::Pair(head, rest) => {
            let t = g.next();
            let acc = bind(rest, list(&[sym("cdr"), t.clone()]), inner, g)?;
            let acc = bind(head, list(&[sym("car"), t.clone()]), acc, g)?;
            Ok(let_(t, init, acc))
        }
        _ => Err(err("desugar", "a binder is a name or a list of them")),
    }
}

fn and(args: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let Some((last, init)) = args.split_last() else {
        return Ok(Val::Num(1));
    };
    let mut acc = desugar(last, g)?;
    for a in init.iter().rev() {
        acc = list(&[sym("if"), desugar(a, g)?, acc, Val::Num(0)]);
    }
    Ok(acc)
}

/// `or` returns the value of the test that succeeded, so each test needs
/// a name: evaluating it twice would duplicate its effects.
fn or(args: &[Val], g: &mut Gen) -> Result<Val, Val> {
    let Some((last, init)) = args.split_last() else {
        return Ok(Val::Num(0));
    };
    let mut acc = desugar(last, g)?;
    for a in init.iter().rev() {
        let t = g.next();
        acc = let_(
            t.clone(),
            desugar(a, g)?,
            list(&[sym("if"), t.clone(), t, acc]),
        );
    }
    Ok(acc)
}

pub fn compile(src: &str) -> Result<Val, Val> {
    let forms = read::read(src)?;
    let lowered = body(&forms, &mut Gen(0))?;
    read::trans(&lowered, &Val::Nil)
}

/// An embedder that wants more host types or ops extends this further.
pub fn registry() -> Registry {
    extend(crate::floor::host::builtins())
}

#[cfg(test)]
mod tests {
    use super::*;
    use crate::floor::machine::{Machine, NoMail, Store};
    use crate::floor::Env;

    fn one(src: &str) -> Val {
        let forms = read::read(src).expect("reads");
        assert_eq!(forms.len(), 1);
        forms[0].clone()
    }

    fn d(src: &str) -> Val {
        desugar_top(&one(src)).expect("rewrites")
    }

    fn db(src: &str) -> Val {
        desugar_body(&read::read(src).expect("reads")).expect("rewrites")
    }

    fn run(src: &str) -> Val {
        let exp = match compile(src).expect("compiles") {
            Val::Code(e) => e,
            other => panic!("expected code, got {other}"),
        };
        Machine::new(Env::default(), exp)
            .run(&mut Store::<NoMail>::default())
            .expect("no fault")
    }

    #[test]
    fn an_n_ary_lambda_keeps_its_arity_and_its_name() {
        assert_eq!(
            d("(lambda f (a b) (f a b))"),
            one("(lambda (f a b) (f a b))")
        );
    }

    #[test]
    fn a_reflective_lambda_does_not_curry() {
        assert_eq!(
            d("(lambda reflect (m l e r k) e)"),
            one("(rlambda (m l e r k) e)")
        );
    }

    #[test]
    fn a_nullary_function_takes_no_argument() {
        assert_eq!(d("(lambda () 1)"), one("(lambda (_) 1)"));
        assert_eq!(d("(f)"), one("(f)"));
    }

    #[test]
    fn a_definition_binds_the_rest_of_its_body() {
        assert_eq!(
            d("(begin (define x 1) (define (f a) a) (f x))"),
            one("(let (x 1) (let (f (lambda (f a) a)) (f x)))")
        );
    }

    #[test]
    fn a_form_and_a_call_both_get_their_operands_rewritten() {
        assert_eq!(
            d("(cons (or a b) c)"),
            one("(cons (let (%1 a) (if %1 %1 b)) c)")
        );
        assert_eq!(d("(f (or a b) c)"), one("(f (let (%1 a) (if %1 %1 b)) c)"));
    }

    #[test]
    fn rewriting_does_not_reach_inside_quoted_data() {
        assert_eq!(d("'(lambda (a b c) x)"), one("'(lambda (a b c) x)"));
    }

    #[test]
    fn or_names_each_test_so_it_is_evaluated_once() {
        assert_eq!(d("(or a b)"), one("(let (%1 a) (if %1 %1 b))"));
    }

    #[test]
    fn the_rewritten_surface_runs() {
        assert_eq!(
            run("(define (fact n) (if (< n 1) 1 (* n (fact (- n 1)))))
                 (fact 5)"),
            Val::Num(120)
        );
        assert_eq!(
            run("(define (sum3 a b c) (+ a (+ b c)))
                 (sum3 1 2 3)"),
            Val::Num(6)
        );
        assert_eq!(
            run("(cond ((< 2 1) 'lt) (else 'ge))"),
            Val::Sym("ge".into())
        );
        assert_eq!(run("(and 1 2)"), Val::Num(2));
        assert_eq!(run("(or 0 7)"), Val::Num(7));
        assert_eq!(run("(car (cdr (list 1 2 3)))"), Val::Num(2));
    }

    #[test]
    fn a_thousand_definitions_do_not_recurse() {
        let mut src = String::new();
        for i in 0..1000 {
            src.push_str(&format!("(define x{i} {i})\n"));
        }
        src.push_str("x999");
        assert_eq!(run(&src), Val::Num(999));
    }

    #[test]
    fn the_surface_stages_the_same_way_the_floor_does() {
        // The power specializer again, written the way anyone would.
        assert_eq!(
            run("(define (pow n)
                   (lambda (x) (if (< n 1) (lift 1) (* x ((pow (- n 1)) x)))))
                 ((run 0 (lift (pow 3))) 2)"),
            Val::Num(8)
        );
    }

    #[test]
    fn the_template_prefixes_read_as_the_forms_they_stand_for() {
        assert_eq!(one("`x"), one("(quasiquote x)"));
        assert_eq!(one(",x"), one("(unquote x)"));
        assert_eq!(one(",@x"), one("(unquote-splicing x)"));
        assert_eq!(one("`,x"), one("(quasiquote (unquote x))"));
        assert_eq!(one("'`x"), one("(quote (quasiquote x))"));
    }

    #[test]
    fn a_template_with_no_holes_is_a_quotation() {
        assert_eq!(d("`(a b)"), one("(cons 'a (cons 'b '()))"));
    }

    #[test]
    fn a_template_rebuilds_the_shape_around_its_holes() {
        assert_eq!(d("`(a ,b)"), one("(cons 'a (cons b '()))"));
        assert_eq!(d("`(a . ,b)"), one("(cons 'a b)"));
        assert_eq!(run("(let ((b 2)) `(1 ,b 3))"), run("'(1 2 3)"));
        assert_eq!(run("(let ((b 2)) `(1 . ,b))"), run("'(1 . 2)"));
    }

    #[test]
    fn a_splice_brings_its_own_joiner() {
        assert_eq!(run("(let ((xs '(2 3))) `(1 ,@xs 4))"), run("'(1 2 3 4)"));
        assert_eq!(run("(let ((xs '())) `(1 ,@xs))"), run("'(1)"));
        assert_eq!(
            run("(let ((xs '(1)) (ys '(2))) `(,@xs ,@ys))"),
            run("'(1 2)")
        );
    }

    #[test]
    fn a_nested_template_holds_its_inner_holes_as_data() {
        assert_eq!(
            run("(let ((b 2)) `(a `(c ,b)))"),
            run("'(a (quasiquote (c (unquote b))))")
        );
        assert_eq!(
            run("(let ((b 2)) `(a `(c ,,b)))"),
            run("'(a (quasiquote (c (unquote 2))))")
        );
    }

    #[test]
    fn a_hole_outside_a_template_is_refused() {
        assert!(desugar_top(&one(",x")).is_err());
        assert!(desugar_top(&one("`,@x")).is_err());
    }

    #[test]
    fn case_compares_one_key_against_each_clause() {
        assert_eq!(run("(case 'b ((a) 1) ((b c) 2) (else 3))"), Val::Num(2));
        assert_eq!(run("(case 'c ((a) 1) ((b c) 2) (else 3))"), Val::Num(2));
        assert_eq!(run("(case 'z ((a) 1) ((b c) 2) (else 3))"), Val::Num(3));
        assert_eq!(run("(case 'z ((a) 1))"), Val::Nil);
    }

    #[test]
    fn a_case_key_is_named_and_its_clause_heads_are_not() {
        assert_eq!(
            d("(case k ((a) 1) (else 2))"),
            one("(let (%1 k) (if (if (eq? %1 'a) 1 0) 1 2))")
        );
    }

    #[test]
    fn a_binder_may_be_a_shape_rather_than_a_name() {
        assert_eq!(run("(let (((a b) '(1 2))) (- a b))"), Val::Num(-1));
        assert_eq!(run("(let (((a . r) '(1 2 3))) (car r))"), Val::Num(2));
        assert_eq!(
            run("(let ((((a b) c) '((1 2) 3))) (+ a (+ b c)))"),
            Val::Num(6)
        );
    }

    #[test]
    fn a_parameter_may_be_a_shape_too() {
        assert_eq!(run("((lambda ((a b)) (- a b)) '(1 2))"), Val::Num(-1));
        assert_eq!(
            run("(define (f x (a . r)) (+ x (+ a (car r)))) (f 1 '(2 3))"),
            Val::Num(6)
        );
    }

    #[test]
    fn a_shape_may_rebind_a_name_its_init_reads() {
        assert_eq!(
            run("(let ((a '(1 2))) (let (((a b) a)) (- a b)))"),
            Val::Num(-1)
        );
    }

    #[test]
    fn bindings_are_sequential_and_a_later_one_sees_an_earlier() {
        assert_eq!(d("(let ((x 1) (y x)) y)"), one("(let (x 1) (let (y x) y))"));
        assert_eq!(run("(let ((x 1) (y (+ x 1))) (* x y))"), Val::Num(2));
    }

    #[test]
    fn a_definition_may_call_one_written_below_it() {
        assert_eq!(
            run("(define (a n) (b (+ n 1)))
                 (define (b n) (* n 2))
                 (a 3)"),
            Val::Num(8)
        );
        assert_eq!(
            db("(define (a) (b)) (define (b) 1) (a)"),
            db("(define (b) 1) (define (a) (b)) (a)")
        );
    }

    #[test]
    fn a_run_that_reads_nothing_is_left_in_order() {
        assert_eq!(
            db("(define (a) 1) (define (b) 2) (+ (a) (b))"),
            one("(let (a (lambda (a) 1)) (let (b (lambda (b) 2)) (+ (a) (b))))")
        );
    }

    #[test]
    fn definitions_that_read_each_other_are_tied() {
        assert_eq!(
            run("(define (ev? n) (if (eq? n 0) 1 (od? (- n 1))))
                 (define (od? n) (if (eq? n 0) 0 (ev? (- n 1))))
                 (+ (* 10 (ev? 8)) (od? 7))"),
            Val::Num(11)
        );
    }

    #[test]
    fn a_cycle_may_be_longer_than_two() {
        assert_eq!(
            run("(define (up n) (if (eq? n 0) 0 (+ 1 (down (- n 1)))))
                 (define (down n) (if (eq? n 0) 0 (+ 1 (side (- n 1)))))
                 (define (side n) (if (eq? n 0) 0 (+ 1 (up (- n 1)))))
                 (up 9)"),
            Val::Num(9)
        );
    }

    #[test]
    fn a_cycle_ties_only_its_own_members() {
        // `p` and `q` have nothing to do with the cycle beside them and
        // come out as the `let`s they would have been on their own.
        let out = format!(
            "{}",
            db("(define (p) 1)
                (define (ev? n) (od? n))
                (define (od? n) (ev? n))
                (define (q) 2)
                (+ (p) (q))")
        );
        assert!(out.contains("('let ('p ('lambda ('p) 1))"), "{out}");
        assert!(out.contains("('let ('q ('lambda ('q) 2))"), "{out}");
        assert_eq!(
            run("(define (p) 1)
                 (define (ev? n) (if (eq? n 0) 1 (od? (- n 1))))
                 (define (od? n) (if (eq? n 0) 0 (ev? (- n 1))))
                 (define (q) 2)
                 (+ (p) (+ (q) (ev? 4)))"),
            Val::Num(4)
        );
    }

    #[test]
    fn a_value_definition_ends_a_run() {
        assert_eq!(
            db("(define (a) 1) (define x (a)) (define (b) x) (b)"),
            one("(let (a (lambda (a) 1))
                  (let (x (a))
                   (let (b (lambda (b) x)) (b))))")
        );
    }

    #[test]
    fn a_shadowed_name_is_not_a_read() {
        assert_eq!(
            db("(define (a) (let ((b 1)) b)) (define (b) 2) (a)"),
            one("(let (a (lambda (a) (let (b 1) b)))
                  (let (b (lambda (b) 2)) (a)))")
        );
        assert_eq!(
            run("(define (a) (let ((b 1)) b)) (define (b) 2) (a)"),
            Val::Num(1)
        );
    }

    #[test]
    fn a_quoted_name_is_not_a_read() {
        assert_eq!(
            db("(define (a) 'b) (define (b) 1) (a)"),
            one("(let (a (lambda (a) 'b)) (let (b (lambda (b) 1)) (a)))")
        );
    }

    #[test]
    fn a_name_defined_twice_leaves_the_run_a_chain() {
        assert_eq!(
            db("(define (a) (b)) (define (b) 1) (define (b) 2) (a)"),
            one("(let (a (lambda (a) (b)))
                  (let (b (lambda (b) 1))
                   (let (b (lambda (b) 2)) (a))))")
        );
    }

    #[test]
    fn the_surface_extends_the_floor_rather_than_replacing_it() {
        let r = registry();
        assert!(r.lookup("str-append").is_some());
        assert!(r.lookup("desugar").is_some());
    }
}