racket/collects/honu/examples/old/interpreter.honu

// -*- java -*-

/*
 * General Notes:
 *
 * 1) we need some sort of error reporting mechanism.  Full exceptions
 *    would be nice, but even a MzScheme-like error primitive would be
 *    sufficient for now.
 * 2) We desperately need some sort of polymorphism -- even Java 1.4
 *    style would be an improvement!
 * 3) What did we decide w.r.t typing _this_ again?
 */

/*
 * Assumed built-in types, operations
 *  OCaml-style extensional equality
 *  null? (or, more generally, intensional equality)
 *  String (changed to str)
 *  int
 *  boolean (changed to bool)
 */

/*
**********************************************************************
* Boxing: str -> String
**********************************************************************/

type String {
    str val;
}

/*
**********************************************************************
* Infrastructure: sets, lists, etc.
**********************************************************************/

type StringList
{
    bool contains(String s);

    // Returns copy of this list with first occurrence of s removed.
    // If no s, returns copy of this list.
    StringList remove(String s);

    // fold that produces a set.
    StringSet setFold(StringSet initial, StringSetOp op);

    bool hasDuplicates();
}

type StringSetOp
{
    // invoke this closure.
    StringSet run(StringSet accum, String s);
}

class EmptyStringList() : StringList impl StringList
{
    bool contains(String s) { false; }
    StringList remove(String s) { this : StringList; }

    StringSet setFold(StringSet initial, StringSetOp op) { initial; }

    bool hasDuplicates() { false; }

    export StringList : contains, setFold, remove, hasDuplicates;
}

class ConsStringList(String init_first, StringList init_rest) : StringList impl StringList
{
    String first =
        if(init_first == null) {
          error("ConsStringList.init_first null");
        } else {
          init_first;
        };
    StringList rest =
        if init_rest == null {
          error("ConsStringList.init_rest null");
        } else { init_rest; };

    bool contains(String s)
    {
        (s ==== first) || rest.contains(s);
    }

    StringList remove(String s)
    {
        if s ==== first {
          rest;
        } else {
          new ConsStringList : StringList
            (init_first = first,
             init_rest = rest.remove(s));
        };
    }

    StringSet setFold(StringSet initial, StringSetOp op)
    {
        rest.setFold(op.run(initial, first), op);
    }

    bool hasDuplicates()
    {
        rest.contains(first) || rest.hasDuplicates();
    }

    export StringList : contains, setFold, remove, hasDuplicates;
}

class UnionOp() : StringSetOp impl StringSetOp
{
    StringSet run(StringSet accum, String s)
    {
        accum.singleUnion(s);
    }

    export StringSetOp : run;
}

type StringSet
{
    StringSet singleUnion(String elt);
    StringSet union(StringSet rhs);
    StringSet subElt(String elt);
}

class StringSetCls() : StringSet impl StringSet
{
    init StringList init_contents = new EmptyStringList : StringList();
    // this showed up a bug in the parser where I wasn't adding
    // the default expressions to things.  This caused problems
    // when relying on them (i.e. not giving a contents init arg).
    // Fixed.

    // How should this get translated?  You have a default value
    // for contents so it can't go into the init args in the header,
    // but you want an additional check later (hasDuplicates()).
    StringList contents =
        if init_contents.hasDuplicates() {
          error("StringList.contents must be set");
        } else { init_contents; };

    StringSet singleUnion(String elt)
    {
        if contents.contains(elt) {
            this : StringSet;
        } else {
            new StringSetCls : StringSet
                (init_contents = new ConsStringList : StringList(init_first = elt,
                                                            init_rest = contents));
        };
    }

    StringSet union(StringSet rhs)
    {
        contents.setFold(rhs, new UnionOp : StringSetOp());
    }

    StringSet subElt(String elt)
    {
        new StringSetCls : StringSet(init_contents = contents.remove(elt));
    }

    export StringSet : singleUnion, union, subElt;
    // was export StringSetCls, typechecker caught this.
}

/*
**********************************************************************
* Values
**********************************************************************/

type Value
{
    Value apply(Value arg);
}

class IntValue() : Value impl Value // was class Constant, typechecker caught this
                                    // line 359 was the use of IntValue
{
    init int init_n;

    Value apply(Value arg) { error("cannot apply a constant"); }

    export Value : apply;
}

class Closure(String init_argName, Ast init_body, Env init_rho) : Value impl Value
{
    String argName =
        if init_argName == null {
          error("Closure.argName null");
        } else { init_argName; };
    Ast body =
        if init_body == null {
          error("Closure.body null");
        } else { init_body; };
    Env rho =
        if init_rho == null {
          error("Closure.rho null") ;
        } else { init_rho; }; // was else body, Typechecker caught this

    Value apply(Value arg)
    {
        body.getValue(rho.extend(argName, arg));
        // originally thought this was a bug in the interpreter,
        // but it was a bug in the typechecker (did supertype
        // checking on method arguments, not subtype checking).  Fixed.
    }
    
    export Value : apply; // no export statement, typechecker caught this.
}

/*
  **********************************************************************
  * Types
  **********************************************************************/

type Type
{
    Type getRange(Type domain);
}

class IntType() : Type impl Type
{
    Type getRange(Type domain) { error("IntType.getRange"); }

