package Blacknote::Interface;
use strict;
use warnings FATAL => qw(all);
use Exporter qw(import);
use Class::MOP;
use Class::MOP::Class;
use Blacknote::Logging;
use Carp qw(confess croak cluck);
use Data::Dumper;
use List::Util qw(any first);
use File::Slurp qw(write_file);
use feature qw(say);

our @EXPORT = qw(definterface defimpl implements construct finalize defclass defrole fulfill dyn_fulfill defsm defclass_strict
	
);
our @EXPORT_OK = ();
sub STUB;
# [Define interface]
sub definterface ($@) {
	my $name = shift;
	if(index($name,"I") != 0){
		WARN "Interface $name doesn't follow naming conventions";
	}
	my @funcs = @_;
	my ($pkg) = caller;
	my $pkgname = $pkg . "::" . $name;
	DEBUG "Defining interface [$name] in namespace $pkg";
	my $meta = Class::MOP::Class->create(
		$pkg . "::" . $name => (
			version => 1.00,
			attributes => [
			],
			#methods => {
			#	map { my $fname = $_; $_ => sub { confess "UNIMPLEMENTED INTERFACE FUNCTION `$fname'" } } @funcs
			#}
			methods => {
				map { my $fname = $_; $_ => \&STUB } @funcs
			}
		)
	);
	push @EXPORT_OK, $pkgname;
	return $meta;
}

# [Define impementation of interface]
sub defimpl($$$%) {
	my ($interface, $name, $strict, %methods) = @_;
	my $meta = Class::MOP::Class->create(
		$name => (
			superclasses => [(caller)[0]."::".$interface],
			methods => \%methods
		)
	);
	my $imeta = Class::MOP::Class->initialize($interface);
	TRACE Dumper $imeta;
	DEBUG "`$name' is implementing `$interface' with methods: " . join ",", grep { $_ ne "meta" } $meta->get_method_list;
	for($imeta->get_method_list){
		if(not $meta->get_method($_) and $_ ne "new" and $strict){
			croak __PACKAGE__ . ":[ERROR]: "  . "Function `$_' has no implementation in class `$name'";
		}
	}
	return $meta;
}
sub defclass ($%) {
	my ($cname, %opt) = @_;
	my $methods = $opt{methods} // {};
	my $attributes = $opt{attributes};
	my $superclasses = $opt{superclasses} // [];
	my ($pkg) = caller;
	Class::MOP::Class->create(
		$pkg . "::" .$cname => (
			methods => $methods,
			superclasses => [ @$superclasses ],
			attributes => [ map {
					Class::MOP::Attribute->new($_ => (accessor => $_, init_arg => $_))
				} @$attributes ]
		)
	);
}

sub defclass_strict ($%) {
	my ($cname, %opt) = @_;
	my $methods = $opt{methods} // {};
	my $attributes = $opt{attributes}; # href
	my $superclasses = $opt{superclasses} // [];
	my ($pkg) = caller;
	my %defaults = (
		aref => sub { [] },
		href => sub { {} },
		sref => sub { \0 },
		scalar => sub { '' },
		array => sub { my @d; return @d },
		hash => sub { my %h = (); return %h },
		ref => sub { undef },
	);
	$defaults{ptr} = $defaults{sref};
	$defaults{'$'} = $defaults{scalar};
	$defaults{'@'} = $defaults{"array"};
	$defaults{'%'} = $defaults{"hash"};
	$defaults{'\$'} = $defaults{"sref"};
	$defaults{'\@'} = $defaults{"aref"};
	$defaults{'\%'} = $defaults{"href"};
	Class::MOP::Class->create(
		$pkg . "::" .$cname => (
			methods => $methods,
			superclasses => [ @$superclasses ],
			attributes => [ map {
					Class::MOP::Attribute->new($_ =>
						(
							accessor => $_,
							init_arg => $_,
							default => defined $defaults{$attributes->{$_}} ? $defaults{$attributes->{$_}} : $attributes->{$_},
						)
					)
				} keys %$attributes ]
		)
	);
}

