This is not a parsa, this is a function that tests a char for membership in a list of ranges like ['a'-'z']['A'-'Z'].

  //Check if a character is a member of one of the provided ranges
  fun char_range (c:char)(l:list[char * char]):bool =>
    match l with
      | #Empty => false
      | Cons ((c1, c2), tl) =>    
         (ord c1 <= ord c and ord c <= ord c2) or char_range c tl
    endmatch
    ;

The function letter on the other hand, is a parsa. Analysis succeeds for alphabetic characters.

  //An element of the alphabet
  var letter : parsa[char, char] =
    token (fun (c:char) => 
             if char_range c 
              (list[char*char](
               (char 'a', char 'z'), 
              (char 'A', char 'Z'))) 
             then Some c else None[char])
    ;

This next function is a digit parsa.

  //Digit parsa
  var digit : parsa[char, char] = 
    token (fun (c:char) : opt[char] => 
    if isdigit c then Some c else None[char] 
    )
    ;

The expression (digit &~ *digit) computes a pair. The first element of the pair is the leading digit, the second element of the pair, a list of zero or more digits. We "give" that pair to the constructor Cons[char], which joins the pair into a single list with head the leading digit.

  //Parser of a sequence of digit
  var digits : parsa[char, list[char]] = 
    (digit &~ *digit) >=~ Cons[char]
    ;

Next up, floating point numbers. Here's the grammar.

  digit   := '0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9'
  digits  := digit digit*
  optsign := '-'|'+'|ε
  optfrac := ('.' digit*)|ε
  optexp  := (('e'|'E') optsign digits)|ε
  number  := digits optfrac optexp

  // '-' | '+' | eps
  var optsign : parsa[char, list[char]] =
    token (fun (c:char):opt[list[char]] =>
      match c with
      | c when c == char '-' => Some (list[char] (c))
      | c when c == char '+'=> Some (list[char] (c))
      | _ => None[list[char]]
     endmatch) |~ empty[char, list[char]] (list[char] ())
    ;
  
  // '.' digit* | eps
  var optfrac : parsa[char, list[char]] =
    ( char_ (char '.') &~ *digit >=~ Cons[char])
    |~ empty[char, list[char]] (list[char] ())
    ;
  
  //(('e'|'E') optsign digits)|eps
  var optexp : parsa[char, list[char]] =
    (((((char_ (char 'e') |~ char_ (char 'E')) &~ optsign) 
      >=~ Cons[char]) &~ digits) 
      >=~ (fun (x:list[char], y:list[char]) : list[char] => x + y)) 
    |~ empty[char, list[char]] (list[char] ())
  ;

In readiness for parsing, some functions for switching representations between string and list[char].

  //Explode a string into a list of char
  fun explode (s:string):list[char] =
  {
    val n:size = len s;
    fun loop (acc:list[char]) (i:size) : list[char] =>
      if (i == n) then unbox$ rev acc
      else loop (Cons (s.[i], acc)) (i + 1)
    ;
  
    return loop (list[char]()) 0uz;
  };
  
  //Implode a list of char to a string
  fun implode (xs:list[char]) =>
    fold_left (fun (a:string) (b:char):string => a + b) "" xs
    ;

At this point, it makes sense to introduce a type for the tokens that we will admit into our language of arithmetic expressions.

  //Tokens
  variant token_t  =
    | T_num of double
    | T_ident of string
    | T_lparen | T_rparen
    | T_plus | T_minus | T_star | T_slash | T_semicolon | T_equal
    ;
  
  instance Str[token_t] {
    fun str (tok : token_t) : string =>
      match tok with
        | T_num f => "T_num " + (str f)
        | T_ident s => "T_ident " + s
        | #T_lparen => "T_lparen"
        | #T_rparen => "T_rparen"
        | #T_plus => "T_plus"
        | #T_minus => "T_minus"
        | #T_star => "T_star"
        | #T_slash => "T_slash"
        | #T_semicolon => "T_semicolon"
        | #T_equal => "T_equal"
      endmatch
      ;
  }

number produces "number" tokens.

  //Number token
  var number:parsa[char, token_t] =
    (digits &~ optfrac &~ optexp) >=~
      (fun (p:list[char] * list[char], cse:list[char]):token_t =>
        T_num (atof (implode (p.0 + p.1 + cse))))
    ;

