Implement monadic bind syntax

src/lib.rs

@@ -113,6 +113,8 @@ pub fn desugar_book(
 
   ctx.resolve_refs()?;
 
+  ctx.book.apply_bnd();
+
   ctx.fix_match_terms()?;
   ctx.desugar_match_defs()?;
 

src/term/display.rs

@@ -51,6 +51,16 @@ impl fmt::Display for Term {
       Term::Let { pat, val, nxt } => {
         write!(f, "let {} = {}; {}", pat, val, nxt)
       }
+      Term::Bnd { fun, ask, val, nxt } => {
+        write!(f, "do {fun} {{ ")?;
+        write!(f, "ask {} = {}; ", ask, val)?;
+        let mut cur = nxt;
+        while let Term::Bnd { fun: _, ask, val, nxt } = &**cur {
+          cur = nxt;
+          write!(f, "ask {} = {}; ", ask, val)?;
+        }
+        write!(f, "{} }}", cur)
+      }
       Term::Use { nam, val, nxt } => {
         let Some(nam) = nam else { unreachable!() };
         write!(f, "use {} = {}; {}", nam, val, nxt)
@@ -232,6 +242,18 @@ impl Term {
           write!(f, "let {} = {};\n{:tab$}{}", pat, val.display_pretty(tab), "", nxt.display_pretty(tab))
         }
 
+        Term::Bnd { fun, ask, val, nxt } => {
+          writeln!(f, "do {fun} {{")?;
+          writeln!(f, "{:tab$}ask {} = {};", "", ask, val.display_pretty(tab + 2), tab = tab + 2)?;
+          let mut cur = nxt;
+          while let Term::Bnd { fun: _, ask, val, nxt } = &**cur {
+            cur = nxt;
+            writeln!(f, "{:tab$}ask {} = {};", "", ask, val.display_pretty(tab + 2), tab = tab + 2)?;
+          }
+          writeln!(f, "{:tab$}{}", "", cur.display_pretty(tab + 2), tab = tab + 2)?;
+          writeln!(f, "{:tab$}}}", "")
+        }
+
         Term::Use { nam, val, nxt } => {
           write!(
             f,

src/term/mod.rs

@@ -87,6 +87,12 @@ pub enum Term {
     val: Box<Term>,
     nxt: Box<Term>,
   },
+  Bnd {
+    fun: Name,
+    ask: Box<Pattern>,
+    val: Box<Term>,
+    nxt: Box<Term>,
+  },
   Use {
     nam: Option<Name>,
     val: Box<Term>,
@@ -294,6 +300,9 @@ impl Clone for Term {
       Self::Var { nam } => Self::Var { nam: nam.clone() },
       Self::Lnk { nam } => Self::Lnk { nam: nam.clone() },
       Self::Let { pat, val, nxt } => Self::Let { pat: pat.clone(), val: val.clone(), nxt: nxt.clone() },
+      Self::Bnd { fun, ask, val, nxt } => {
+        Self::Bnd { fun: fun.clone(), ask: ask.clone(), val: val.clone(), nxt: nxt.clone() }
+      }
       Self::Use { nam, val, nxt } => Self::Use { nam: nam.clone(), val: val.clone(), nxt: nxt.clone() },
       Self::App { tag, fun, arg } => Self::App { tag: tag.clone(), fun: fun.clone(), arg: arg.clone() },
       Self::Fan { fan, tag, els } => Self::Fan { fan: *fan, tag: tag.clone(), els: els.clone() },
@@ -460,6 +469,7 @@ impl Term {
       }
       Term::Fan { els, .. } | Term::Lst { els } => ChildrenIter::Vec(els),
       Term::Let { val: fst, nxt: snd, .. }
+      | Term::Bnd { val: fst, nxt: snd, .. }
       | Term::Use { val: fst, nxt: snd, .. }
       | Term::App { fun: fst, arg: snd, .. }
       | Term::Opx { fst, snd, .. } => ChildrenIter::Two([fst.as_ref(), snd.as_ref()]),
@@ -486,6 +496,7 @@ impl Term {
       }
       Term::Fan { els, .. } | Term::Lst { els } => ChildrenIter::Vec(els),
       Term::Let { val: fst, nxt: snd, .. }
+      | Term::Bnd { val: fst, nxt: snd, .. }
       | Term::Use { val: fst, nxt: snd, .. }
       | Term::App { fun: fst, arg: snd, .. }
       | Term::Opx { fst, snd, .. } => ChildrenIter::Two([fst.as_mut(), snd.as_mut()]),
@@ -536,6 +547,9 @@ impl Term {
       Term::Let { pat, val, nxt, .. } => {
         ChildrenIter::Two([(val.as_ref(), BindsIter::Zero([])), (nxt.as_ref(), BindsIter::Pat(pat.binds()))])
       }
+      Term::Bnd { ask, val, nxt, .. } => {
+        ChildrenIter::Two([(val.as_ref(), BindsIter::Zero([])), (nxt.as_ref(), BindsIter::Pat(ask.binds()))])
+      }
       Term::Use { nam, val, nxt, .. } => {
         ChildrenIter::Two([(val.as_ref(), BindsIter::Zero([])), (nxt.as_ref(), BindsIter::One([nam]))])
       }
@@ -584,6 +598,9 @@ impl Term {
       Term::Let { pat, val, nxt, .. } => {
         ChildrenIter::Two([(val.as_mut(), BindsIter::Zero([])), (nxt.as_mut(), BindsIter::Pat(pat.binds()))])
       }
+      Term::Bnd { val, nxt, .. } => {
+        ChildrenIter::Two([(val.as_mut(), BindsIter::Zero([])), (nxt.as_mut(), BindsIter::Zero([]))])
+      }
       Term::Use { nam, val, nxt } => {
         ChildrenIter::Two([(val.as_mut(), BindsIter::Zero([])), (nxt.as_mut(), BindsIter::One([&*nam]))])
       }
@@ -633,6 +650,10 @@ impl Term {
         (val.as_mut(), BindsIter::Zero([])),
         (nxt.as_mut(), BindsIter::Pat(pat.binds_mut())),
       ]),
+      Term::Bnd { ask, val, nxt, .. } => ChildrenIter::Two([
+        (val.as_mut(), BindsIter::Zero([])),
+        (nxt.as_mut(), BindsIter::Pat(ask.binds_mut())),
+      ]),
       Term::App { fun: fst, arg: snd, .. } | Term::Opx { fst, snd, .. } => {
         ChildrenIter::Two([(fst.as_mut(), BindsIter::Zero([])), (snd.as_mut(), BindsIter::Zero([]))])
       }

src/term/parser.rs

@@ -335,6 +335,12 @@ impl<'a> TermParser<'a> {
           } else if self.try_consume("switch") {
             // switch
             self.parse_switch()?
+          } else if self.try_consume("do ") {
+            let fun = self.parse_name()?;
+            self.consume("{")?;
+            let ask = self.parse_ask(Name::new(fun))?;
+            self.consume("}")?;
+            ask
           } else {
             // var
             let nam = self.labelled(|p| p.parse_hvml_name(), "term")?;
@@ -346,6 +352,19 @@ impl<'a> TermParser<'a> {
     })
   }
 
+  fn parse_ask(&mut self, fun: Name) -> Result<Term, String> {
+    if self.try_consume("ask") {
+      let ask = self.parse_pattern(true)?;
+      self.consume("=")?;
+      let val = self.parse_term()?;
+      self.try_consume(";");
+      let nxt = self.parse_ask(fun.clone())?;
+      Ok(Term::Bnd { fun, ask: Box::new(ask), val: Box::new(val), nxt: Box::new(nxt) })
+    } else {
+      self.parse_term()
+    }
+  }
+
   fn parse_oper(&mut self) -> Result<Op, String> {
     let opr = if self.try_consume("+") {
       Op { ty: OpType::U60, op: IntOp::Add }

src/term/term_to_net.rs

@@ -173,6 +173,7 @@ impl EncodeTermState<'_> {
           self.link(up, Trg::Port(Port(opx, 2)));
         }
         Term::Use { .. }  // Removed in earlier pass
+        | Term::Bnd { .. } // Removed in earlier pass
         | Term::Mat { .. } // Removed in earlier pass
         | Term::Nat { .. } // Removed in encode_nat
         | Term::Str { .. } // Removed in encode_str

src/term/transform/apply_bnd.rs

@@ -0,0 +1,35 @@
+use crate::{
+  maybe_grow,
+  term::{Book, Pattern, Term},
+};
+
+impl Book {
+  pub fn apply_bnd(&mut self) {
+    for def in self.defs.values_mut() {
+      for rule in def.rules.iter_mut() {
+        rule.body.apply_bnd();
+      }
+    }
+  }
+}
+
+impl Term {
+  pub fn apply_bnd(&mut self) {
+    maybe_grow(|| {
+      for children in self.children_mut() {
+        children.apply_bnd();
+      }
+    });
+
+    if let Term::Bnd { fun, ask, val, nxt } = self {
+      let mut fvs = nxt.free_vars();
+      ask.binds().flatten().for_each(|bind| _ = fvs.remove(bind));
+      let fvs = fvs.into_keys().collect::<Vec<_>>();
+      let nxt =
+        fvs.iter().fold(*nxt.clone(), |nxt, nam| Term::lam(Pattern::Var(Some(nam.clone())), nxt.clone()));
+      let nxt = Term::lam(*ask.clone(), nxt);
+      let term = Term::call(Term::Ref { nam: fun.clone() }, [*val.clone(), nxt]);
+      *self = Term::call(term, fvs.into_iter().map(|nam| Term::Var { nam }));
+    }
+  }
+}

src/term/transform/float_combinators.rs

@@ -163,6 +163,7 @@ impl Term {
       Term::Let { val: fst, nxt: snd, .. }
       | Term::Use { val: fst, nxt: snd, .. }
       | Term::Opx { fst, snd, .. } => FloatIter::Two([fst.as_mut(), snd.as_mut()]),
+      Term::Bnd { .. } => unreachable!(),
       Term::Lam { bod, .. } => bod.float_children_mut(),
       Term::Var { .. }
       | Term::Lnk { .. }

src/term/transform/mod.rs

@@ -1,4 +1,5 @@
 pub mod apply_args;
+pub mod apply_bnd;
 pub mod apply_use;
 pub mod definition_merge;
 pub mod definition_pruning;

tests/golden_tests/desugar_file/bind_syntax.hvm

@@ -0,0 +1,8 @@
+Result.bind (Result.ok val) f = (f val)
+Result.bind err _ = err
+
+Main = do Result.bind {
+  ask y = (HVM.store "file.txt" "Alice");
+  ask x = (HVM.load "file.txt");
+  x
+}

tests/golden_tests/run_file/recursive_bind.hvm

@@ -0,0 +1,11 @@
+Result.bind (Result.ok val) f = (f val)
+Result.bind err _ = err
+
+Bar x = (Result.err 0)
+
+Foo x y = do Result.bind {
+  ask x = (Bar x);
+  (Foo x y)
+}
+
+Main = (Foo "a" 0)

tests/snapshots/desugar_file__bind_syntax.hvm.snap

@@ -0,0 +1,19 @@
+---
+source: tests/golden_tests.rs
+input_file: tests/golden_tests/desugar_file/bind_syntax.hvm
+---
+(Result.bind) = λa #Result (a Result.bind$C1 Result.bind$C0)
+
+(Main) = (Result.bind (HVM.store (String.cons 102 (String.cons 105 (String.cons 108 (String.cons 101 (String.cons 46 (String.cons 116 (String.cons 120 (String.cons 116 String.nil)))))))) (String.cons 65 (String.cons 108 (String.cons 105 (String.cons 99 (String.cons 101 String.nil)))))) λ* (Result.bind (HVM.load (String.cons 102 (String.cons 105 (String.cons 108 (String.cons 101 (String.cons 46 (String.cons 116 (String.cons 120 (String.cons 116 String.nil))))))))) λb b))
+
+(String.cons) = λa λb #String λc #String λ* #String (c a b)
+
+(String.nil) = #String λ* #String λb b
+
+(Result.ok) = λa #Result λb #Result λ* #Result (b a)
+
+(Result.err) = λa #Result λ* #Result λc #Result (c a)
+
+(Result.bind$C0) = #Result λd λ* (Result.err d)
+
+(Result.bind$C1) = #Result λb λc (c b)

tests/snapshots/run_file__recursive_bind.hvm.snap

@@ -0,0 +1,9 @@
+---
+source: tests/golden_tests.rs
+input_file: tests/golden_tests/run_file/recursive_bind.hvm
+---
+Lazy mode:
+(Result.err 0)
+
+Strict mode:
+(Result.err 0)