sub defrole ($%) {
	my $rolename = shift;
	if(index($rolename,"R") != 0){
		WARN "Role '$rolename' doesn't follow naming conventions";
	}
	my %opts = @_;
	my $funcs = $opts{methods};
	my $adherence = $opts{adheres_to};
	if($funcs){
		croak "Expected hashref" unless ref($funcs) eq "HASH";
	}
	if($adherence){
		croak "Expected arrat ref" unless ref($adherence) eq "ARRAY";
	}
	my ($pkg) = caller;
	DEBUG "Defining role $rolename in namespace: " . (caller)[0];
	Class::MOP::Class->create(
		$pkg . "::" .$rolename => (
			superclasses => $adherence // [],
			methods => $funcs // {},
		)
	);
}

# [make object fullfill a role]
# Adds all methods from ROLE to OBJECT dynamically
sub dyn_fulfill ($$) {
	my ($role, $obj) = @_;
	my $meta = Class::MOP::get_metaclass_by_name($role);
	croak "No such role: $role" unless $meta;
	for my $method_name($meta->get_method_list){
		my $method = $meta->get_method($method_name);
		DEBUG "Method is: $method";
		$obj->meta->add_method($method_name, $method);
	}
	$obj->meta->superclasses($obj->meta->superclasses(), (caller)[0]."::".$role);
	DEBUG "Object $obj dynamically mix-ins the $role role";
}

# A simple state class

definterface IState => qw(name init update fini);
my $state_meta = defclass State => attributes => [ qw(name init update fini) ],
	superclasses => ["Blacknote::Interface::IState" ];

$state_meta->make_immutable;

# Define a state machine
sub defsm {
	my ($smname, @states) = @_;
	$_->isa("Blacknote::Interface::IState") or croak "Not a state object `$_'" for @states;
	DEBUG "Defining a globaly accessbile state machine package $smname";
	my $meta_sm = Class::MOP::Class->create(
	$smname =>
		attributes => [
			Class::MOP::Attribute->new(
				state => (
					reader => "get_state",
					writer => {
						set_state => sub {
							my $self = shift;
							my $value = shift;
							my $state = first { $_->name eq $value } @{$self->valid_states};
							say $value;
							DEBUG "Setting state: " . $state->name;
							$self->{state} = $state;
						}
					}
				),
			),
			Class::MOP::Attribute->new(
				valid_states => ( default => sub { return  \@states  }, reader => 'valid_states' ),
			),
			Class::MOP::Attribute->new(
				etc => (default => sub { {} }, accessor => 'etc' )
			),
			Class::MOP::Attribute->new(
				_cycles => (default => 0, accessor => "_cycles")
			),
		],
		methods => {
			switch_state => sub {
				my $self = shift;
				my $next = shift;
				$self->get_state->fini->();
				$self->set_state($next);
				$self->get_state->init->();
			},
			cycle => sub {
				my $self = shift;
				my $next_state = $self->get_state->update->();
				$self->_cycles($self->_cycles+1);
				if($next_state =~ m/(?:\w+?)/ and not $next_state =~ /^\d+$/){
					$self->switch_state($next_state);
				}else{
					WARN "Invalid state passed to SM: $next_state";
				}
			},
			fini => sub {
				my $self = shift;
				#NOTE: Default start and end states?
				my $last_state = $self->valid_states->[scalar(@{$self->valid_states})-1];
				$self->switch_state($last_state->name);
				$self->get_state->fini->();
				DEBUG "Total state machine cycles: ". $self->_cycles();
			}
		}
	);
	$meta_sm->add_method(init => sub { 
		DEBUG "initializing state machine";
		my $self = shift;
		my @states = @{$self->valid_states};
		$self->set_state($states[0]->name);
		$self->get_state->init->();
		});
	#$meta_sm->add_after_method_modifier(new => sub { my $self=shift;$self->set_state(@{$self->valid_states}[0]); $self->get_state->init; });
	$meta_sm->make_immutable;
}

#defsm MySM => qw(one two three);

