[Jifty-commit] r5352 - B-Decompile/sketch

[Jifty commits]

Author: nothingmuch
Date: Tue May  6 10:52:55 2008
New Revision: 5352

Added:
   B-Decompile/sketch/
   B-Decompile/sketch/classes.pl
   B-Decompile/sketch/simple.t

Log:
B::Simple sketch

Added: B-Decompile/sketch/classes.pl
==============================================================================
--- (empty file)
+++ B-Decompile/sketch/classes.pl	Tue May  6 10:52:55 2008
@@ -0,0 +1,249 @@
+package B::Simple::Node::FactoryDelegate;
+use Moose::Role;
+
+has factory => (
+	isa => "B::Simple::Node::Factory",
+	handles => qr/.*/,
+);
+
+
+package B::Simple::Node::Factory;
+use Moose;
+
+sub node_from_op {
+	my ( $self, $op, @args ) = @_;
+	$self->node_class_foo->new($op, @args, factory => $self);
+}
+
+package B::Simple::Node;
+use Moose::Role;
+
+package B::Simple::Role::Equality;
+use Moose::Role;
+
+sub equals {
+	my ( $self, $other, @args ) = @_;
+
+	return unless blessed($other) and $other->isa(__PACKAGE__);
+
+	$self->inner_equals($other, @_);
+}
+
+requires "inner_equals";
+
+package B::Simple::Node::Container;
+use Moose::Role;
+
+requires "children";
+
+sub children_equal {
+	my ( $self, $other, @args ) = @_;
+
+	my @self_children = $self->children;
+
+	my @other_children = $other->children;
+
+	return unless @self_children == @other_children;
+
+	# FIXM zip and equals->(@args)
+	return
+}
+
+package B::Simple::OP;
+use Moose::Role;
+
+with qw(B::Simple::Role::Equality);
+
+package B::Simple::OP::Nullary;
+use Moose::Role;
+
+with qw(
+	B::Simple::Node::Container
+	B::Simple::OP
+);
+
+package B::Simple::OP::Unary;
+use Moose::Role;
+
+with qw(
+	B::Simple::Node::Container
+	B::Simple::OP
+);
+
+has _child => (
+	does => "B::Simple::Collection::Item",
+);
+
+
+package B::Simple::OP::Binary;
+use Moose::Role;
+
+with qw(
+	B::Simple::Node::Container
+	B::Simple::OP
+);
+
+package B::Simple::OP::List;
+use Moose::Role;
+
+with qw(
+	B::Simple::Node::Container
+	B::Simple::OP
+);
+
+has child_collection => (
+	does => "B::Simple::Collection::List",
+	is   => "rw",
+	default => sub { B::Simple::Collection::List::Floating->new },
+	handles => 'B::Simple::Collection::List',
+);
+
+package B::Simple::Collection::Item;
+use Moose::Role;
+
+with qw(B::Simple::Collection);
+
+requires "child";
+
+package B::Simple::Collection::Item::Floating;
+use Moose;
+
+with qw(B::Simple::Collection::Item);
+
+sub child {}
+has child => (
+	does => "B::Simple::Node",
+	is   => "rw",
+	required => 1,
+);
+
+package B::Simple::Collection::Item::Attached;
+use Moose;
+
+with qw(B::Simple::Collection::Item);
+
+has _parent => (
+	isa => "B::OP::UNOP",
+	is  => "ro",
+	required => 1,
+);
+
+sub child {}
+has child => (
+	# FIXME write a metaclass to delegate set_value and get_value properly to _parent and then make rw
+	does => "B::Simple::Node",
+	is   => "ro",
+	required => 1, # FIXME look into lazy_build vs. required, not sure how this would work
+	lazy_build => 1,
+);
+
+sub BUILD {
+	shift->child; # force building for required
+}
+
+sub _build_child {
+	my $self = shift;
+
+	if ( my $parent = $self->_parent ) {
+		return $self->node_from_op($parent->first);
+	} else {
+		croak "No parent or child provided";
+	}
+}
+
+package B::Simple::Collection::List;
+use Moose::Role;
+
+with qw(B::Simple::Collection);
+
+requires "children";
+
+requires "splice";
+
+sub length {
+	scalar(shift->children);
+}
+
+sub first {
+	(shift->children)[0];
+}
+
+sub last {
+	(shift->children)[-1];
+}
+
+sub shift {
+	my $self = shift;
+	$self->splice( 0, 1 );
+}
+
+# ... push, pop, unshift, etc
+
+package B::Simple::Collection::List::Floating;
+use Moose;
+
+use MooseX::AttributeHelpers;
+
+with qw(B::Simple::Collection::List);
+
+has _children => (
+	metaclass => "Collection::Array",
+	isa => "ArrayRef[B::Simple::Node]",
+	is  => "rw",
+	default => sub { [] },
+	provides => {
+		splice => "splice",
+		push => "push",
+		pop  => "pop",
+		shift => "shift",
+		unshift => "unshift",
+		# ...
+	},
+);
+
+sub children { @{ shift->_children } }
+
+package B::Simple::Collection::List::Attached;
+use Moose::Role;
+
+with qw(
+	B::Simple::Collection::List
+	B::Simple::Node::FactoryDelegate
+);
+
+use B::Utils ();
+
+has root => (
+	isa => "B::OP",
+	is  => "ro",
+	required => 1,
+);
+
+# has first
+# has last
+# has children
+# has length
+
+sub children {
+	map { $self->node_from_op($_) } shift->root->kids; # FIXME caching to ensure that two accesses return the same values
+}
+
+package B::Simple::OP::Block;
+use Moose;
+
+with 'B::Simple::OP::List' => {
+	alias => {
+		children_equal => "inner_equals", # Body has no value of it's own, lineseq/scope is a meaningless op
+	},
+};
+
+sub new_from_op {
+	my ( $self, $op, @args ) = @_;	
+	die "no idea how the factory shit works yet on classes, maybe factory is a required arg to create the attached collection";
+}
+
+Body->new(
+	child_collection => B::Simple::Collection::Element::Attached->new( root => $some_b_op_lineseq_or_scope ),
+);
+
+

