From 445f06897cabbc4384b8a75cd18a9f98f103443e Mon Sep 17 00:00:00 2001
From: Carl Masak <cmasak@gmail.com>
Date: Mon, 8 Dec 2014 11:30:01 +0100
Subject: [PATCH] make declaration, assignment, and say() work

---
 lib/_007.pm         | 123 ++++++++++++++++++++++++++++++++++++++++++++
 lib/_007/Test.pm    |  63 +++++++++++++++++++++++
 t/semantics/types.t |  25 +++++++++
 3 files changed, 211 insertions(+)
 create mode 100644 lib/_007.pm
 create mode 100644 lib/_007/Test.pm
 create mode 100644 t/semantics/types.t

diff --git a/lib/_007.pm b/lib/_007.pm
new file mode 100644
index 00000000..2bc70d9d
--- /dev/null
+++ b/lib/_007.pm
@@ -0,0 +1,123 @@
+role Val {}
+role Val::None is Val {}
+role Val::Int is Val { has Int $.value }
+role Val::Str is Val { has Str $.value }
+
+sub children(*@c) {
+    "\n" ~ @c.join("\n").indent(2)
+}
+
+role Q {
+}
+
+role Q::Literal::Int does Q {
+    has $.value;
+    method new(Int $value) { self.bless(:$value) }
+    method Str { "Int[$.value]" }
+
+    method eval($) { Val::Int.new(:$.value) }
+}
+
+role Q::Literal::Str does Q {
+    has $.value;
+    method new(Str $value) { self.bless(:$value) }
+    method Str { qq[Str["$.value"]] }
+
+    method eval($) { Val::Str.new(:$.value) }
+}
+
+role Q::Term::Identifier does Q {
+    has $.name;
+    method new(Str $name) { self.bless(:$name) }
+    method Str { "Identifier[$.name]" }
+
+    method eval($runtime) {
+        return $runtime.get-var($.name);
+    }
+}
+
+role Q::Expr::Assignment does Q {
+    has $.ident;
+    has $.expr;
+    method new($ident, $expr) { self.bless(:$ident, :$expr) }
+    method Str { "Assign" ~ children($.ident, $.expr) }
+
+    method eval($runtime) {
+        my $value = $.expr.eval($runtime);
+        $runtime.put-var($.ident.name, $value);
+        return $value;
+    }
+}
+
+role Q::Expr::Call::Sub does Q {
+    has $.ident;
+    has @.args;
+    method new($ident, *@args) { self.bless(:$ident, :@args) }
+    method Str { "Call" ~ children($.ident, |@.args) }
+
+    method eval($runtime) {
+        # TODO: de-hack -- wants to be a hash of builtins somewhere
+        die "Unknown sub {$.ident.name}"
+            unless $.ident.name eq "say";
+        my $arg = @.args[0].eval($runtime);
+        $runtime.output.say($arg.value);
+        Val::None.new;
+    }
+}
+
+role Q::Statement::Expr does Q {
+    has $.expr;
+    method new($expr) { self.bless(:$expr) }
+    method Str { "Expr" ~ children($.expr) }
+
+    method run($runtime) {
+        $.expr.eval($runtime);
+    }
+}
+
+role Q::Statement::VarDecl does Q {
+    has $.ident;
+    has $.assignment;
+    method new($ident, $assignment = Nil) { self.bless(:$ident, :$assignment) }
+    method Str { "VarDecl" ~ children($.ident, |$.assignment) }
+
+    method run($runtime) {
+        # TODO: should have an if statement here, but need a test case for it
+        $.assignment.eval($runtime);
+    }
+}
+
+role Q::CompUnit does Q {
+    has @.statements;
+    method new(*@statements) { self.bless(:@statements) }
+    method Str { "CompUnit" ~ children(@.statements) }
+
+    method run($runtime) {
+        for @.statements -> $statement {
+            $statement.run($runtime);
+        }
+    }
+}
+
+role Runtime {
+    has $.output;
+    has %!pad;
+
+    method run($compunit) {
+        $compunit.run(self);
+    }
+
+    method put-var($name, $value) {
+        %!pad{$name} = $value;
+    }
+
+    method get-var($name) {
+        return %!pad{$name};
+    }
+}
+
+role _007 {
+    method runtime(:$output = $*OUT) {
+        Runtime.new(:$output);
+    }
+}
diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm
new file mode 100644
index 00000000..0f263fae
--- /dev/null
+++ b/lib/_007/Test.pm
@@ -0,0 +1,63 @@
+use v6;
+use _007;
+use Test;
+
+sub read(Str $ast) is export {
+    my %qclass_lookup =
+        int         => Q::Literal::Int,
+        str         => Q::Literal::Str,
+        ident       => Q::Term::Identifier,
+
+        assign      => Q::Expr::Assignment,
+        call        => Q::Expr::Call::Sub,
+
+        vardecl     => Q::Statement::VarDecl,
+        stexpr      => Q::Statement::Expr,
+
+        compunit    => Q::CompUnit,
+    ;
+
+    my grammar _007::Syntax {
+        regex TOP { \s* <expr> \s* }
+        proto token expr {*}
+        token expr:list { '(' ~ ')' [<expr>+ % \s+] }
+        token expr:int { \d+ }
+        token expr:symbol { \w+ }
+        token expr:str { '"' ~ '"' (<-["]>+) }
+    }
+
+    my $actions = role {
+        method TOP($/) { make $<expr>.ast }
+        method expr:list ($/) {
+            my $qname = ~$<expr>[0];
+            die "Unknown name: $qname"
+                unless %qclass_lookup{$qname} :exists;
+            my $qclass = %qclass_lookup{$qname};
+            my @rest = $<expr>».ast[1..*];
+            make $qclass.new(|@rest);
+        }
+        method expr:symbol ($/) { make ~$/ }
+        method expr:int ($/) { make +$/ }
+        method expr:str ($/) { make ~$0 }
+    };
+
+    _007::Syntax.parse($ast, :$actions)
+        or die "failure";
+    return $/.ast;
+}
+
+role Output {
+    has $.result = "";
+
+    method say($s) { $!result ~= $s ~ "\n" }
+}
+
+sub is-result($input, $expected, $desc = "MISSING TEST DESCRIPTION") is export {
+    my $ast = read($input);
+    my $output = Output.new;
+    my $runtime = _007.runtime(:$output);
+    $runtime.run($ast, :$output);
+
+    is $output.result, $expected, $desc;
+}
+
diff --git a/t/semantics/types.t b/t/semantics/types.t
new file mode 100644
index 00000000..e6c6536b
--- /dev/null
+++ b/t/semantics/types.t
@@ -0,0 +1,25 @@
+use v6;
+use Test;
+use _007::Test;
+
+{
+    my $ast = q:to/./;
+        (compunit
+          (vardecl (ident "n") (assign (ident "n") (int 7)))
+          (stexpr (call (ident "say") (ident "n"))))
+        .
+
+    is-result $ast, "7\n", "int type works";
+}
+
+{
+    my $ast = q:to/./;
+        (compunit
+          (vardecl (ident "s") (assign (ident "s") (str "Bond")))
+          (stexpr (call (ident "say") (ident "s"))))
+        .
+
+    is-result $ast, "Bond\n", "str type works";
+}
+
+done;