# foam - functional object-oriented applicative metaarchitecture
# MIT-licensed
# 23apr2008  +chris+ 
require 'pp'

$: << "~/projects/rpeg/lib"
require 'rpeg'

class Env < Hash
  attr_accessor :parent
  attr_accessor :code

  def initialize
    super
    self.parent = nil
    self.code = []
    @order = []
  end

  def fetch(key)
    return self  if key == "self"
    super {
      (parent || {}).fetch key
    }
  rescue IndexError => e
    e.message << "#{key.inspect}"
    raise e
  end

  def []=(key, value)
    @order.delete key
    @order << key
    super
  end

  def each_in_order
    @order.each { |k|
      yield k, self[k]
    }
  end

  def eval(parent)
    @parent = parent
    each_in_order { |k, v|
      self[k] = v.eval(self)
    }
    code.each { |c| c.eval(self) }
    self
  end

  def as_parent
    e = Env.new
    e.parent = self
    e
  end

  def apply(other)
    self["apply"].apply(other)
  end
end

class Int < Struct.new(:int)
  def eval(env)
    self
  end

  def method_missing(name, *args, &block)
    r = int.__send__(name, *args, &block)
    case r
    when Integer
      Int.new(r)
    else
      r
    end
  end
end

class Sel < Struct.new(:name)
  def eval(env)
    self
  end

  def apply(other)
    case other
    when Env
      other.fetch name
    when Int
      RubyBinMsg.new(other, name.intern)
    else
      raise TypeError, "can't apply #{self} on #{other}"
    end
  end
end

class RubyBinMsg < Struct.new(:arg1, :method)
  def apply(arg2)
    arg1.send method, arg2
  end
end

class Var < Struct.new(:name)
  def eval(env)
    p env
    env.fetch(name).eval(env)
  end
end

class App < Struct.new(:arg1, :arg2)
  def eval(env)
    r2 = arg2.eval(env)
    r1 = arg1.eval(env)
    r1.apply r2
  end
end

class Lam < Struct.new(:arg, :body)
  def eval(env)
    Clo.new(env, self)
  end
end

class CLam < Struct.new(:code)
end

class Clo < Struct.new(:env, :lam)
  def apply(other)
    env2 = env.as_parent
    env2[lam.arg.name] = other
    lam.body.eval(env2)
  end

  def eval(env)
    self
  end
end

class CClo < Struct.new(:env, :code)
end

def compile(obj, code=[])
  case obj
  when Env
    code << [:PUSH]
    obj.each_in_order { |name, value|
      compile value, code
      compile Sel.new(name), code
      code << [:BIND]
    }
    unless obj.code.empty?
      obj.code.each { |c|
        compile c, code
      }
    else
      code << [:LIT, Sel.new("self")]
      code << [:LOOK]
    end
    code << [:POP]
  when App
    compile obj.arg2, code
    compile obj.arg1, code
    code << [:APP]
  when Var
    compile Sel.new(obj.name), code
    code << [:LOOK]
  when Sel, Int
    code << [:LIT, obj]
  when Lam
    code << [:LIT, CLam.new([[:LIT, obj.arg],
                             [:BIND]] +
                            compile(obj.body)
                            )]
  else
    raise "#{obj.class} uncompilable"
  end
  code
end

def run(code, stack=[], env=Env.new)

  code.each { |op, arg|
    case op
    when :PUSH
      env = env.as_parent
    when :POP
      env = env.parent
    when :BIND
      env[stack.pop.name] = stack.pop
    when :LOOK
      stack.push env.fetch(stack.pop.name)
    when :LIT
      stack.push arg
    when :APP
      loop {
        case stack.last
        when CLam
          stack.push CClo.new(env.as_parent, stack.pop.code)
        when CClo
          clos = stack.pop
          run clos.code, stack, clos.env
          break
        else
          stack.push stack.pop.apply(stack.pop)
          break
        end
      }
    else
      raise op.inspect
    end
  }

  stack.last
end

$generated = {}
def compile2c(obj)
  case obj
  when Env
    id = "x#{rand 10000}"
    code = "CODE #{id}[] = {"
    code << "PUSH,\n"
    obj.each_in_order { |name, value|
      code << "#{compile2c value},\n"
      code << "#{compile2c Sel.new(name)},\n"
      code << "BIND,\n"
    }
    unless obj.code.empty?
      obj.code.each { |c|
        code << "#{compile2c c},\n"
      }
    else
      code << compile2c(Sel.new("self"))
      code << "LOOK,\n"
    end
    code << "POP"
    code << "};"
    puts code
    return id
  when App
    arg1 = compile2c(obj.arg1)
    arg2 = compile2c(obj.arg2)
    return "#{arg2}, #{arg1}, APP"
  when Var
    return "#{compile2c(Sel.new(obj.name))}, LOOK"
  when Sel
    id = "s_#{obj.name.gsub(/[^a-zA-Z0-9]/) { "_#{$&[0]}" }}"
    unless $generated.include? id
      puts "ID #{id} = intern(#{obj.name.dump});"
      $generated[id] = true
    end
    return "LIT, L(#{id})"
  when Int
    return "LIT, L(#{(obj.int << 2) | 1} /* =#{obj.int} */)"
  when Lam
    id = "x#{rand 10000}"
    arg = compile2c obj.arg
    body = compile2c obj.body
    puts "CODE #{id}[] = {"
    puts "  #{arg},"
    puts "  BIND,"
    puts body
    puts "};"
    return "LIT, L(#{id})"
  else
    raise "#{obj.class} uncompilable"
  end
end

def generate(tree)
  $generated = {}
puts <<EOF
// generated by foam.rb, #{Time.now}
#include "vm.c"
int
main()
{
EOF
  entry = compile2c tree
  puts <<EOF

  struct vm vm = {
    .stack = calloc(255, sizeof (VAL)),
    .env = new_env (0),
    .ip = #{entry}
  };
  
  run (&vm);

  return 0;
}
EOF
end


eval(RPeg.load(File.read("foam.rpeg")).compile2ruby("FoamParser < RPeg"))
# p "ok"

t=FoamParser.new.parse(<<EOF, "defs")
def: 4
meh: [1,2,3]
tuple: (a,b,c) `elt` #x
def': 4
try: a#b#c
try': c #b a
EOF

t=FoamParser.new.parse(<<EOF, "defs")
a: 5
double: x -> _y -> x + x
b: 2 + double 3 10
c: a+b

double c
EOF

t=FoamParser.new.parse(<<EOF, "defs")
double: x -> _y -> x + x
double': _x -> y -> y+y
b: double' 3
c: b 10

b
c
EOF

generate t
exit

code = compile t
pp code

toplevel = Env.new
pp t.eval(toplevel)

pp run(code)

=begin
t=FoamParser.new.parse(<<EOF, "defs")
a: { b: 2 }

a#b
#b a
EOF

pp t

toplevel = Env.new
pp t.eval(toplevel)

pp compile t
=end