Chapter 15: Monads, Do Notation and IO
New files
src/io_lower.rsChanged files
src/desugar.rssrc/eval.rssrc/typecheck.rssrc/ast.rssrc/data.rssrc/elaborate.rssrc/fixity.rssrc/kinds.rssrc/layout.rssrc/lexer.rssrc/lib.rssrc/main.rssrc/primitives.rssrc/rename.rssrc/session.rs
Motivation
So far, our programs have had a rather limited relationship with the outside
world. The driver evaluates main, prints the answer, and goes home. Let’s
write programs that can ask a question, read a response, and decide what to do
next.
We want to keep ordinary expressions pure, so evaluating an IO value won’t perform its effects. We’ll represent an action as a value and run it at an explicit boundary. That distinction lets us build and combine actions using the functions we already know.
The type classes from Chapter 14 give us a way to describe these combinations.
Functor, Applicative, and Monad work with IO, but they also describe useful
operations on Maybe, Either, and lists. We’ll start with what the operations
do and expand the syntax by hand. There’s plenty to understand here without
adding mystique to the vocabulary.
The Language, Now
A complete program now has main :: IO (), whether that signature is written or
inferred. The smallest example calls the new Prelude printer:
main = putStrLn "hello"
do notation also works for ordinary data. Here the two binds extract values
from Just, and pure constructs the result in the same Maybe instance:
main = print (do { x <- Just 20; y <- Just 22; pure (x+y) })
A block must end with an expression. A statement x <- action binds x only in
the remaining statements. A statement let introduces local declarations
without an in. Patterns may be nested, including tuples, lists, as-patterns,
and nominal record patterns. A failed refutable pattern calls error with its
source location. Fun has no MonadFail, so failure is a runtime error even when
the surrounding monad is Maybe.
putStr, putStrLn, getLine, print, and exitWith provide the program’s
external interface. mapM, mapM_, sequence_, when, and unless express
common sequencing patterns. A missing or wrongly typed entry point reports
E0250. A body that violates its explicit signature can instead fail during
signature checking with E0203.
Theory
Suppose an action produces an a, and the rest of our program knows how to
use that a to make the next action. Bind connects the two. Its second argument
is a function because the next action may depend on the first result. Read
this type slowly from left to right (Jones 1993).
For IO, the source checker treats IO as an abstract nominal constructor. Core
represents an action as a function from unit to its result:
The unit argument gives us somewhere to put the delay. Constructing the
function doesn’t run its body. returnIO builds a function that returns its
saved value, while bindIO builds one that runs the first action and passes
the result to the next. The effectful primitives sit inside those bodies.
Only the trusted Prelude and compiler can use this representation. Source
programs see abstract IO a values, so they can’t apply an action to ()
and run it wherever they please. That boundary is what lets ordinary Fun
expressions remain pure.
Strictness still applies. Constructing putStrLn "hello" evaluates its string
argument and returns an action. It does not print. Constructing an action with
error "bad" as an eagerly demanded argument can fail before the action runs.
Sequencing controls effects, not evaluation of arbitrary pure arguments. The
Haskell report describes the analogous do translations (Simon Marlow 2010), but its
lazy evaluation must not be imported into Fun’s operational account.
The monad laws describe intended instance behavior. The compiler checks types, not those equations. In particular, equations involving nontermination need care in a strict language. Dictionary passing remains the mechanism from Chapter 14: no new class dispatch appears in the evaluator.
Implementation
The parser calls desugar::do_block before lexical renaming. Processing the
statements backwards makes the remaining block the continuation of each bind.
A variable pattern becomes a lambda directly. A refutable pattern introduces a
case with a failure alternative. Its temporary name cannot be written as a
source identifier.
#![allow(unused)]
fn main() {
use crate::{
data::{ConId, DataEnv},
diagnostics::{Diagnostic, ErrorCode},
renamed::{self, BindGroup, Expr, Kind, Pat, PatKind, Row, RowBody},
session::{Session, Stop},
source::Span,
syn,
};
struct Desugar<'a> {
sess: &'a mut Session,
data: &'a DataEnv,
}
impl Desugar<'_> {
fn node(&mut self, kind: Kind, span: Span) -> Expr {
Expr {
kind,
span,
node: self.sess.fresh_node(),
}
}
fn constructor(&mut self, name: &str, span: Span) -> ConId {
if let Some(info) = self.data.constructor(name) {
return info.id.clone();
}
self.sess.emit(Diagnostic::error(
ErrorCode::UnboundConstructor,
format!("sugar requires constructor {name} from the Prelude"),
span,
));
ConId {
index: 0,
name: name.into(),
}
}
fn tuple(&mut self, n: usize, span: Span) -> ConId {
if !matches!(n, 0 | 2 | 3) {
self.sess.emit(Diagnostic::error(
ErrorCode::Parse,
"only unit, pairs, and triples are supported",
span,
));
}
self.constructor(
&format!("({})", ",".repeat(n.saturating_sub(1))),
span,
)
}
fn pattern(&mut self, p: Pat) -> Pat {
let span = p.span;
let kind = match p.kind {
PatKind::List(ps) => {
let nil = self.constructor("[]", span);
let cons = self.constructor(":", span);
let mut tail = Pat {
kind: PatKind::Con(nil, vec![]),
span,
};
for p in ps.into_iter().rev() {
tail = Pat {
kind: PatKind::Con(
cons.clone(),
vec![self.pattern(p), tail],
),
span,
};
}
return tail;
}
PatKind::Tuple(ps) => PatKind::Con(
self.tuple(ps.len(), span),
ps.into_iter().map(|p| self.pattern(p)).collect(),
),
PatKind::Con(id, ps) => PatKind::Con(
id,
ps.into_iter().map(|p| self.pattern(p)).collect(),
),
PatKind::As(id, p) => {
PatKind::As(id, Box::new(self.pattern(*p)))
}
PatKind::Int(n) => PatKind::Int((n << 1) >> 1),
other => other,
};
Pat { kind, span }
}
fn groups(&mut self, groups: Vec<BindGroup>) -> Vec<BindGroup> {
groups
.into_iter()
.map(|mut g| {
for b in &mut g.binds {
b.rhs = self.expression(b.rhs.clone());
}
g
})
.collect()
}
fn row(&mut self, row: Row) -> Row {
let body = match row.body {
RowBody::Plain(e) => {
RowBody::Plain(Box::new(self.expression(*e)))
}
RowBody::Guarded(gs) => RowBody::Guarded(
gs.into_iter()
.map(|(g, e)| (self.expression(g), self.expression(e)))
.collect(),
),
};
Row {
patterns: row
.patterns
.into_iter()
.map(|p| self.pattern(p))
.collect(),
body,
locals: self.groups(row.locals),
span: row.span,
}
}
fn equations(&mut self, rows: Vec<Row>, span: Span) -> Expr {
let mut rows: Vec<_> =
rows.into_iter().map(|r| self.row(r)).collect();
if rows.len() == 1
&& rows[0]
.patterns
.iter()
.all(|p| matches!(p.kind, PatKind::Var(_)))
&& matches!(rows[0].body, RowBody::Plain(_))
{
let row = rows.pop().unwrap();
let RowBody::Plain(body) = row.body else {
unreachable!()
};
let mut body = *body;
if !row.locals.is_empty() {
body =
self.node(Kind::Let(row.locals, Box::new(body)), span);
}
for p in row.patterns.into_iter().rev() {
let PatKind::Var(id) = p.kind else {
unreachable!()
};
body = self.node(Kind::Lam(id, Box::new(body)), span);
}
return body;
}
// ANCHOR: equations-match
let params: Vec<_> = (0..rows[0].patterns.len())
.map(|_| self.sess.fresh_id("$match"))
.collect();
let scruts = params
.iter()
.map(|id| self.node(Kind::Var(id.clone()), span))
.collect();
let mut body = self.node(Kind::Match(scruts, rows), span);
for id in params.into_iter().rev() {
body = self.node(Kind::Lam(id, Box::new(body)), span);
}
body
// ANCHOR_END: equations-match
}
fn expression(&mut self, expr: Expr) -> Expr {
let mut work = vec![(Some(expr), None)];
let mut values: Vec<Expr> = Vec::new();
while let Some((expr, saved)) = work.pop() {
match expr {
Some(Expr {
kind: Kind::App(f, a),
node,
span,
}) => {
work.push((None, Some((node, span))));
work.push((Some(*a), None));
work.push((Some(*f), None));
}
Some(expr) => values.push(self.expression_leaf(expr)),
None => {
let a = values.pop().expect("application argument");
let f = values.pop().expect("application function");
let (node, span) = saved.expect("application metadata");
values.push(Expr {
node,
span,
kind: Kind::App(Box::new(f), Box::new(a)),
});
}
}
}
values.pop().expect("desugared root")
}
fn expression_leaf(&mut self, expr: Expr) -> Expr {
let span = expr.span;
let kind = match expr.kind {
Kind::Record(id, fields) => Kind::Record(
id,
fields
.into_iter()
.map(|(n, e)| (n, self.expression(e)))
.collect(),
),
Kind::Project(e, n) => {
Kind::Project(Box::new(self.expression(*e)), n)
}
Kind::Update(e, fields) => Kind::Update(
Box::new(self.expression(*e)),
fields
.into_iter()
.map(|(n, e)| (n, self.expression(e)))
.collect(),
),
Kind::Annotated(e, t) => {
Kind::Annotated(Box::new(self.expression(*e)), t)
}
Kind::Bool(b) => Kind::Con(
self.constructor(if b { "True" } else { "False" }, span),
),
Kind::Equations(rows) => return self.equations(rows, span),
Kind::PatternLam(patterns, body) => {
return self.equations(
vec![Row {
patterns,
body: RowBody::Plain(body),
locals: vec![],
span,
}],
span,
);
}
Kind::Case(e, rows) => Kind::Match(
vec![self.expression(*e)],
rows.into_iter().map(|r| self.row(r)).collect(),
),
Kind::If(c, a, b) => {
let c = self.expression(*c);
let a = self.expression(*a);
let b = self.expression(*b);
let rows = [("True", a), ("False", b)]
.into_iter()
.map(|(name, body)| Row {
patterns: vec![Pat {
kind: PatKind::Con(
self.constructor(name, span),
vec![],
),
span,
}],
body: RowBody::Plain(Box::new(body)),
locals: vec![],
span,
})
.collect();
Kind::Match(vec![c], rows)
}
Kind::List(es) => {
let nil = self.constructor("[]", span);
let cons = self.constructor(":", span);
let mut tail = self.node(Kind::Con(nil), span);
for e in es.into_iter().rev() {
let con = self.node(Kind::Con(cons.clone()), span);
let head = self.expression(e);
let app = self.node(
Kind::App(Box::new(con), Box::new(head)),
span,
);
tail = self.node(
Kind::App(Box::new(app), Box::new(tail)),
span,
);
}
return tail;
}
Kind::Tuple(es) => {
let id = self.tuple(es.len(), span);
let mut value = self.node(Kind::Con(id), span);
for e in es {
let e = self.expression(e);
value = self.node(
Kind::App(Box::new(value), Box::new(e)),
span,
);
}
return value;
}
Kind::Lam(id, b) => {
Kind::Lam(id, Box::new(self.expression(*b)))
}
Kind::App(a, b) => Kind::App(
Box::new(self.expression(*a)),
Box::new(self.expression(*b)),
),
Kind::Let(gs, b) => {
Kind::Let(self.groups(gs), Box::new(self.expression(*b)))
}
Kind::Neg(a) => Kind::Neg(Box::new(self.expression(*a))),
Kind::Binary(op, a, b) => Kind::Binary(
op,
Box::new(self.expression(*a)),
Box::new(self.expression(*b)),
),
Kind::Match(..) => {
unreachable!("Match is produced by this pass")
}
other => other,
};
Expr {
kind,
span,
node: expr.node,
}
}
}
/// Produce Syn after names are resolved, preserving row scopes and guard order.
pub fn desugar(
sess: &mut Session,
program: renamed::Program,
) -> Result<syn::Program, Stop> {
let groups = {
let mut pass = Desugar {
sess,
data: &program.data,
};
pass.groups(program.groups)
};
sess.finish(syn::Program {
classes: program.classes,
data: program.data,
groups,
primitives: program.primitives,
main: program.main,
span: program.span,
})
}
/// Statements are lowered before name resolution so ordinary lexical scopes apply.
pub enum Statement {
Expr(crate::ast::Expr),
Bind(crate::ast::Pat, crate::ast::Expr),
Let(Vec<crate::ast::Binding>),
}
pub fn do_pattern(
e: crate::ast::Expr,
) -> Result<crate::ast::Pat, Diagnostic> {
use crate::ast::{Kind as K, Pat as P, PatKind as PK};
let span = e.span;
let kind = match e.kind {
K::Chain(a, pairs, None) if pairs.is_empty() => {
return do_pattern(*a);
}
K::Chain(a, pairs, None)
if pairs.iter().all(|(op, _)| op == ":") =>
{
let mut elements = vec![do_pattern(*a)?];
for (_, e) in pairs {
elements.push(do_pattern(e)?);
}
let mut tail = elements.pop().unwrap();
for head in elements.into_iter().rev() {
tail = P {
kind: PK::Con(":".into(), vec![head, tail]),
span,
};
}
return Ok(tail);
}
K::PatternAs(n, p) => PK::As(n, Box::new(do_pattern(*p)?)),
K::Paren(a) => return do_pattern(*a),
K::Var(n) if n == "_" => PK::Wild,
K::Var(n) if n.starts_with(char::is_uppercase) => {
PK::Con(n, vec![])
}
K::Var(n) => PK::Var(n),
K::App(a, b) => {
let mut p = do_pattern(*a)?;
if let PK::Con(_, ps) = &mut p.kind {
ps.push(do_pattern(*b)?);
return Ok(p);
} else {
return Err(Diagnostic::error(
ErrorCode::Parse,
"invalid do pattern",
span,
));
}
}
K::Int(n) => PK::Int(n),
K::Double(n) => PK::Double(n),
K::Char(c) => PK::Char(c),
K::String(s) => PK::String(s),
K::Neg(a) => {
if let K::Int(n) = a.kind {
PK::Int(-n)
} else {
return Err(Diagnostic::error(
ErrorCode::Parse,
"invalid negative pattern",
span,
));
}
}
K::List(es) => PK::List(
es.into_iter().map(do_pattern).collect::<Result<_, _>>()?,
),
K::Tuple(es) => PK::Tuple(
es.into_iter().map(do_pattern).collect::<Result<_, _>>()?,
),
K::Update(a, fs) => {
fn record(
mut p: P,
fields: Vec<(String, P)>,
) -> Result<P, Diagnostic> {
p.kind = match p.kind {
PK::As(n, p) => {
PK::As(n, Box::new(record(*p, fields)?))
}
PK::Con(n, ps) if ps.is_empty() => {
PK::Record(n, fields)
}
_ => {
return Err(Diagnostic::error(
ErrorCode::Parse,
"invalid record pattern",
p.span,
));
}
};
Ok(p)
}
let fields = fs
.into_iter()
.map(|(n, e)| Ok((n, do_pattern(e)?)))
.collect::<Result<_, Diagnostic>>()?;
return record(do_pattern(*a)?, fields);
}
K::Record(n, fs) => PK::Record(
n,
fs.into_iter()
.map(|(n, e)| Ok((n, do_pattern(e)?)))
.collect::<Result<_, Diagnostic>>()?,
),
_ => {
return Err(Diagnostic::error(
ErrorCode::Parse,
"invalid do pattern",
span,
));
}
};
Ok(P { kind, span })
}
/// Expand do syntax into ordinary applications, matches, and local bindings.
pub fn do_block(
statements: Vec<Statement>,
span: Span,
) -> Result<crate::ast::Expr, Diagnostic> {
use crate::ast::{
Expr as E, Kind as K, Pat as P, PatKind as PK, Row as R,
RowBody as B,
};
let node = |kind| E { kind, span };
let app = |a, b| node(K::App(Box::new(a), Box::new(b)));
let mut statements = statements;
let Some(Statement::Expr(mut body)) = statements.pop() else {
return Err(Diagnostic::error(
ErrorCode::Parse,
"do must end with an expression",
span,
));
};
for statement in statements.into_iter().rev() {
body = match statement {
Statement::Expr(e) => {
app(app(node(K::Var(">>".into())), e), body)
}
Statement::Let(bs) => node(K::LetGroup(bs, Box::new(body))),
Statement::Bind(p, e) => {
let continuation = match &p.kind {
PK::Var(n) => node(K::Lam(n.clone(), Box::new(body))),
PK::Wild => node(K::Lam("$do".into(), Box::new(body))),
_ => {
let site = p.span;
let rows = vec![
R {
patterns: vec![p],
body: B::Plain(Box::new(body)),
locals: vec![],
span: site,
},
R {
patterns: vec![P {
kind: PK::Wild,
span: site,
}],
body: B::Plain(Box::new(E {
kind: K::DoFail,
span: site,
})),
locals: vec![],
span: site,
},
];
node(K::Lam(
"$do".into(),
Box::new(node(K::Case(
Box::new(node(K::Var("$do".into()))),
rows,
))),
))
}
};
app(app(node(K::Var(">>=".into())), e), continuation)
}
};
}
Ok(body)
}
}This placement differs from a separate post-renaming desugaring pass: generated
bindings go through the same scope checker as handwritten ones. The helper
do_pattern validates the pattern-shaped syntax on the left of <-. The
span-bearing DoFail node is later translated into an ordinary error call with
its file, line, and column. No do node reaches Core.
Only the Prelude’s trusted FileId lets the checker relate its IO implementation
to unit-taking functions. User-visible schemes remain nominal. After
elaboration, io_lower::lower traverses all Core types before lint: binder
types, type applications, constructor fields, match result types, and dictionary
types. Replacing only IO a at the outermost level would miss higher-kinded
uses such as a Monad IO dictionary. The traversal also replaces the unapplied
constructor IO with the partially applied function constructor (->) ().
The runner first installs function closures and evaluates strict top-level values in dependency order, then applies the entry point to unit:
#![allow(unused)]
fn main() {
use crate::{
ast::Op,
core::{self, Bind, BindGroup, Expr, Id, Lit},
};
use std::{cell::RefCell, rc::Rc};
/// Language termination is separate from an ordinary runtime failure.
#[derive(Debug, Clone, PartialEq, Eq)]
pub enum Failure {
Runtime(String),
Exit(i32),
}
impl From<String> for Failure {
fn from(s: String) -> Self {
Self::Runtime(s)
}
}
impl From<&str> for Failure {
fn from(s: &str) -> Self {
Self::Runtime(s.into())
}
}
impl std::fmt::Display for Failure {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
match self {
Self::Runtime(s) => write!(f, "{s}"),
Self::Exit(n) => write!(f, "exit {n}"),
}
}
}
type Env = Vec<(Id, Value)>;
#[derive(Clone, Debug)]
/// A closure captures outer declarations and an optional immutable recursive-group recipe.
pub enum Value {
Lit(Lit),
Con(crate::data::ConId, Vec<Value>, Option<Vec<String>>),
Closure {
parameter: Id,
body: Rc<Expr>,
env: Rc<Env>,
recursive: Option<Rc<Vec<Bind>>>,
},
}
impl std::fmt::Display for Value {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
self.print(f, 0)
}
}
impl Value {
fn print(
&self,
f: &mut std::fmt::Formatter<'_>,
precedence: u8,
) -> std::fmt::Result {
match self {
Self::Lit(Lit::Double(n))
if f64::from_bits(*n).is_sign_negative()
&& precedence > 6 =>
{
write!(
f,
"({})",
crate::primitives::show_double(f64::from_bits(*n))
)
}
Self::Lit(Lit::Int(n)) if *n < 0 && precedence > 6 => {
write!(f, "({n})")
}
Self::Lit(l) => write!(f, "{l}"),
Self::Closure { .. } => write!(f, "<function>"),
Self::Con(id, fields, Some(labels)) => {
if precedence > 10 {
write!(f, "(")?;
}
write!(f, "{} {{", id.name)?;
for (i, (name, value)) in
labels.iter().zip(fields).enumerate()
{
if i > 0 {
write!(f, ", ")?;
}
write!(f, "{name} = ")?;
value.print(f, 0)?;
}
write!(f, "}}")?;
if precedence > 10 {
write!(f, ")")?;
}
Ok(())
}
Self::Con(id, fields, None) => match id.name.as_str() {
"[]" => write!(f, "[]"),
":" => {
write!(f, "[")?;
let mut value = self;
let mut first = true;
while let Self::Con(c, fs, _) = value {
if c.name == "[]" {
break;
}
if !first {
write!(f, ",")?;
}
first = false;
fs[0].print(f, 0)?;
value = &fs[1];
}
write!(f, "]")
}
"()" | "(,)" | "(,,)" => {
write!(f, "(")?;
for (i, v) in fields.iter().enumerate() {
if i > 0 {
write!(f, ",")?;
}
v.print(f, 0)?;
}
write!(f, ")")
}
_ => {
let parens = precedence > 10 && !fields.is_empty();
if parens {
write!(f, "(")?;
}
write!(f, "{}", id.name)?;
for v in fields {
write!(f, " ")?;
v.print(f, 11)?;
}
if parens {
write!(f, ")")?;
}
Ok(())
}
},
}
}
}
pub fn normalize(n: i64) -> i64 {
(n << 1) >> 1
}
/// Rebuild a recursive group's closures from a shared immutable recipe. The
/// recipe captures the outer environment, never the closures themselves.
// ANCHOR: recursive-closures
fn recursive_values(bindings: Rc<Vec<Bind>>, env: Rc<Env>) -> Env {
let mut values = Vec::new();
for binding in bindings.iter() {
let mut rhs = &*binding.rhs;
while let Expr::TyLam(_, inner) = rhs {
rhs = inner;
}
let Expr::Lam(parameter, body) = rhs else {
unreachable!("recursive lambda invariant")
};
let value = Value::Closure {
parameter: parameter.clone(),
body: Rc::new(*body.clone()),
env: env.clone(),
recursive: Some(bindings.clone()),
};
values.push((binding.name.clone(), value));
}
values
}
fn bind_group(
group: &BindGroup,
env: &mut Env,
fuel: &mut usize,
program: &core::Program,
globals: &RefCell<Env>,
) -> Result<(), Failure> {
if group.recursive {
env.extend(recursive_values(
Rc::new(group.binds.clone()),
Rc::new(env.clone()),
));
} else {
for binding in &group.binds {
let value =
evaluate(&binding.rhs, env, fuel, program, globals)?;
env.push((binding.name.clone(), value));
}
}
Ok(())
}
fn evaluate(
expr: &Expr,
env: &Env,
fuel: &mut usize,
program: &core::Program,
globals: &RefCell<Env>,
) -> Result<Value, Failure> {
*fuel = fuel.checked_sub(1).ok_or("step limit exceeded")?;
match expr {
Expr::Lit(l) => Ok(Value::Lit(l.clone())),
Expr::TyLam(_, body) | Expr::TyApp(body, _) => {
evaluate(body, env, fuel, program, globals)
}
Expr::Global(n) => globals
.borrow()
.iter()
.find(|(id, _)| id.unique() == n.unique())
.map(|(_, v)| v.clone())
.ok_or_else(|| {
Failure::Runtime(format!(
"internal error: uninitialized global {n}"
))
}),
Expr::Var(n) => env
.iter()
.rev()
.find(|(name, _)| name == n)
.map(|(_, v)| v.clone())
.ok_or_else(|| {
Failure::Runtime(format!("internal error: unbound {n}"))
}),
Expr::Lam(parameter, body) => Ok(Value::Closure {
parameter: parameter.clone(),
body: Rc::new(*body.clone()),
env: Rc::new(env.clone()),
recursive: None,
}),
// ANCHOR: application
Expr::App(function, argument) => {
let function = evaluate(function, env, fuel, program, globals)?;
let argument = evaluate(argument, env, fuel, program, globals)?;
if let Value::Closure {
parameter,
body,
env,
recursive,
} = &function
{
let mut local = (**env).clone();
if let Some(bindings) = recursive {
local.extend(recursive_values(
bindings.clone(),
env.clone(),
));
}
local.push((parameter.clone(), argument));
evaluate(body, &local, fuel, program, globals)
} else {
Err("internal error: non-function application".into())
}
}
// ANCHOR_END: application
Expr::Let(group, body) => {
let mut local = env.clone();
bind_group(group, &mut local, fuel, program, globals)?;
evaluate(body, &local, fuel, program, globals)
}
Expr::Con(id, _, fields) => Ok(Value::Con(
id.clone(),
fields
.iter()
.map(|e| evaluate(e, env, fuel, program, globals))
.collect::<Result<_, _>>()?,
program.constructors[id.index as usize].labels.clone(),
)),
Expr::PatternFail(span, _) => Err(failure(program, *span).into()),
Expr::Match(m) => {
let values = m
.scruts
.iter()
.map(|id| {
evaluate(
&Expr::Var(id.clone()),
env,
fuel,
program,
globals,
)
})
.collect::<Result<Vec<_>, _>>()?;
for row in &m.rows {
let mut local = env.clone();
if !row
.pats
.iter()
.zip(&values)
.all(|(p, v)| matches_pattern(p, v, &mut local))
{
continue;
}
for group in &row.locals {
bind_group(group, &mut local, fuel, program, globals)?;
}
match &row.body {
core::RowBody::Plain(e) => {
return evaluate(e, &local, fuel, program, globals);
}
core::RowBody::Guarded(gs) => {
for (g, e) in gs {
let value = evaluate(
g, &local, fuel, program, globals,
)?;
if matches!(value,Value::Con(id,_,_) if id.name=="True")
{
return evaluate(
e, &local, fuel, program, globals,
);
}
}
}
}
}
Err(failure(program, m.span).into())
}
Expr::Prim(op, _, args, _) => {
let values = args
.iter()
.map(|a| evaluate(a, env, fuel, program, globals))
.collect::<Result<Vec<_>, _>>()?;
primitive(*op, &values, program, globals)
}
}
}
fn primitive(
op: Op,
args: &[Value],
program: &core::Program,
_globals: &RefCell<Env>,
) -> Result<Value, Failure> {
if let Op::Runtime(p) = op {
return crate::primitives::evaluate(p, args, program);
}
if let [Value::Lit(Lit::String(a)), Value::Lit(Lit::String(b))] = args
&& op == Op::Append
{
return Ok(Value::Lit(Lit::String(format!("{a}{b}"))));
}
let [Value::Lit(Lit::Int(a)), Value::Lit(Lit::Int(b))] = args else {
return Err("internal error: primitive operands".into());
};
if matches!(op, Op::Eq | Op::Lt | Op::Le) {
let yes = match op {
Op::Eq => a == b,
Op::Lt => a < b,
_ => a <= b,
};
let name = if yes { "True" } else { "False" };
let c = program
.constructors
.iter()
.find(|c| c.id.name == name)
.ok_or("internal error: missing Bool constructor")?;
return Ok(Value::Con(c.id.clone(), vec![], c.labels.clone()));
}
let value = match op {
Op::Runtime(p) => {
return crate::primitives::evaluate(p, args, program);
}
Op::Add => Lit::Int(normalize(a.wrapping_add(*b))),
Op::Sub => Lit::Int(normalize(a.wrapping_sub(*b))),
Op::Mul => Lit::Int(normalize(a.wrapping_mul(*b))),
Op::Eq | Op::Lt | Op::Le => unreachable!(),
Op::Div | Op::Mod => {
if *b == 0 {
return Err("divide by zero".into());
}
let (mut q, mut r) = (a / b, a % b);
if r != 0 && (r < 0) != (*b < 0) {
q -= 1;
r += b;
}
Lit::Int(normalize(if op == Op::Div { q } else { r }))
}
Op::Append => {
return Err("internal error: string append on Int".into());
}
};
Ok(Value::Lit(value))
}
/// Evaluate top-level values exactly once in dependency order, then select main's value.
fn execute(
program: &core::Program,
mut fuel: usize,
io: bool,
) -> Result<String, Failure> {
let globals = RefCell::new(vec![]);
for group in &program.groups {
for b in &group.binds {
if core::is_function(&b.rhs) {
let value = evaluate(
&b.rhs,
&vec![],
&mut fuel,
program,
&globals,
)?;
globals.borrow_mut().push((b.name.clone(), value));
}
}
}
for group in &program.groups {
for b in &group.binds {
if !core::is_function(&b.rhs) {
let value = evaluate(
&b.rhs,
&vec![],
&mut fuel,
program,
&globals,
)?;
globals.borrow_mut().push((b.name.clone(), value));
}
}
}
let value = globals
.borrow()
.iter()
.find(|(n, _)| n.unique() == program.main.unique())
.map(|(_, v)| v.clone())
.ok_or("internal error: missing main")?;
if io {
let unit = program
.constructors
.iter()
.find(|c| c.id.name == "()")
.unwrap();
let action = Expr::App(
Box::new(Expr::Global(program.main.clone())),
Box::new(Expr::Con(unit.id.clone(), vec![], vec![])),
);
evaluate(&action, &vec![], &mut fuel, program, &globals)?;
Ok(String::new())
} else {
Ok(value.to_string())
}
}
/// Evaluate a pure fragment; retained for compiler tests and REPL inspection.
pub fn run(program: &core::Program, fuel: usize) -> Result<String, String> {
execute(program, fuel, false).map_err(|e| e.to_string())
}
fn failure(program: &core::Program, span: crate::source::Span) -> String {
let site = program
.locations
.iter()
.find(|(s, _)| *s == span)
.map(|(_, s)| s.as_str())
.unwrap_or("<unknown>:1:1");
format!("pattern match failure at {site}")
}
fn matches_pattern(p: &core::Pat, v: &Value, env: &mut Env) -> bool {
match p {
core::Pat::Wild => true,
core::Pat::Var(id) => {
env.push((id.clone(), v.clone()));
true
}
core::Pat::As(id, p) => {
env.push((id.clone(), v.clone()));
matches_pattern(p, v, env)
}
core::Pat::Lit(Lit::Double(n)) => {
matches!(v,Value::Lit(Lit::Double(m)) if f64::from_bits(*n)==f64::from_bits(*m))
}
core::Pat::Lit(l) => matches!(v,Value::Lit(actual) if l==actual),
core::Pat::Con(id, ps) => match v {
Value::Con(actual, vs, _)
if id == actual && ps.len() == vs.len() =>
{
ps.iter().zip(vs).all(|(p, v)| matches_pattern(p, v, env))
}
_ => false,
},
}
}
/// Initialize globals, then run the checked IO action exactly once.
pub fn run_io(program: &core::Program, fuel: usize) -> Result<(), Failure> {
execute(program, fuel, true).map(|_| ())
}
}An unused top-level action is still a value initialized at startup. Its body is not entered, as this regression demonstrates:
unused = putStrLn "bad"
main = putStrLn "ok"
The evaluator distinguishes a language error from a requested process exit.
This distinction prevents exitWith 7 from being printed as an error message:
#![allow(unused)]
fn main() {
use crate::{
ast::Op,
core::{self, Bind, BindGroup, Expr, Id, Lit},
};
use std::{cell::RefCell, rc::Rc};
impl From<String> for Failure {
fn from(s: String) -> Self {
Self::Runtime(s)
}
}
impl From<&str> for Failure {
fn from(s: &str) -> Self {
Self::Runtime(s.into())
}
}
impl std::fmt::Display for Failure {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
match self {
Self::Runtime(s) => write!(f, "{s}"),
Self::Exit(n) => write!(f, "exit {n}"),
}
}
}
type Env = Vec<(Id, Value)>;
#[derive(Clone, Debug)]
/// A closure captures outer declarations and an optional immutable recursive-group recipe.
pub enum Value {
Lit(Lit),
Con(crate::data::ConId, Vec<Value>, Option<Vec<String>>),
Closure {
parameter: Id,
body: Rc<Expr>,
env: Rc<Env>,
recursive: Option<Rc<Vec<Bind>>>,
},
}
impl std::fmt::Display for Value {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
self.print(f, 0)
}
}
impl Value {
fn print(
&self,
f: &mut std::fmt::Formatter<'_>,
precedence: u8,
) -> std::fmt::Result {
match self {
Self::Lit(Lit::Double(n))
if f64::from_bits(*n).is_sign_negative()
&& precedence > 6 =>
{
write!(
f,
"({})",
crate::primitives::show_double(f64::from_bits(*n))
)
}
Self::Lit(Lit::Int(n)) if *n < 0 && precedence > 6 => {
write!(f, "({n})")
}
Self::Lit(l) => write!(f, "{l}"),
Self::Closure { .. } => write!(f, "<function>"),
Self::Con(id, fields, Some(labels)) => {
if precedence > 10 {
write!(f, "(")?;
}
write!(f, "{} {{", id.name)?;
for (i, (name, value)) in
labels.iter().zip(fields).enumerate()
{
if i > 0 {
write!(f, ", ")?;
}
write!(f, "{name} = ")?;
value.print(f, 0)?;
}
write!(f, "}}")?;
if precedence > 10 {
write!(f, ")")?;
}
Ok(())
}
Self::Con(id, fields, None) => match id.name.as_str() {
"[]" => write!(f, "[]"),
":" => {
write!(f, "[")?;
let mut value = self;
let mut first = true;
while let Self::Con(c, fs, _) = value {
if c.name == "[]" {
break;
}
if !first {
write!(f, ",")?;
}
first = false;
fs[0].print(f, 0)?;
value = &fs[1];
}
write!(f, "]")
}
"()" | "(,)" | "(,,)" => {
write!(f, "(")?;
for (i, v) in fields.iter().enumerate() {
if i > 0 {
write!(f, ",")?;
}
v.print(f, 0)?;
}
write!(f, ")")
}
_ => {
let parens = precedence > 10 && !fields.is_empty();
if parens {
write!(f, "(")?;
}
write!(f, "{}", id.name)?;
for v in fields {
write!(f, " ")?;
v.print(f, 11)?;
}
if parens {
write!(f, ")")?;
}
Ok(())
}
},
}
}
}
pub fn normalize(n: i64) -> i64 {
(n << 1) >> 1
}
/// Rebuild a recursive group's closures from a shared immutable recipe. The
/// recipe captures the outer environment, never the closures themselves.
// ANCHOR: recursive-closures
fn recursive_values(bindings: Rc<Vec<Bind>>, env: Rc<Env>) -> Env {
let mut values = Vec::new();
for binding in bindings.iter() {
let mut rhs = &*binding.rhs;
while let Expr::TyLam(_, inner) = rhs {
rhs = inner;
}
let Expr::Lam(parameter, body) = rhs else {
unreachable!("recursive lambda invariant")
};
let value = Value::Closure {
parameter: parameter.clone(),
body: Rc::new(*body.clone()),
env: env.clone(),
recursive: Some(bindings.clone()),
};
values.push((binding.name.clone(), value));
}
values
}
fn bind_group(
group: &BindGroup,
env: &mut Env,
fuel: &mut usize,
program: &core::Program,
globals: &RefCell<Env>,
) -> Result<(), Failure> {
if group.recursive {
env.extend(recursive_values(
Rc::new(group.binds.clone()),
Rc::new(env.clone()),
));
} else {
for binding in &group.binds {
let value =
evaluate(&binding.rhs, env, fuel, program, globals)?;
env.push((binding.name.clone(), value));
}
}
Ok(())
}
fn evaluate(
expr: &Expr,
env: &Env,
fuel: &mut usize,
program: &core::Program,
globals: &RefCell<Env>,
) -> Result<Value, Failure> {
*fuel = fuel.checked_sub(1).ok_or("step limit exceeded")?;
match expr {
Expr::Lit(l) => Ok(Value::Lit(l.clone())),
Expr::TyLam(_, body) | Expr::TyApp(body, _) => {
evaluate(body, env, fuel, program, globals)
}
Expr::Global(n) => globals
.borrow()
.iter()
.find(|(id, _)| id.unique() == n.unique())
.map(|(_, v)| v.clone())
.ok_or_else(|| {
Failure::Runtime(format!(
"internal error: uninitialized global {n}"
))
}),
Expr::Var(n) => env
.iter()
.rev()
.find(|(name, _)| name == n)
.map(|(_, v)| v.clone())
.ok_or_else(|| {
Failure::Runtime(format!("internal error: unbound {n}"))
}),
Expr::Lam(parameter, body) => Ok(Value::Closure {
parameter: parameter.clone(),
body: Rc::new(*body.clone()),
env: Rc::new(env.clone()),
recursive: None,
}),
// ANCHOR: application
Expr::App(function, argument) => {
let function = evaluate(function, env, fuel, program, globals)?;
let argument = evaluate(argument, env, fuel, program, globals)?;
if let Value::Closure {
parameter,
body,
env,
recursive,
} = &function
{
let mut local = (**env).clone();
if let Some(bindings) = recursive {
local.extend(recursive_values(
bindings.clone(),
env.clone(),
));
}
local.push((parameter.clone(), argument));
evaluate(body, &local, fuel, program, globals)
} else {
Err("internal error: non-function application".into())
}
}
// ANCHOR_END: application
Expr::Let(group, body) => {
let mut local = env.clone();
bind_group(group, &mut local, fuel, program, globals)?;
evaluate(body, &local, fuel, program, globals)
}
Expr::Con(id, _, fields) => Ok(Value::Con(
id.clone(),
fields
.iter()
.map(|e| evaluate(e, env, fuel, program, globals))
.collect::<Result<_, _>>()?,
program.constructors[id.index as usize].labels.clone(),
)),
Expr::PatternFail(span, _) => Err(failure(program, *span).into()),
Expr::Match(m) => {
let values = m
.scruts
.iter()
.map(|id| {
evaluate(
&Expr::Var(id.clone()),
env,
fuel,
program,
globals,
)
})
.collect::<Result<Vec<_>, _>>()?;
for row in &m.rows {
let mut local = env.clone();
if !row
.pats
.iter()
.zip(&values)
.all(|(p, v)| matches_pattern(p, v, &mut local))
{
continue;
}
for group in &row.locals {
bind_group(group, &mut local, fuel, program, globals)?;
}
match &row.body {
core::RowBody::Plain(e) => {
return evaluate(e, &local, fuel, program, globals);
}
core::RowBody::Guarded(gs) => {
for (g, e) in gs {
let value = evaluate(
g, &local, fuel, program, globals,
)?;
if matches!(value,Value::Con(id,_,_) if id.name=="True")
{
return evaluate(
e, &local, fuel, program, globals,
);
}
}
}
}
}
Err(failure(program, m.span).into())
}
Expr::Prim(op, _, args, _) => {
let values = args
.iter()
.map(|a| evaluate(a, env, fuel, program, globals))
.collect::<Result<Vec<_>, _>>()?;
primitive(*op, &values, program, globals)
}
}
}
fn primitive(
op: Op,
args: &[Value],
program: &core::Program,
_globals: &RefCell<Env>,
) -> Result<Value, Failure> {
if let Op::Runtime(p) = op {
return crate::primitives::evaluate(p, args, program);
}
if let [Value::Lit(Lit::String(a)), Value::Lit(Lit::String(b))] = args
&& op == Op::Append
{
return Ok(Value::Lit(Lit::String(format!("{a}{b}"))));
}
let [Value::Lit(Lit::Int(a)), Value::Lit(Lit::Int(b))] = args else {
return Err("internal error: primitive operands".into());
};
if matches!(op, Op::Eq | Op::Lt | Op::Le) {
let yes = match op {
Op::Eq => a == b,
Op::Lt => a < b,
_ => a <= b,
};
let name = if yes { "True" } else { "False" };
let c = program
.constructors
.iter()
.find(|c| c.id.name == name)
.ok_or("internal error: missing Bool constructor")?;
return Ok(Value::Con(c.id.clone(), vec![], c.labels.clone()));
}
let value = match op {
Op::Runtime(p) => {
return crate::primitives::evaluate(p, args, program);
}
Op::Add => Lit::Int(normalize(a.wrapping_add(*b))),
Op::Sub => Lit::Int(normalize(a.wrapping_sub(*b))),
Op::Mul => Lit::Int(normalize(a.wrapping_mul(*b))),
Op::Eq | Op::Lt | Op::Le => unreachable!(),
Op::Div | Op::Mod => {
if *b == 0 {
return Err("divide by zero".into());
}
let (mut q, mut r) = (a / b, a % b);
if r != 0 && (r < 0) != (*b < 0) {
q -= 1;
r += b;
}
Lit::Int(normalize(if op == Op::Div { q } else { r }))
}
Op::Append => {
return Err("internal error: string append on Int".into());
}
};
Ok(Value::Lit(value))
}
/// Evaluate top-level values exactly once in dependency order, then select main's value.
fn execute(
program: &core::Program,
mut fuel: usize,
io: bool,
) -> Result<String, Failure> {
let globals = RefCell::new(vec![]);
for group in &program.groups {
for b in &group.binds {
if core::is_function(&b.rhs) {
let value = evaluate(
&b.rhs,
&vec![],
&mut fuel,
program,
&globals,
)?;
globals.borrow_mut().push((b.name.clone(), value));
}
}
}
for group in &program.groups {
for b in &group.binds {
if !core::is_function(&b.rhs) {
let value = evaluate(
&b.rhs,
&vec![],
&mut fuel,
program,
&globals,
)?;
globals.borrow_mut().push((b.name.clone(), value));
}
}
}
let value = globals
.borrow()
.iter()
.find(|(n, _)| n.unique() == program.main.unique())
.map(|(_, v)| v.clone())
.ok_or("internal error: missing main")?;
if io {
let unit = program
.constructors
.iter()
.find(|c| c.id.name == "()")
.unwrap();
let action = Expr::App(
Box::new(Expr::Global(program.main.clone())),
Box::new(Expr::Con(unit.id.clone(), vec![], vec![])),
);
evaluate(&action, &vec![], &mut fuel, program, &globals)?;
Ok(String::new())
} else {
Ok(value.to_string())
}
}
/// Evaluate a pure fragment; retained for compiler tests and REPL inspection.
pub fn run(program: &core::Program, fuel: usize) -> Result<String, String> {
execute(program, fuel, false).map_err(|e| e.to_string())
}
/// Initialize globals, then run the checked IO action exactly once.
pub fn run_io(program: &core::Program, fuel: usize) -> Result<(), Failure> {
execute(program, fuel, true).map(|_| ())
}
fn failure(program: &core::Program, span: crate::source::Span) -> String {
let site = program
.locations
.iter()
.find(|(s, _)| *s == span)
.map(|(_, s)| s.as_str())
.unwrap_or("<unknown>:1:1");
format!("pattern match failure at {site}")
}
fn matches_pattern(p: &core::Pat, v: &Value, env: &mut Env) -> bool {
match p {
core::Pat::Wild => true,
core::Pat::Var(id) => {
env.push((id.clone(), v.clone()));
true
}
core::Pat::As(id, p) => {
env.push((id.clone(), v.clone()));
matches_pattern(p, v, env)
}
core::Pat::Lit(Lit::Double(n)) => {
matches!(v,Value::Lit(Lit::Double(m)) if f64::from_bits(*n)==f64::from_bits(*m))
}
core::Pat::Lit(l) => matches!(v,Value::Lit(actual) if l==actual),
core::Pat::Con(id, ps) => match v {
Value::Con(actual, vs, _)
if id == actual && ps.len() == vs.len() =>
{
ps.iter().zip(vs).all(|(p, v)| matches_pattern(p, v, env))
}
_ => false,
},
}
}
/// Language termination is separate from an ordinary runtime failure.
#[derive(Debug, Clone, PartialEq, Eq)]
pub enum Failure {
Runtime(String),
Exit(i32),
}
}The driver flushes stdout at completion and before runtime diagnostics. Input
primitives flush before reading, so a prompt reaches the user before the program
blocks. The test runner accepts .in files and sends identical input to each
engine. A pipe-handshake regression checks flushing independently of terminal
buffering.
Existing programs need a small adjustment here. The driver no longer prints
main for us, so we put the printing in the program itself. If a value has no
Show instance, we’ll need to supply one or choose something printable from it.
The old value printer remains available through --print-value for inspecting
compiler fragments.
Running It
From the repository root, enter the chapter crate. These commands print an explicit action’s output and its inferred entry-point type:
$ cd crates/ch15_io
$ cargo run -q -- run tests/programs/io/hello.fun --lint
hello
$ cargo run -q -- dump --pass=types tests/programs/io/hello.fun
main : IO ()
$ cargo run -q -- run tests/programs/io/deferred.fun --lint
ok
Use --pass=core to find the dictionary arguments and the lambda taking unit.
It’s worth comparing an unused print action with one that is actually sequenced
by main. Both are values, but only the latter’s body runs. The Core interpreter
is still our execution engine in this chapter.
Exercises
- Warm-up. Replace the second
Justin the example with a suitably annotatedNothing. Explain why its continuation is not called. - Warm-up. Compare constructing an unused print action with constructing one
whose string argument calls
error. - Intermediate. Trace the generated scopes for a do block containing a
let, a tuple bind, and a shadowing bind. - Intermediate. Inspect a
Monad IOdictionary in Core and identify every type affected by IO lowering. - Advanced. Extend the pipe-handshake test to issue two prompts and verify the order without relying on a terminal’s line buffering.
Further Reading
- The report’s do expressions and monadic library (Simon Marlow 2010).
- Higher-kinded constructor classes (Jones 1993).
- Dictionary passing and qualified types (Jones 1999).