identifier produces "identifier" tokens.

  //Identifier token
  var identifier : parsa[char, token_t] =
    (letter &~ (zero_or_more letter)) >=~ 
      (fun (c:char, cs:list[char]):token_t => 
         T_ident (implode (Cons (c, cs))))
    ;

The following set of parsas deals with the remaining single character token types.

  //Operator token
  var operator : parsa[char, token_t] =
    token (
      fun (ch:char) : opt[token_t] =>
        match ch with
        | c when c == char '-' => Some T_minus
        | c when c == char '+' => Some T_plus
        | c when c == char '*' => Some T_star
        | c when c == char '/' => Some T_slash
        | _ => None[token_t]
      endmatch
    );
  
  //Parenthesis token
  var paren : parsa[char, token_t] =
    token (
      fun (ch:char) : opt[token_t] =>
        match ch with
        | c when c == char '(' => Some T_lparen
        | c when c == char ')' => Some T_rparen
        | _ => None[token_t]
        endmatch
    );
  
  //Equal token
  var equal : parsa[char, token_t] =
    token (
     fun (ch:char) : opt[token_t] =>
        match ch with
        | c when c == '=' => Some T_equal
        | _ => None[token_t]
      endmatch
    );
  
  //Semicolon token
  var semicolon : parsa[char, token_t] =
    token (
      fun (ch:char) : opt[token_t] =>
        match ch with
        | c when c == ';' => Some T_semicolon
        | _ => None[token_t]
       endmatch
    );

A parsa of white space consumes a space character but produces no significant information.

  //Parse a whitespace character
  var space_ : parsa[char, unit] =
   token (fun (ch:char) : opt[unit] =>
     match ch with
       | c when c == char ' ' => Some ()
       | c when c == char '\t' => Some ()
       | c when c == char '\n' => Some ()
       | c when c == char '\r' => Some ()
       | _ => None[unit]
     endmatch
    );

A parsa of spaces follows easily.

  //Parser of whitespace
  fun spaces (toks:list[char]) : parsed[char, unit] =>
    (((space_ &~ spaces) >=~ 
         fst[unit, unit])
      |~ empty[char, unit](()))
    toks
    ;

Finally, the lexical analyzer which computes a list[token_t] from an input list[char]. It is defined by the regular expression

lex := spaces((identifier|number|operator|paren|semicolon|equal)spaces)*

  //Lexer for the language of arithmetic expressions
  fun lex (toks : list[char]) : parsed [char, list[token_t]] =>
      (spaces &~ 
      *((( identifier 
          |~ number 
          |~ operator 
          |~ paren 
          |~ semicolon 
          |~ equal) &~ spaces) >=~ 
      (fst[token_t, unit])) 
         >=~ snd[unit, list[token_t]]) toks
    ;

  //Arithmetic expressions
  variant ast_t =
    | E_const of double
    | E_var of string
    | E_add of ast_t * ast_t
    | E_sub of ast_t * ast_t
    | E_mul of ast_t * ast_t
    | E_div of ast_t * ast_t
    | E_let of (string * ast_t)
    ;
  
  fun str (ast : ast_t) : string =>
    match ast with
      | E_const f => "E_const (" + str f + ")"
      | E_var s => "E_var (" + s + ")"
      | E_add (x, y) => "E_add (" + str x + ", " + str y + ")"
      | E_sub (x, y) => "E_sub (" + str x + ", " + str y + ")"
      | E_mul (x, y) => "E_mul (" + str x + ", " + str y + ")"
      | E_div (x, y) => "E_div (" + str x + ", " + str y + ")"
      | E_let (s, e) => "E_let (" + s + ", " + str e + ")"
    endmatch
    ;

The first in this set of functions, num, is a parsa of number tokens producing (literal) number expressions.

  //Constants
  val num:parsa[token_t, ast_t] =
    token (
      fun (t:token_t):opt[ast_t] =>
        match t with
          | T_num n => Some (E_const n)
          | _ => None[ast_t]
        endmatch
    );

ident is a parsa of "identifier" expressions.

  //Identifiers
  val xident:parsa[token_t, ast_t] =
    token (
      fun (t:token_t):opt[ast_t] =>
        match t with
          | T_ident s => Some (E_var s)
          | _ => None[ast_t]
    );