# [make object class fullfill a role]
# Adds all methods from ROLE to CLASS
sub fulfill ($@) {
	my ($rolename, @classnames) = @_;
	my ($pkg) = caller;
	DEBUG "Classes fullfilling role $rolename: " . join ",",@classnames;
	for my $classname(@classnames){
		my $metaclass = Class::MOP::get_metaclass_by_name($classname);
		my $meta = Class::MOP::get_metaclass_by_name($rolename);
		croak "No such class:" . $metaclass unless $metaclass;
		croak "No such role: $rolename" unless $meta;
		for my $method_name($meta->get_method_list){
			my $method = $meta->get_method($method_name);
			$metaclass->add_method($method_name, $method);
		}
		#NOTE: rolename must be a fully qualified package name
		$metaclass->superclasses($metaclass->superclasses(), $rolename);
	}
}

sub construct ($;%) {
	my $cname = shift;
	my $meta = Class::MOP::get_metaclass_by_name($cname);
	croak "No such class: $cname" if not $meta;
	my $obj = $meta->new_object(@_);
	return $obj
}

sub implements ($$) {
	my ($obj, $interfname) = @_;
	my $imeta = Class::MOP::get_metaclass_by_name($interfname);
	croak "Object must be defined" unless defined $obj;
	#NOTE: Class can also be a role or basically any defined class
	croak "No such class: $interfname" if not $imeta;
	my $bool = any { ref($obj) eq $_ } $imeta->direct_subclasses;
	croak "Object [$obj] doesn't implement [$interfname]" if not $bool;
	return $bool;
}

sub does_adhere_to {
	my ($class, $interf) = @_;
	my $meta = Class::MOP::get_metaclass_by_name($class);
	my @classmethods = ();
	my $is_regular = 0;
	if(not defined $meta){
		# We assume this is a standart perl class
		@classmethods = keys %$class::;
		$is_regular = 1;
	}else{
		@classmethods = $meta->get_all_methods;
	}
	my @interfmethods = grep { not /meta/ } $interf->get_method_list;
	for my $interfmethod(@interfmethods){
		if(not $is_regular){
			my $method = $meta->get_method($interfmethod);
			croak "Class: `" . $class . "' does not adhere to interface `" . $interf->name.".' Missing implementation of method $interfmethod" unless defined $method;
# FIXME: Stop when method is a stub/unimplemented
			TRACE "[FIXME] stop when method is a stub/unimplemented";
		}
	}
}

sub finalize (){
	for my $meta(Class::MOP::get_all_metaclass_instances){
		$meta->make_immutable;
	}
}


# This state machine is experimental as of yet
#my $meta = defsm MySm => ( Blacknote::Interface::State->new(name => "one", init => sub { DEBUG "INIT" }, update => sub { DEBUG "update" }  ));
#my $sm = $meta->new_object;
#$sm->init;
#$sm->cycle;


DEBUG __PACKAGE__() . " Imported\n";

# We lock-in and freeze all objects created here
# We also check if interfaces are implemented before we run anything
# TODO: Check for role conflicts
INIT {
	my @metanames = grep { /.+?::I[A-Z].+?/ and not /^Class::MOP.+?/ and $_ } Class::MOP::get_all_metaclass_names();
	for (@metanames){
		# Metaclass is an interface
		my $interf = Class::MOP::get_metaclass_by_name($_);
		my @subclasses = grep { not m/^Class::MOP.+?/  } $interf->direct_subclasses;
		DEBUG "$interf -> subclasses = @subclasses";
		for my $class(@subclasses){
			DEBUG "Checking implementation of ".$class;
			does_adhere_to($class, $interf);
		}
	}
	finalize;
}

1;

=pod

=head1 NAME

	Blacknote::Interface

=head1 SYNOPSIS

	use Blacknote::Interface qw(defclass defclass_strict definterface);

	# define an interface
	definterface IMyInterface => qw(implement_me some_function etc);

	# define a class
	defclass MyClass =>
		superclasses => ['CurrentPackage::IMyInterface'],
		methods => {
			implement_me => sub {...},
			some_function => sub {...},
			etc => sub {...}
		};

=head1 DESCRIPTION

	Main engine functions. These functions define
	various objects and perform compile-time check
	for correct usage, such a interface implementations
	and role method collision checks.

=head1 FUNCTIONS

=head3 finalize

	This function makes all created objects 'immutable'
	as per Class::MOP interface, making them ready for use

.