racket/collects/honu/examples/old/interpreter-str.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)
 */

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

type StringList
{
    bool contains(str s);

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

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

    bool hasDuplicates();
}

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

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

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

    bool hasDuplicates() { false; }

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

class ConsStringList(StringList rest) : StringList impl StringList
{
    init str first;

    StringList rest =
        if rest == null {
          error("ConsStringList.rest null");
        } else { rest; };

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

    StringList remove(str s)
    {
        if s == first { rest; }
        else { new ConsStringList : StringList
                (first = first,
                 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, str s)
    {
        accum.singleUnion(s);
    }

    export StringSetOp : run;
}

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

class StringSetCls() : StringSet impl StringSet
{
    init StringList 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 contents.hasDuplicates() {
          error("StringList.contents must be set");
        } else { contents; };

    StringSet singleUnion(str elt)
    {
        if contents.contains(elt) { this : StringSet; }
        else {
            new StringSetCls : StringSet
                (contents = new ConsStringList : StringList(first = elt,
                                                            rest = contents));
        };
    }

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

    StringSet subElt(str elt)
    {
        new StringSetCls : StringSet(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 n;

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

    export Value : apply;
}

class Closure(Ast body, Env rho) : Value impl Value
{
    init str argName;
    Ast body =
        if body == null {
          error("Closure.body null");
        } else { body; };
    Env rho =
        if rho == null {
          error("Closure.rho null");
        } else { 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 dom, Type rng) : Type impl Type
{
    Type dom =
        if dom == null {
          error("ArrowType.dom null");
        } else { dom; };
    Type rng =
        if rng == null {
          error("ArrowType.rng null");
        } else { 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(str var, Any t);
    Any lookup(str var);
}

class EmptyEnv() : Env impl Env
{
    Env extend(str var, Any t)
    {
        new RibEnv : Env(id = var, bdg = t, rest = this : Env);
    }

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

    export Env : extend, lookup;
}

class RibEnv(Any bdg, Env rest) : Env impl Env
{
    init str id;
    Any bdg =
        if bdg == null {
          error("RibEnv.bdg null");
        } else { bdg; };
    Env rest =
        if rest == null {
          error("RibEnv.rest null");
        } else { rest; };

    Env extend(str var, Any t)
    {
        new RibEnv : Env(id = var, bdg = t, rest = this : Env);
    }

    Any lookup(str 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(n = n);
    }

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

class Variable() : Ast impl Ast
{
    init str 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(Ast body, Type argType) : Ast impl Ast
{
    init str argName;

    Ast body =
        if body == null {
          error("Lambda.body null");
        } else { body; };
    Type argType =
        if argType == null {
          error("Lambda.argType null");
        } else { 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(argName = argName, body = body, rho = rho);
    }

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

class Application(Ast rator, Ast rand) : Ast impl Ast
{
    Ast rator =
        if rator == null {
          error("Application.rator null");
        } else { rator; };
    Ast rand =
        if rand == null {
          error("Application.rand null");
        } else { 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;
}