    export Type : getRange;
}

class ArrowType(Type init_dom, Type init_rng) : Type impl Type
{
    Type dom =
        if init_dom == null {
          error("ArrowType.dom null");
        } else { init_dom; };
    Type rng =
        if init_rng == null {
          error("ArrowType.rng null");
        } else { init_rng; };

    Type getRange(Type domain)
    {
        // extensional equality
        if domain ==== dom { rng; }
        else { error("arrowType.getRange: domain mismatch"); };
    }

    export Type : getRange;
}

/*
**********************************************************************
* Environments
**********************************************************************/

type Env
{
    Env extend(String var, Any t);
    Any lookup(String var);
}

class EmptyEnv() : Env impl Env
{
    Env extend(String var, Any t)
    {
        new RibEnv : Env(init_id = var, init_bdg = t, init_rest = this : Env);
    }

    Any lookup(String var)
    {
        error("unbound id");
    }

    export Env : extend, lookup;
}

class RibEnv(String init_id, Any init_bdg, Env init_rest) : Env impl Env
{

    String id =
        if init_id == null {
          error("RibEnv.id null");
        } else { init_id; };
    Any bdg =
        if init_bdg == null {
          error("RibEnv.bdg null");
        } else { init_bdg; };
    Env rest =
        if init_rest == null {
          error("RibEnv.rest null");
        } else { init_rest; };

    Env extend(String var, Any t)
    {
        new RibEnv : Env(init_id = var, init_bdg = t, init_rest = this : Env);
    }

    Any lookup(String var)
    {
        if var ==== id { bdg; }
        else { rest.lookup(var); };
    }

    export Env : extend, lookup;
    // was export TypeEnv, should be Env, typechecker caught this.
}
/*
  **********************************************************************
  * ASTS
  **********************************************************************/

type Ast
{
    StringSet vars();
    StringSet freeVars();

    Type getType(Env gamma);
    Value getValue(Env rho);
}

class Constant() : Ast impl Ast
{
    init int n;

    StringSet vars()
    {
        new StringSetCls : StringSet();
    }

    StringSet fv()
    {
        vars();
    }

    Type getType(Env gamma)
    {
        new IntType : Type();
    }

    Value getValue(Env rho)
    {
        new IntValue : Value(init_n = n);
    }

    export Ast : vars, fv as freeVars, getType, getValue;
}

class Variable(String init_name) : Ast impl Ast
{
    String name =
        if init_name == null {
          error("Variable.name null");
        } else { init_name; };

    StringSet vars()
    {
        StringSet result = new StringSetCls : StringSet();
        result.singleUnion(name);
    }

    StringSet fv() { vars(); }

    Type getType(Env gamma)
    {
        gamma.lookup(name) : Type;
    }

    Value getValue(Env rho)
    {
        rho.lookup(name) : Value;
    }

    export Ast : vars, fv as freeVars, getType, getValue;
    // last part was erroneously typed "getName" instead of "getValue",
    // caught by typechecker.
}

class Lambda(String init_arg, Ast init_body, Type init_argType) : Ast impl Ast
{
    String argName =
        if init_arg == null {
          error("Lambda.argName null");
        } else { init_arg; };
    Ast body =
        if init_body == null {
          error("Lambda.body null");
        } else { init_body; };
    Type argType =
        if init_argType == null {
          error("Lambda.argType null");
        } else { init_argType; };

    StringSet vars()
    {
        body.vars();
    }

    StringSet freeVars()
    {
        body.freeVars().subElt(argName);
        // was arg (init field) instead of argName (field).
        // typechecker caught this.
    }

    Type getType(Env gamma)
    {
        body.getType(gamma.extend(argName, argType));
        // originally thought this was a bug in the interpreter,
        // but it was a bug in the typechecker (did supertype
        // checking on method arguments, not subtype checking).  Fixed.
    }

    Value getValue(Env rho)
    {
        return new Closure : Value(init_argName = argName, init_body = body, init_rho = rho);
    }

    export Ast : vars, freeVars, getType, getValue;
}

class Application(Ast init_rator, Ast init_rand) : Ast impl Ast
{
    Ast rator =
        if init_rator == null {
          error("Application.rator null");
        } else { init_rator; };
    Ast rand =
        if init_rand == null {
          error("Application.rand null");
        } else { init_rand; };

    StringSet vars()
    {
        StringSet ratorVars = rator.vars();
        ratorVars.union(rand.vars());
    }

    StringSet fv()
    {
        StringSet ratorFv = rator.freeVars();
        // rator.freeVars (public name)  was rator.fv (private name).
        // typechecker caught this (happened below also with rand)
        ratorFv.union(rand.freeVars());
    }

    Type getType(Env gamma)
    {
        Type ratorType = rator.getType(gamma);
        ratorType.getRange(rand.getType(gamma));
    }

    Value getValue(Env rho)
    {
        Value ratorVal = rator.getValue(rho);
        ratorVal.apply(rand.getValue(rho));
        // ratorVal.apply was rator.apply, which gave method not found error
        // typechecker caught this.
        // also, rand.getValue was rand.value.  Same error.
        // typechecker caught this.
    }

    export Ast : vars, fv as freeVars, getType, getValue;
}