From 458cf889e6ed331d9e5084cf8e199166ce983286 Mon Sep 17 00:00:00 2001
From: Daniel Friesel <derf@finalrewind.org>
Date: Tue, 16 May 2017 15:48:34 +0200
Subject: autogenerate simple models (without args or parameters) from AC++
 attributes

---
 bin/dfatool                   |  6 ++++
 lib/AspectC/Repo.pm           | 40 ++++++++++++++++++---
 lib/Kratos/DFADriver.pm       | 17 +++++++--
 lib/Kratos/DFADriver/Model.pm | 81 ++++++++++++++++++++++++++++++++++++++++++-
 4 files changed, 137 insertions(+), 7 deletions(-)

diff --git a/bin/dfatool b/bin/dfatool
index 254a779..a5a53e9 100755
--- a/bin/dfatool
+++ b/bin/dfatool
@@ -16,6 +16,7 @@ my %opt;
 GetOptions(
 	\%opt,
 	qw{
+	  class=s
 	  exclude-states=s@
 	  ignore-nested-calls
 	  logging!
@@ -51,6 +52,7 @@ my ( $command, $xml_file, @data_files ) = @ARGV;
 
 my $driver = Kratos::DFADriver->new(
 	cache => $opt{'no-cache'} ? 0 : 1,
+	class_name      => $opt{class},
 	data_file       => $data_files[0],
 	excluded_states => $opt{'exclude-states'} // [],
 	fast_analysis   => $opt{'zomg-fasta-nao'} // 0,
@@ -74,6 +76,10 @@ my $driver = Kratos::DFADriver->new(
 );
 
 my %action = (
+	autogen => sub {
+
+		# nothing to do
+	},
 	clean => sub {
 		$driver->launchpad_log_clean;
 	},
diff --git a/lib/AspectC/Repo.pm b/lib/AspectC/Repo.pm
index 6f59117..35bffbe 100644
--- a/lib/AspectC/Repo.pm
+++ b/lib/AspectC/Repo.pm
@@ -46,13 +46,33 @@ sub parse_xml {
 		my $filename = $node->getAttribute('filename');
 		my $id       = $node->getAttribute('id');
 		if ( defined $id ) {
-			$self->{files}[$id] = $filename;
+			$self->{files}{$id} = $filename;
 		}
 		else {
 			say STDERR "repo.acp: File ${filename} has no ID";
 		}
 	}
 
+	for my $aspect (
+		$xml->findnodes(
+			    '/ac-model/root/Namespace[@name="::"]/children/Aspect'
+			  . ' | /ac-model/root/Namespace[@name="::"]/children/Namespace'
+		)
+	  )
+	{
+		my $aspect_name = $aspect->getAttribute('name');
+		for my $attr_node ( $aspect->findnodes('./children/Attribute') ) {
+			my $attr_name = $attr_node->getAttribute('name');
+			my $attr_id   = $attr_node->getAttribute('id');
+			if ( defined $attr_id ) {
+				$self->{attributes}{$attr_id} = {
+					namespace => $aspect_name,
+					name      => $attr_name,
+				};
+			}
+		}
+	}
+
 	for my $node (
 		$xml->findnodes('/ac-model/root/Namespace[@name="::"]/children/Class') )
 	{
@@ -70,7 +90,7 @@ sub parse_xml {
 			push(
 				@sources,
 				{
-					file => $self->{files}[ $source->getAttribute('file') ],
+					file => $self->{files}{ $source->getAttribute('file') },
 					kind => $source_loc_kind[ $source->getAttribute('kind') ],
 				}
 			);
@@ -84,6 +104,7 @@ 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;
 
@@ -92,12 +113,23 @@ sub parse_xml {
 				$result_type = $typenode->getAttribute('signature');
 			}
 
-			#print "$id $name $kind $result_type <- ";
 			for my $argnode ( $fnode->findnodes('./arg_types/Type') ) {
 				push( @args, $argnode->getAttribute('signature') );
 			}
 
-			#say join( q{, }, @args );
+			my $fun = {
+				name     => $name,
+				returns  => $result_type,
+				argtypes => [@args],
+			};
+
+			if ($attributes) {
+				$fun->{attributes} = [
+					map { $self->{attributes}{$_}{name} }
+					  split( qr{ \s+ }x, $attributes )
+				];
+			}
+			$class->{function}{$name} = $fun;
 		}
 		$self->{class}{$class_name} = $class;
 	}
diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm
index 8c8f780..7ceaa4a 100644
--- a/lib/Kratos/DFADriver.pm
+++ b/lib/Kratos/DFADriver.pm
@@ -35,11 +35,24 @@ sub new {
 
 	$self->{dfa}           = Kratos::DFADriver::DFA->new(%opt);
 	$self->{mimosa}        = MIMOSA->new(%opt);
-	$self->{model}         = Kratos::DFADriver::Model->new(%opt);
 	$self->{repo}          = AspectC::Repo->new;
-	$self->{class_name}    = $self->{model}->class_name;
 	$self->{lp}{iteration} = 1;
 
+	if ( -r $opt{xml_file} ) {
+		$self->{model}      = Kratos::DFADriver::Model->new(%opt);
+		$self->{class_name} = $self->{model}->class_name;
+	}
+	elsif ( $opt{class_name} ) {
+		$self->{model} = Kratos::DFADriver::Model->new_from_repo(
+			repo       => $self->{repo},
+			class_name => $opt{class_name},
+			xml_file   => $opt{xml_file},
+		);
+	}
+	else {
+		die('Neither driver.xml nor class name specified, cannot continue');
+	}
+
 	bless( $self, $class );
 
 	$self->set_paths;
diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm
index 677fd99..f87b81c 100644
--- a/lib/Kratos/DFADriver/Model.pm
+++ b/lib/Kratos/DFADriver/Model.pm
@@ -8,7 +8,7 @@ use parent 'Class::Accessor';
 
 use Carp;
 use Carp::Assert::More;
-use List::Util qw(first);
+use List::Util qw(first uniq);
 use XML::LibXML;
 
 Kratos::DFADriver::Model->mk_ro_accessors(qw(class_name xml));
@@ -32,6 +32,85 @@ sub new {
 	return $self;
 }
 
+sub new_from_repo {
+	my ( $class, %opt ) = @_;
+	my $repo       = $opt{repo};
+	my $class_name = $opt{class_name};
+
+	my @states;
+	my %transition;
+
+	if ( not exists $repo->{class}{$class_name} ) {
+		die("Unknown class: $class_name\n");
+	}
+	my $class_base = $repo->{class}{$class_name};
+
+	for my $function ( values %{ $class_base->{function} } ) {
+		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 );
+			}
+			else {
+				say "wat $attrib";
+			}
+		}
+	}
+
+	@states = uniq @states;
+	@states = sort @states;
+
+	my $xml = XML::LibXML::Document->new('1.0');
+
+	my $data_node        = $xml->createElement('data');
+	my $driver_node      = $xml->createElement('driver');
+	my $states_node      = $xml->createElement('states');
+	my $transitions_node = $xml->createElement('transitions');
+
+	$driver_node->setAttribute( name => $class_name );
+
+	$xml->setDocumentElement($data_node);
+	$data_node->appendChild($driver_node);
+	$driver_node->appendChild($states_node);
+	$driver_node->appendChild($transitions_node);
+
+	for my $state (@states) {
+		my $state_node = $xml->createElement('state');
+		$state_node->setAttribute( name => $state );
+		$states_node->appendChild($state_node);
+	}
+	for my $transition ( sort keys %transition ) {
+		my $transition_node = $xml->createElement('transition');
+		my $level = $transition eq 'epilogue' ? 'epilogue' : 'user';
+		$transition_node->setAttribute( name => $transition );
+		for my $src_state ( @{ $transition{$transition}{src} } ) {
+			my $src_node = $xml->createElement('src');
+			my $src_name = $xml->createTextNode($src_state);
+			$src_node->appendChild($src_name);
+			$transition_node->appendChild($src_node);
+		}
+		for my $dst_state ( @{ $transition{$transition}{dst} } ) {
+			my $dst_node = $xml->createElement('dst');
+			my $dst_name = $xml->createTextNode($dst_state);
+			$dst_node->appendChild($dst_name);
+			$transition_node->appendChild($dst_node);
+		}
+		my $level_node = $xml->createElement('level');
+		my $level_name = $xml->createTextNode($level);
+		$level_node->appendChild($level_name);
+		$transition_node->appendChild($level_node);
+		$transitions_node->appendChild($transition_node);
+	}
+
+	$xml->toFile( $opt{xml_file} );
+
+	return $class->new(%opt);
+}
+
 sub parse_xml_property {
 	my ( $self, $node, $property_name ) = @_;
 
-- 
cgit v1.2.3