tests no longer use self.pm, added rational numbers and set applicati…

…on via (apply! var proc)
phaylon · Jan 30, 2009 · 2aea926 · 2aea926
1 parent 8e4097a
commit 2aea926
Show file tree

Hide file tree

Showing 40 changed files with 920 additions and 719 deletions.
diff --git a/Makefile.PL b/Makefile.PL
@@ -60,10 +60,13 @@ requires        'Sub::Install',                 '0.924';
 requires        'Scalar::Util',                 '1.19';
 requires        'Term::ReadLine',               '1.03';
 requires        'Time::HiRes',                  '1.9711';
+requires        'File::ShareDir',               '1.00';
 
 no_index        directory   => 'examples';
 
 install_script  'script/sxc';
 install_script  'script/sxc.pl';
 
+install_share   'share';
+
 WriteAll;
diff --git a/lib/Script/SXC/Library/Core.pm b/lib/Script/SXC/Library/Core.pm
@@ -34,7 +34,8 @@ CLASS->add_delegated_items({
 
     'Script::SXC::Library::Core::Contexts'      => [qw( values->list values->hash )],
 
-    'Script::SXC::Library::Core::Apply'         => [qw( apply )],
+    'Script::SXC::Library::Core::Apply'         
+        => [qw( apply apply! )],
 
     'Script::SXC::Library::Core::Recursion'     => [qw( recurse )],
 

diff --git a/lib/Script/SXC/Library/Core/Apply.pm b/lib/Script/SXC/Library/Core/Apply.pm
@@ -64,4 +64,19 @@ CLASS->add_procedure('apply',
     },
 );
 
+CLASS->add_inliner('apply!',
+    via => method (:$compiler, :$env, :$name, :$error_cb, :$exprs, :$symbol) {
+        CLASS->check_arg_count($error_cb, $name, $exprs, min => 2, max => 2);
+        my ($var, $apply) = @$exprs;
+        return $symbol->new_item_with_source('List', { contents => [
+            $symbol->new_item_with_source('Builtin', { value => 'set!' }),
+            $var,
+            $symbol->new_item_with_source('List', { contents => [
+                $apply,
+                $var,
+            ]}),
+        ]})->compile($compiler, $env);
+    },
+);
+
 1;
diff --git a/lib/Script/SXC/Script/Command.pm b/lib/Script/SXC/Script/Command.pm
@@ -8,6 +8,8 @@ use MooseX::Types::Moose qw( Object Bool );
 #use aliased 'Script::SXC::Script::Message',          'InfoMessage';
 #use aliased 'Script::SXC::Script::Message::Warning', 'WarningMessage';
 
+use File::ShareDir qw( dist_file );
+
 sub ReaderClass    { 
     Class::MOP::load_class('Script::SXC::Reader'); 
     return 'Script::SXC::Reader';
@@ -80,6 +82,10 @@ has inline_firstclass_procedures => (
     documentation   => 'inline firstclass procedures when possible (default: true)',
 );
 
+method shared_file (Str $filename) {
+    return dist_file 'Script-SXC', $filename;
+}
+
 method _build_default_reader { ReaderClass->new }
 
 method _build_default_compiler { 

diff --git a/lib/Script/SXC/Script/Command/repl.pm b/lib/Script/SXC/Script/Command/repl.pm
@@ -194,6 +194,7 @@ method run {
             perltidy(
                 source      => \$body,
                 destination => \$body,
+                perltidyrc  => $self->shared_file('perltidyrc'),
             ) if $self->pretty;
 
             # remember all existing variables

diff --git a/lib/Script/SXC/Token/DirectTransform.pm b/lib/Script/SXC/Token/DirectTransform.pm
@@ -1,8 +1,8 @@
 package Script::SXC::Token::DirectTransform;
 use Moose::Role;
+use MooseX::Method::Signatures;
 
 use namespace::clean -except => 'meta';
-use Method::Signatures;
 
 #requires qw( tree_item_class );
 

diff --git a/lib/Script/SXC/Token/Number.pm b/lib/Script/SXC/Token/Number.pm
@@ -1,18 +1,22 @@
 package Script::SXC::Token::Number;
 use Moose;
+use Moose::Util::TypeConstraints;
+use MooseX::Method::Signatures;
 
-use Script::SXC::Types qw( Num );
+use Script::SXC::Types qw( Num Object );
+
+use Math::BigRat;
 
 use namespace::clean -except => 'meta';
-use Method::Signatures;
 
 with 'Script::SXC::Token::MatchByRegex';
 with 'Script::SXC::Token::DirectTransform';
 with 'Script::SXC::Token';
 
-has '+value' => (isa => Num);
+has '+value' => (isa => Num | Object );
 
-method match_regex () { 
+method match_regex { 
+#sub match_regex {
     qr/
         [+-]?                   # signedness
         (?:                     # octal
@@ -42,6 +46,12 @@ method match_regex () {
               |                 # 0xF
                 [\da-f]+
             )
+          |                     # rationals
+            (?:
+                \d+
+                \/
+                \d+
+            )
           |                     # integer and float
             (?:                 # 24_800.30
                 [1-9][_\d]+\d
@@ -55,6 +65,8 @@ method match_regex () {
     /xi
 };
 
+#sub build_tokens {
+#    my ($self, $value) = @_;
 method build_tokens ($value) {
     my $class = ref($self) || $self;
 
@@ -80,6 +92,11 @@ method build_tokens ($value) {
         $value = oct $1;
     }
 
+    # rational value
+    elsif ($value =~ /\//) {
+        $value = Math::BigRat->new($value);
+    }
+
     # move value into negative if it was signed negative
     $value = 0 - $value
         if $substract;
@@ -88,7 +105,8 @@ method build_tokens ($value) {
     return $class->new(value => 0+$value);
 };
 
-method tree_item_class () { 'Script::SXC::Tree::Number' };
+method tree_item_class () { 'Script::SXC::Tree::Number' }
+#sub tree_item_class { 'Script::SXC::Tree::Number' };
 
 __PACKAGE__->meta->make_immutable;
 

diff --git a/lib/Script/SXC/Tree/Constant.pm b/lib/Script/SXC/Tree/Constant.pm
@@ -7,6 +7,8 @@ use Data::Dump qw( pp );
 use Script::SXC::lazyload
     ['Script::SXC::Compiled::Value', 'CompiledValue'];
 
+use Scalar::Util qw( blessed );
+
 use namespace::clean -except => 'meta';
 
 with 'Script::SXC::Tree::Item';
@@ -24,9 +26,13 @@ method compile (Object $compiler, Object $env) {
 
     # build compiled value
     return CompiledValue->new(
-        content => pp($self->value),
+        content => ( blessed($self->value) ? $self->compile_object_value($compiler, $env, $self->value) : pp($self->value) ),
       ( $self->does('Script::SXC::TypeHinting') ? (typehint => $self->typehint) : () ),
     );
 };
 
+method compile_object_value (Object $object) {
+    return pp($object);
+}
+
 1;
diff --git a/lib/Script/SXC/Tree/Number.pm b/lib/Script/SXC/Tree/Number.pm
@@ -5,10 +5,23 @@ use MooseX::Method::Signatures;
 use Script::SXC::lazyload
     ['Script::SXC::Compiled::Value', 'CompiledValue'];
 
+use Data::Dump qw( pp );
+
 use namespace::clean -except => 'meta';
 
 with 'Script::SXC::Tree::Constant';
 
+method compile_object_value (Object $compiler, Object $env, Object $object) {
+
+    if ($object->isa('Math::BigRat')) {
+        $compiler->add_required_package('Math::BigRat');
+        return sprintf '(Math::BigRat->new(%s))', pp("$object");
+    }
+    else {
+        return pp $object;
+    }
+}
+
 __PACKAGE__->meta->make_immutable;
 
 1;
diff --git a/t/lib/Script/SXC/Test/Compiler.pm b/t/lib/Script/SXC/Test/Compiler.pm
@@ -1,7 +1,6 @@
 package Script::SXC::Test::Compiler;
 use strict;
 use parent 'Script::SXC::Test';
-use self;
 use CLASS;
 use Test::Most;
 use aliased 'Script::SXC::Reader',      'ReaderClass';
@@ -15,13 +14,13 @@ use Script::SXC::Test::Util qw( assert_ok list_ok symbol_ok builtin_ok quote_ok
 CLASS->mk_accessors(qw( reader compiler ));
 
 sub evaluate {
-    my ($content) = args;
+    my ($self, $content) = @_;
 
-    my $tree = self->reader->build_stream(\$content)->transform;
+    my $tree = $self->reader->build_stream(\$content)->transform;
     isa_ok $tree, TreeClass;
     explain 'built tree: ', $tree;
 
-    my $compiled = self->compiler->compile_tree($tree);
+    my $compiled = $self->compiler->compile_tree($tree);
     isa_ok $compiled, CompiledClass;
     explain 'compiled result: ', $compiled;
 
@@ -33,35 +32,49 @@ sub evaluate {
 }
 
 sub setup_objects: Test(setup) {
-    self->reader(ReaderClass->new);
-    self->compiler(CompilerClass->new);
+    my ($self) = @_;
+    $self->reader(ReaderClass->new);
+    $self->compiler(CompilerClass->new);
 }
 
 sub T00_simple_expressions: Tests {
+    my ($self) = @_;
 
     # numbers
-    is self->evaluate('23'), 23, 'simple integer evaluation';
-    is self->evaluate('23.5'), 23.5, 'simple float evaluation';
+    is $self->evaluate('23'), 23, 'simple integer evaluation';
+    is $self->evaluate('23.5'), 23.5, 'simple float evaluation';
+
+    # rationals
+    my $rat = $self->evaluate('3/4');
+    isa_ok $rat, 'Math::BigRat', 'rational number transformed to Math::BigRat object';
+    is "$rat", '3/4', 'correct rational number';
 
     # strings
-    is self->evaluate('"foo"'), 'foo', 'simple string evaluation';
-    is self->evaluate('"foo\"bar"'), 'foo"bar', 'simple string evaluation with special char';
+    is $self->evaluate('"foo"'), 'foo', 'simple string evaluation';
+    is $self->evaluate('"foo\"bar"'), 'foo"bar', 'simple string evaluation with special char';
 
     # booleans
-    is self->evaluate('#t'), 1, 'simple true boolean';
-    is self->evaluate('#f'), undef, 'simple false boolean';
+    is $self->evaluate('#t'), 1, 'simple true boolean';
+    is $self->evaluate('#f'), undef, 'simple false boolean';
 
     # keywords
-    {   my $foo = self->evaluate(':foo');
+    {   my $foo = $self->evaluate(':foo');
         isa_ok $foo, 'Script::SXC::Runtime::Keyword';
         is "$foo", 'foo', 'runtime keyword is correctly built';
     }
 }
 
 sub T10_lists: Tests {
+    my ($self) = @_;
 
     # empty list
-    is_deeply self->evaluate('()'), [], 'empty list';
+    is_deeply $self->evaluate('()'), [], 'empty list';
+}
+
+sub T20_hashes: Tests {
+    my ($self) = @_;
+
+    is_deeply $self->evaluate('{}'), {}, 'empty hash';
 }
 
 1;
diff --git a/t/lib/Script/SXC/Test/Library.pm b/t/lib/Script/SXC/Test/Library.pm
@@ -2,7 +2,7 @@ package Script::SXC::Test::Library;
 use 5.010;
 use strict;
 use parent 'Script::SXC::Test';
-use self;
+#use self;
 use CLASS;
 use Test::Most;
 use Data::Dump qw( dump );
@@ -16,16 +16,17 @@ use aliased 'Script::SXC::Compiled',    'CompiledClass';
 CLASS->mk_accessors(qw( reader compiler ));
 
 sub setup_objects: Test(setup) {
-    self->reader(ReaderClass->new);
-    self->compiler(CompilerClass->new(
+    my ($self) = @_;
+    $self->reader(ReaderClass->new);
+    $self->compiler(CompilerClass->new(
         optimize_tailcalls           => $ENV{TEST_TAILCALLOPT},
         force_firstclass_procedures  => $ENV{TEST_FIRSTCLASS},
         inline_firstclass_procedures => $ENV{TEST_FIRSTCLASS_INLINE} // 1,
     ));
 }
 
 sub tidy {
-    my ($content) = args;
+    my ($self, $content) = @_;
     return $content if $ENV{NO_TIDY};
     my $result;
 
@@ -38,18 +39,18 @@ sub tidy {
 }
 
 sub run {
-    my ($content) = args;
+    my ($self, $content) = @_;
 
-    my $tree = self->reader->build_stream(\$content)->transform;
+    my $tree = $self->reader->build_stream(\$content)->transform;
     isa_ok $tree, TreeClass;
     explain 'built tree: ', $tree;
 
-    my $compiled = self->compiler->compile_tree($tree);
+    my $compiled = $self->compiler->compile_tree($tree);
     isa_ok $compiled, CompiledClass;
     explain 'compiled result: ', $compiled;
 
     explain 'original: ', $content;
-    explain 'compiled body: ', self->tidy($compiled->get_body);
+    explain 'compiled body: ', $self->tidy($compiled->get_body);
     my $value = $compiled->evaluate;
     explain 'returned value: ', $value;
 

diff --git a/t/lib/Script/SXC/Test/Library/Core.pm b/t/lib/Script/SXC/Test/Library/Core.pm
@@ -1,7 +1,6 @@
 package Script::SXC::Test::Library::Core;
 use strict;
 use parent 'Script::SXC::Test::Library';
-use self;
 use CLASS;
 use Test::Most;
 use Data::Dump qw( dump );