Support specification of transitions in AspectC++ annotations

4 files changed, 123 insertions, 44 deletions

diff --git a/lib/AspectC/Repo.pm b/lib/AspectC/Repo.pm
index ec5bcd0..a2e94d2 100644
--- a/lib/AspectC/Repo.pm
+++ b/lib/AspectC/Repo.pm
@@ -64,10 +64,23 @@ sub parse_xml {
 		for my $attr_node ( $aspect->findnodes('./children/Attribute') ) {
 			my $attr_name = $attr_node->getAttribute('name');
 			my $attr_id   = $attr_node->getAttribute('id');
+			my @args;
+			for my $arg_node ( $attr_node->findnodes('./args/Arg') ) {
+				my $arg_name = $arg_node->getAttribute('name');
+				my $arg_type = $arg_node->getAttribute('type');
+				push(
+					@args,
+					{
+						name => $arg_name,
+						type => $arg_type,
+					}
+				);
+			}
 			if ( defined $attr_id ) {
 				$self->{attributes}{$attr_id} = {
 					namespace => $aspect_name,
 					name      => $attr_name,
+					arguments => \@args,
 				};
 			}
 		}
@@ -104,7 +117,6 @@ sub parse_xml {
 			my $name        = $fnode->getAttribute('name');
 			my $id          = $fnode->getAttribute('id') // q{?};
 			my $kind        = $fnode->getAttribute('kind');
-			my $attributes  = $fnode->getAttribute('attributes');
 			my $result_type = q{?};
 			my @args;
 
@@ -123,12 +135,30 @@ sub parse_xml {
 				argtypes => [@args],
 			};
 
-			if ($attributes) {
-				$fun->{attributes} = [
-					map { $self->{attributes}{$_}{name} }
-					  split( qr{ \s+ }x, $attributes )
-				];
+			for my $annotation_node (
+				$fnode->findnodes('./annotations/Annotation') )
+			{
+				my $attr_id   = $annotation_node->getAttribute('attribute');
+				my $attribute = {
+					name      => $self->{attributes}{$attr_id}{name},
+					namespace => $self->{attributes}{$attr_id}{namespace},
+				};
+				for my $param_node (
+					$annotation_node->findnodes('./parameters/Parameter') )
+				{
+					my $value      = $param_node->getAttribute('value');
+					my $expression = $param_node->getAttribute('expression');
+					push(
+						@{ $attribute->{args} },
+						{
+							value      => $value,
+							expression => $expression,
+						}
+					);
+				}
+				push( @{ $fun->{attributes} }, $attribute );
 			}
+
 			my $hash_key = sprintf( '%s(%s)', $name, join( q{, }, @args ) );
 			$class->{function}{$hash_key} = $fun;
 		}
diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm
index 07f478c..deb758c 100644
--- a/lib/Kratos/DFADriver.pm
+++ b/lib/Kratos/DFADriver.pm
@@ -424,9 +424,9 @@ sub printf_parameterized {
 				$key, $status, $param, $std_ind_param, $std_this, $ratio,
 				$fline );
 		}
-		if (exists $r_by_param->{$param}) {
-			printf("  %s: spearman_r for global %s is %.3f (p = %.3f)\n",
-				$key, $param, $r_by_param->{$param}, -1);
+		if ( exists $r_by_param->{$param} ) {
+			printf( "  %s: spearman_r for global %s is %.3f (p = %.3f)\n",
+				$key, $param, $r_by_param->{$param}, -1 );
 		}
 	}
 
@@ -859,18 +859,19 @@ EOF
 	$buf .= "\n\t\t\\path\n";
 
 	for my $transition ( $self->model->transitions ) {
-		for my $origin ( @{ $transition->{origins} } ) {
+		for my $transition_elem ( @{ $transition->{transitions} } ) {
+			my ( $origin, $destination ) = @{$transition_elem};
 			my @edgestyles;
 			if ( $transition->{level} eq 'epilogue' ) {
 				push( @edgestyles, 'dashed' );
 			}
-			if ( $origin eq $transition->{destination} ) {
+			if ( $origin eq $destination ) {
 				push( @edgestyles, 'loop above' );
 			}
 			my $edgestyle
 			  = @edgestyles ? '[' . join( q{,}, @edgestyles ) . ']' : q{};
 			$buf
-			  .= "\t\t  ($origin) edge ${edgestyle} node {$transition->{name}} ($transition->{destination})\n";
+			  .= "\t\t  ($origin) edge ${edgestyle} node {$transition->{name}} ($destination)\n";
 		}
 	}
 	$buf .= "\t\t;\n";
@@ -992,8 +993,7 @@ sub to_test_h {
 	my ($self) = @_;
 	my $class_name = $self->{class_name};
 
-	my $class_prefix
-	  = $self->repo->get_class_path_prefix( $class_name );
+	my $class_prefix = $self->repo->get_class_path_prefix($class_name);
 
 	my $buf = <<"EOF";
 
@@ -1138,7 +1138,7 @@ sub launchpad_connect {
 	$self->{port} = Device::SerialPort->new( $self->{port_file} )
 	  or croak("Error openig serial port $self->{port_file}");
 
-	$self->{port}->baudrate($self->{baud_rate} // 115200);
+	$self->{port}->baudrate( $self->{baud_rate} // 115200 );
 	$self->{port}->databits(8);
 	$self->{port}->parity('none');
 	$self->{port}->read_const_time(500);
diff --git a/lib/Kratos/DFADriver/DFA.pm b/lib/Kratos/DFADriver/DFA.pm
index 33d96c3..9b581d8 100644
--- a/lib/Kratos/DFADriver/DFA.pm
+++ b/lib/Kratos/DFADriver/DFA.pm
@@ -6,6 +6,7 @@ use 5.020;
 
 use parent 'Class::Accessor';
 
+use Data::Dumper;
 use FLAT::DFA;
 use Math::Cartesian::Product;
 
@@ -65,7 +66,21 @@ sub dfa {
 	$dfa->set_accepting( $dfa->get_states );
 
 	for my $transition ( $self->model->transitions ) {
-		my $destination = $transition->{destination};
+		print Dumper( $transition->{parameters} );
+
+		for my $param ( @{ $transition->{parameters} } ) {
+			if ( not defined $param->{values} ) {
+				die(
+"argument values for transition $transition->{name} are undefined\n"
+				);
+			}
+			if ( @{ $param->{values} } == 0 ) {
+				die(
+"argument-value list for transition $transition->{name} is empty \n"
+				);
+			}
+		}
+
 		my @argtuples
 		  = cartesian { 1 } map { $_->{values} } @{ $transition->{parameters} };
 
@@ -73,7 +88,8 @@ sub dfa {
 		# an empty array if @{$transition->{parameters}} is empty
 
 		for my $argtuple (@argtuples) {
-			for my $origin ( @{ $transition->{origins} } ) {
+			for my $transition_pair ( @{ $transition->{transitions} } ) {
+				my ( $origin, $destination ) = @{$transition_pair};
 				$dfa->add_transition(
 					$self->model->get_state_id($origin),
 					$self->model->get_state_id($destination),
diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm
index 216f3b8..264a443 100644
--- a/lib/Kratos/DFADriver/Model.pm
+++ b/lib/Kratos/DFADriver/Model.pm
@@ -74,32 +74,57 @@ sub new_from_repo {
 	for my $function ( values %{ $class_base->{function} } ) {
 		my %param_values;
 		for my $attrib ( @{ $function->{attributes} // [] } ) {
-			if ( $attrib =~ s{ ^ src _ }{}x ) {
-				push( @states,                                    $attrib );
-				push( @{ $transition{ $function->{name} }{src} }, $attrib );
-			}
-			elsif ( $attrib =~ s{ ^ dst _ }{}x ) {
-				push( @states,                                    $attrib );
-				push( @{ $transition{ $function->{name} }{dst} }, $attrib );
-			}
-			elsif ( $attrib =~ s{ ^ required_in_ }{}x ) {
-				push(
-					@{
-						$self->{custom_code}{after_transition_by_state}{$attrib}
-					},
-					$function->{name}
-				);
+			if ( $attrib->{namespace} eq 'Model' ) {
+				if ( $attrib->{name} =~ m{ ^ transition }x
+					and @{ $attrib->{args} } == 2 )
+				{
+					push( @states, $attrib->{args}[0]{expression} );
+					push( @states, $attrib->{args}[1]{expression} );
+					push(
+						@{ $transition{ $function->{name} }{src} },
+						$attrib->{args}[0]{expression}
+					);
+					push(
+						@{ $transition{ $function->{name} }{dst} },
+						$attrib->{args}[1]{expression}
+					);
+					push(
+						@{ $transition{ $function->{name} }{transitions} },
+						[
+							$attrib->{args}[0]{expression},
+							$attrib->{args}[1]{expression}
+						]
+					);
+				}
+				elsif ( $attrib->{name} =~ m{ ^ testval }x
+					and @{ $attrib->{args} } == 2 )
+				{
+					push(
+						@{ $param_values{ $attrib->{args}[0]{value} } },
+						$attrib->{args}[1]{value}
+					);
+				}
+				elsif (
+					$attrib->{name} =~ m{ ^ required_in_ (?<state> .* ) $ }x )
+				{
+					push(
+						@{
+							$self->{custom_code}{after_transition_by_state}
+							  { $+{state} }
+						},
+						$function->{name}
+					);
+				}
+				else {
+					printf( "wat %s::%s\n",
+						$attrib->{namespace}, $attrib->{name} );
+				}
 			}
 			elsif ( $attrib =~ m{ ^ epilogue $ }x ) {
 				$transition{ $function->{name} }{level} = 'epilogue';
 			}
-			elsif ( $attrib
-				=~ m{ ^ testarg _ (?<index> [^_]+ ) _ (?<value> [^_]+) $ }x )
-			{
-				push( @{ $param_values{ $+{index} } }, $+{value} );
-			}
 			else {
-				say "wat $attrib";
+				printf( "wat %s::%s\n", $attrib->{namespace}, $attrib->{name} );
 			}
 		}
 		if ( exists $transition{ $function->{name} } ) {
@@ -160,22 +185,30 @@ sub new_from_repo {
 	my @transition_names = sort keys %transition;
 
 	for my $i ( 0 .. $#transition_names ) {
-		my $name = $transition_names[$i];
-		my $guess_level = ( $name eq 'epilogue' ? 'epilogue' : 'user' );
+
+		my $name         = $transition_names[$i];
+		my @origins      = uniq @{ $transition{$name}{src} };
+		my @destinations = uniq @{ $transition{$name}{dst} };
+		my $guess_level  = ( $name eq 'epilogue' ? 'epilogue' : 'user' );
+
 		$self->{transition}{$name} = {
 			name            => $name,
 			id              => $i,
-			destination     => $transition{$name}{dst}[0],
-			origins         => $transition{$name}{src},
+			destination     => \@destinations,
+			origins         => \@origins,
+			transitions     => $transition{$name}{transitions},
 			level           => $transition{$name}{level} // $guess_level,
 			parameters      => $transition{$name}{parameters} // [],
+			duration        => { static => 0 },
 			energy          => { static => 0 },
 			rel_energy_prev => { static => 0 },
 			rel_energy_next => { static => 0 },
+			timeout         => { static => 0 },
 		};
-		if ( @{ $transition{$name}{dst} } > 1 ) {
+		if ( @destinations > 1 ) {
+			my $dst_str = join( q{, }, @destinations );
 			warn(
-"Transition ${name} has several destination states. This is not supported yet.\n"
+"Transition ${name} has several destination states ($dst_str). This is only partially supported.\n"
 			);
 		}
 	}