addop is the parsa of additive expressions.

  //Addition, subtraction operators
  val addop:parsa[token_t, ast_t -> ast_t -> ast_t] =
    token (
      fun (t:token_t):opt[ast_t -> ast_t -> ast_t] =>
        match t with
          | #T_plus => Some (fun (e1:ast_t)(e2:ast_t):ast_t => E_add (e1, e2))
          | #T_minus => Some (fun (e1:ast_t)(e2:ast_t):ast_t => E_sub (e1, e2))
          | _ => None[ast_t -> ast_t -> ast_t]
          endmatch
    );

mulop the parsa of multiplicative expressions.

  //Multiplication, division operators
  val mulop:parsa[token_t, ast_t -> ast_t -> ast_t] =
    token (
      fun (t:token_t):opt[ast_t -> ast_t -> ast_t] =>
        match t with
          | #T_star => Some (fun (e1:ast_t)(e2:ast_t):ast_t => E_mul (e1, e2))
          | #T_slash => Some (fun (e1:ast_t)(e2:ast_t):ast_t => E_div (e1, e2))
          | _ => None[ast_t -> ast_t -> ast_t]
          endmatch
    );

Note that addop amd mulop produce functions on a successful parse.

The result of a parsa p say, can be used to compute a new parsa q that then attempts a parse on the remains. Informally we might say this as p "given to" q. This function has infix operator form >>=~

  //A parsa that feeds its result into another
  fun givento[A, B, C] (p1:parsa[A, B], p2:B -> parsa[A, C]) : parsa[A, C] =>
    fun (toks : list[A]) : parsed[A, C] =>
       match p1 toks with
        | Returns (r1, toks1) => p2 r1 toks1
        | #Parse_failed => Parse_failed[A, C]
       endmatch
      ;

The >>=~ operator is critical to the implementation of left_assoc : the analyzer for expressions with associative infix operators which recognizes the grammar

expr := term (op term)* 

  //Build left-associative trees e.g. expr := term (op term)*
  fun left_assoc[A, B] 
    (term : parsa[A, B]) 
    (op : parsa[A, B -> B-> B]) : parsa[A, B] =>
    let 
      fun sequence (t1:B) : parsa [A, B] =>
        let fn = fun (f:B -> B -> B, t2:B) => f t1 t2 in
        (op &~ term >=~ fn >>=~ sequence of (B)) |~ (empty[A, B] t1)
    in
      (term >>=~ sequence)
  ;

These are all the single token parsas that don't don't map to actual expressions (their occurrences do not result in nodes in the abstract syntax tree).

  //Opening paren
  var open_paren : parsa[token_t, unit] =
    let fun t (tok : token_t) : opt[unit] =>
      match tok with
      | #T_lparen => Some ()
      | _ => None[unit]
    in token t
  ;
  
  //Closing paren
  var close_paren : parsa[token_t, unit] =
    let fun t (tok : token_t) : opt[unit] =>
      match tok with
      | #T_rparen => Some ()
      | _ => None[unit]
    in token t
  ;
  
  //Semi-colon
  var semi : parsa[token_t, unit] =
    let fun t (tok : token_t) : opt[unit] =>
      match tok with
      | #T_semicolon => Some ()
      | _ => None[unit]
    in token t
  ;
  
  //Equals sign
  var equals : parsa[token_t, unit] =
    let fun t (tok : token_t) : opt[unit] =>
      match tok with
      | #T_equal => Some ()
      | _ => None[unit]
    in token t
  ;

The language of arithmetic expressions will be defined by the following grammar:

expr_list :=
  | expr (';' expr)*
  ;
expr :=
  | identifier '=' expr
  | term (['+'|'-'] term)*
  ;
term :=
  | fact (['*'|'/'] fact)*
  ;
fact :=
  | num
  | identifier
  | '( expr ')
  ;

  //expr_list := expr (';' expr)*
  var expr_list : parsa[token_t, list[ast_t]] = 
    ((expr &~ *((semi &~ expr) >=~ snd[unit, ast_t])
       >=~ Cons[ast_t]))
     |~empty[token_t, list[ast_t]] (list[ast_t]())
    ;

For simplicity, we write the expression rule this way:

expr :=
| bind
| term (['+'|'-'] term)*
;

  fun expr (toks : list[token_t]) : parsed[token_t, ast_t] =>
    (bind |~ left_assoc[token_t, ast_t] term addop) toks
    ;

where,

bind := identifier '=' expr

  var bind : parsa[token_t, ast_t] =
     (((xident &~ equals) >=~ fst[ast_t, unit]) &~ expr) >=~ 
     (fun (p : ast_t * ast_t) : ast_t => 
        match p.0 with
        | E_var e => E_let (e, p.1)
        endmatch)
    ;