Added: B-Decompile/sketch/simple.t
==============================================================================
--- (empty file)
+++ B-Decompile/sketch/simple.t	Tue May  6 10:52:55 2008
@@ -0,0 +1,80 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+sub code_optree_is ($$;$) {
+	my ( $perl, $tree, $desc ) = @_:
+	$desc ||= "optree for '$perl'";
+
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+	trees_equal(
+		perl_to_tree($perl),
+		$tree,
+		$desc,
+	);
+}
+
+sub tree_equals {
+	my ( $got, $exp, $desc ) = @_;
+
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+	ok( blessed($got) and $got->equals($exp), $desc );
+}
+
+sub sub_body_tree ($) {
+	my $sub = shift;
+	$sub = eval $sub unless ref $sub;
+
+	my $cv_obj = B::svref_2object($cref);
+
+	my $op = $cv->ROOT->first;
+
+	$factory->new_from_op($op);
+}
+
+tree_equals(
+	sub_body_tree('sub { }'),
+	B::Simple::OP::Block->new( ),
+);
+
+code_optree_is(
+	sub_body_tree('sub { 1 }'),
+	B:Simple::OP::Block->new(
+		children => [
+			B::Simple::OP::Const->new(
+				value => 1, # FIXME value or sv?
+				# type => IV ?
+				context => "inherit",
+			),
+		],
+	);
+);
+
+tree_equals(
+	sub_body_tree('my $x; sub { $x }'),
+	B::Simple::OP::Block->new(
+		children => [
+			B::Simple::OP::Variable::Lexical->new(
+				name => '$x',
+				introduce => 0,
+				context => "inherit",
+			),
+		],
+	),
+}
+
+tree_equals(
+	sub_body_tree('sub { my $x }'),
+	B::Simple::OP::Block->new(
+		children => [
+			B::Simple::OP::Variable::Lexical->new(
+				name => '$x',
+				introduce => 1,
+				context => "inherit",
+			),
+		],
+	),
+}