The rule for terms:

term := fact (['*'|'/'] fact)*

  var term : parsa[token_t, ast_t] = left_assoc[token_t, ast_t] fact mulop ;

The fule for factors:

fact :=
 | num
 | identifier
 | '( expr ')
 ;

  fun fact (toks : list[token_t]) : parsed[token_t, ast_t] =>
    (num |~ xident |~ 
      ((open_paren &~ expr &~ close_paren) >=~ 
          (fun (p:(unit * ast_t), u:unit) : ast_t => p.1))
     ) toks
    ;

  //A function to extract the result of a parse
  fun accept[A, B] (result : parsed[A, B]) : opt[B] =>
    match result with
    | Returns (b, #Empty) => Some[B] (b)
    | #Parse_failed => None[B]
    | _ => None[B] //meaning, not all chars consumed
    endmatch
    ;
  
  //A function to produce a list of tokens from a string
  fun tokenize (s : string) : opt[list[token_t]] => 
    accept (lex (explode (s))) 
    ;
  
  //A function to produce an AST from a list of tokens
  fun parse_expr (s : string) : opt[ast_t] =>
    match tokenize s with
      | Some toks => accept (expr toks)
      | #None => None[ast_t]
    endmatch
    ;
  
  //A function to produce a list of ASTs from a list of tokens
  fun parse_expr_list (s : string) : opt[list[ast_t]] =>
    match tokenize s with
    | Some toks => accept (expr_list toks)
    | #None => None[list[ast_t]]
    endmatch
    ;

This is an implementation detail that will be called on later. It's a lookup function on associative lists.

  //'assoc a l' returns the value associated with key 'a in the list of
  //pairs 'l'.  That is, 'assoc a [ ...; (a,b); ...] = b' if '(a,b)' is
  //the leftmost binding of 'a' in list 'l'
  fun assoc[A, B with Eq[A]] (x : A) (l : list[(A * B)]) : opt[B] =>
    match l with
      | #Empty => None[B]
      | Cons ((a, b), t) => if a == x then Some b else assoc x t
    endmatch
      ;

So, all that remains now is to put an interactive "front end" on the interpreter (a read-eval-print-loop).

  proc prompt (continuing:bool) {
    if (not continuing) do
      write$ stdout, "? ";
    else
      write$ stdout, "... ";
    done;
    fflush stdout;
  }
  
  gen read (continuing:bool) : string = {
    prompt (continuing);
    val l = stdin.readln.strip;
    return l;
  }
  
  //Read-eval-print-loop
  proc repl () {
  
    //oh hai!
    println$ "";
    println$ "Interpreter of arithmetic expressions (with variables)";
    println$ "Type ^D to quit.";
  
    var env = list [(string * double)]();
  
    //A buffer
    var buf:string ="";
    reserve (&buf, 1048); //initial capacity
    
  repl_loop : //iz in ur loop!
    while true do
  
      var l:string = read (len buf != 0uz);
      var n:size = len l;
  
      if n == 0uz 
        break repl_loop; //kthxbai!
  
      if n > 0uz do
        if (l.[0] == char '%') //Comment line. Discard
          continue repl_loop;
  
        if l.[n - 1] == char '\\' do //Line continuation; append and keep reading
          buf += substring (l, 0, n - 1);
          continue repl_loop;
        done
  
        if l.[n - 1] == char 7 do //Discard partial statements with ^G
          buf = "";
          continue repl_loop;
        done
  
        //We think we got a phrase. Evaluate
        buf += l;
        var res : result[list[double], error_t] = parse_eval_exprs (&env) buf;
        buf = ""; //reset buf
        var response : string =
          match res with 
           | Ok a => str (head (drop (int (len a) - 1) a))
           | Error err => str err
         endmatch;
         println$ response;
  
      done
    done //repl_loop
    println$ "";
  }

When the program is executed, we go into the repl "loop"!

  repl () ;

Here's some test input for the repl emulating what a user might write.

x=1
y=2
x+y
x+(x*y)+43-y/1

Given the above test input, this is the expected output from the interpreter.

Interpreter of arithmetic expressions (with variables)
Type ^D to quit.
? x=1
1
? y=2
2
? x+y
3
? x+(x*y)+43-y/1
44
?