modmark/pl_proto.pl

#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;
use lib "/home/swatson/perl5/lib/perl5";
use GraphViz2;

my $SOURCE_FILE = $ARGV[0];

sub read_to_var($) {
	my $file_path = shift;
	my $content;
	open(my $fh, '<', $file_path) or die "cannot open file $file_path";
	{
		local $/;
		$content = <$fh>;
	}
	close($fh);

	return $content;
}

my $src_content = read_to_var($SOURCE_FILE);

sub trim($) {
	my $str = shift;
	$str =~ s/^\s+|\s+$//g;
	return $str;
}

my @module_library_paths = (
	".",
);
my %modules;

sub parse_module_file {
	my $src = shift;

	my %module;


	my $last_proc_type = "null";
	my $last_input = "null";
	my $last_output = "null";
	foreach my $line ( split("\n", $src) ) {
		chomp $line;
		if ( $line =~ m/^#/ ) {
			next;
		}

		if ( $line =~ m/^Manufacturer:(.*)/ ) {
			my $manu = $1;
			$manu = trim($manu);
			$module{'Manufacturer'} = $manu;
		}

		if ( $line =~ m/^Module:(.*)/ ) {
			my $mod = $1;
			$mod = trim($mod);
			$module{'Module'} = $mod;
		}

		if ( $line =~ m/^Revision:(.*)/ ) {
			my $rev = $1;
			$rev = trim($rev);
			$module{'Rev'} = $rev;
		}

		if ( $line =~ m/^-\ / ) {
			if ( $line =~ m/^-\ Input:(.*)/ ) {
				my $input = $1;
				$input = trim($input);
				my %input_chars;
				$last_input = $input;
				$last_proc_type = "input";
				$module{'Inputs'}->{$input} = \%input_chars;
			}

			if ( $line =~ m/^-\ Knob:(.*)/ ) {
				my $knob = $1;
				$knob = trim($knob);
				my %knob_chars;
				$last_input = $knob;
				$last_proc_type = "input";
				$module{'Inputs'}->{$knob} = \%knob_chars;
			}

			if ( $line =~ m/^-\ Output:(.*)/ ) {
				my $output = $1;
				$output = trim($output);
				my %output_chars;
				$last_output = $output;
				$last_proc_type = "output";
				$module{'Outputs'}->{$output} = \%output_chars;
			}

			if ( $line =~ m/^-\ Button:(.*)/ ) {
				my $button = $1;
				$button = trim($button);
				my %button_chars;
				$last_input = $button;
				$last_proc_type = "input";
				$module{'Inputs'}->{$button} = \%button_chars;
			}
			
		}

		if ( $line =~ m/^--\ / ) {
			if ( $line =~ m/^--\ Position:(.*)/ ) {
				my $pos_args = $1;
				$pos_args = trim($pos_args);
				if ( $last_proc_type eq "input" ) {
					$module{'Inputs'}->{$last_input}->{'pos'} = $pos_args;
				} elsif ( $last_proc_type eq "output" ) {
					$module{'Outputs'}->{$last_output}->{'pos'} = $pos_args;
				}
			}
		}

	}

	return \%module;
}

my %AST;

my %PARSE_TABLE = (
	'comment' => '^#.*$',
	'title' => '^Title: (.*)$',
	'mod_path' => '^ModuleDir\ "(.*)"$',
	'import' => '^import (Module)::([a-zA-Z0-9]{1,})::([a-zA-Z0-9]{1,})(.*$)',
	'set' => '^set\ (.*)$',
	'connect' => '^connect(.*)$',
);

my %PARSE_RULES = (
	'comment' => sub {
		# Do nothing, throw this line out
	},
	'title' => sub {
		my $title = shift;
		$AST{'Title'} = $title;
	},
	'mod_path' => sub {
		my $file_path = shift;
		if ( ! -d $file_path ) {
			die "Path: $file_path doesn't look like a directory, exiting";
		}

		push(@module_library_paths, $file_path);
	},
	'import' => sub {
		my $module_import = shift;
		my $import_manu = shift;
		my $import_mod = shift;
		my $import_as = shift;
		my @module_files = sub {
			my @files;
			foreach my $path ( @module_library_paths ) {
				my @f = split("\n", `find $path`);
				foreach my $file ( @f ) {
					if ( $file =~ m/.module$/ ) {
						my $f_bn = `basename $file`;
						chomp $f_bn;
						if ( ! grep(/$f_bn/, @files) ) {
							push(@files, $file);
						}
					}
				}
			}
			return @files;
		}->();
		foreach my $mod_file ( @module_files ) {
			my $mod_file_content = read_to_var($mod_file);
			my $mod_ref = parse_module_file($mod_file_content);

			if ( $import_mod eq $$mod_ref{'Module'} ) {

				if ( defined $AST{'Modules'} ) {
					my $r = grep { $import_mod eq $_->{'Module'} } @{$AST{'Modules'}};
					if ( $r == 0 ) {
						push(@{$AST{'Modules'}}, $mod_ref);
					}
				} else {
					push(@{$AST{'Modules'}}, $mod_ref);
				}
			} else {
				next;
			}
		}
	},
	'set' => sub {
		my $set_line = shift;
		my $mod_to_set;
		my $attr_to_set;
		my $attr_param;
		my $value;
		my $setter = sub {
			my $mod_to_set = shift;
			my $attr_to_set = shift;
			my $attr_param = shift;
			if ( $attr_param eq "position" ) {
				$attr_param = "pos";
			}
			my $value = shift;

			my %set_params = (
				'Param' => $attr_param,
				'Value' => $value,
			);

			# Check values against mod definition
			# Pull mod ref out of AST for straight forward checking
			my $mod_ref;
			# Check we have module in AST
			my $r = grep { $mod_to_set eq $_->{'Module'} } @{$AST{'Modules'}};
			if ( $r eq 0 ) {
				die "Can't set value on module that is not imported: $mod_to_set\n";
			} else {
				foreach my $module_ref ( @{$AST{'Modules'}} ) {
					if ( $mod_to_set eq $$module_ref{'Module'} ) {
						$mod_ref = $module_ref;
						last;
					}
				}
			}

			# Check that module has param we want to set
			if ( ! $attr_to_set eq $$mod_ref{'Inputs'}->{$attr_to_set} ) {
				die "Can't set a param that doesn't existing in the module spec: $attr_to_set";
			}

			# If the set has an attr param, check that it's in the allowed range on the attr
			if ( $attr_param ne "null" ) {
				my $attr_range = $$mod_ref{'Inputs'}->{$attr_to_set}->{'pos'};
				if ( $attr_range =~ m/([0-9]{1,2})\-([0-9]{1,2})/ ) {
					my $r_begin = $1;
					my $r_end = $2;
					if ( $value > $r_end || $value < $r_begin ) {
						die "Parse error: attr_param value: $value for $attr_to_set : $attr_param is outside of range: $r_begin $r_end";
					}
				} else {
					die "Somehow encountered parse error in setter for module file $$mod_ref{'Module'}\n";
				}
			}

			$AST{'Sets'}->{$mod_to_set}->{$attr_to_set} = \%set_params;
		};

		if ( $set_line =~ m/(^[A-Z]{1}[A-Za-z0-9]{1,})\.{1}([A-Za-z0-9]{1,})\ \=\ (.*)$/ ) {
			$mod_to_set = $1;
			$attr_to_set = $2;
			$value = $3;
		} elsif ( $set_line =~ m/(^[A-Z]{1}[A-Za-z]{1,})\.{1}([A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})\ \=\ (.*)$/ ) {
			$mod_to_set = $1;
			$attr_to_set = $2;
			$attr_param = $3;
			$value = $4;
		} else {
			die "Parse error at $set_line";
		}

		if ( ! defined $attr_param || $attr_param eq "" ) {
			$attr_param = "null",
		};

		$setter->($mod_to_set,$attr_to_set,$attr_param,$value);
	},
	'connect' => sub {
		my $connect_line = shift;
		$connect_line = trim($connect_line);
		if ( $connect_line =~ m/([A-Z]{1}[A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})\ ([A-Z]{1}[A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})/ ) {
			my $output_mod = $1;
			my $output_mod_port = $2;
			my $input_mod = $3;
			my $input_mod_dst = $4;

			# Check we have modules defined
			if ( ! defined $AST{'Modules'} ) {
				die "Parse error: Encountered connection but no modules are imported: $connect_line"
			} else {
				# Check that connect references imported modules and get module refs
				my $output_mod_ref;
				my $input_mod_ref;
				foreach my $mod_ref ( @{$AST{'Modules'}} ) {
					if ( $$mod_ref{'Module'} eq $output_mod ) {
						$output_mod_ref = $mod_ref;
					} elsif ( $$mod_ref{'Module'} eq $input_mod ) {
						$input_mod_ref = $mod_ref;
					}
				}
				# If we reach the end of the loop and input/output refs are not set
				# we didn't find the module, and it's a parse error
				if ( ! defined $output_mod_ref ||
				     $output_mod_ref eq "" ||
				     ! defined $input_mod_ref ||
				     $input_mod_ref eq "" ) {
					die "Parse error, couldn't find $output_mod or $input_mod in AST"
				}

				# Check src/dst ports
				if ( ! defined $$output_mod_ref{'Outputs'}->{$output_mod_port} ) {
					die "Parse error: $output_mod_port is not defined in module $output_mod"
				} elsif ( ! defined $$input_mod_ref{'Inputs'}->{$input_mod_dst} ) {
					die "Parse error: $input_mod_dst is not defined in module $input_mod"
				}

				# Everything looks good, make connection
				my $get_conn_id = sub {
					if ( ! defined $AST{'Connections'} ) {
						return 0;
					} else {
						my $c = 0;
						foreach my $conn_id ( keys %{$AST{'Connections'}} ) {
							$c++;
						}
						return $c;
					}
				};
				my $conn_id = $get_conn_id->();
				my %conn_map = (
					'Output_Module' => $output_mod,
					'Output_Port' => $output_mod_port,
					'Input_Module' => $input_mod,
					'Input_Mod_Dst' => $input_mod_dst,
				);
				$AST{'Connections'}->{$conn_id} = \%conn_map;
				
			}
		} else {
			die "Parse error at $connect_line";
		}
	},
	
);

# Basic line parser
sub line_parse($) {
	my $line = shift;
	my $line_type = "null";
	my @line_caps;
	foreach my $key ( keys %PARSE_TABLE ) {
		if ( $line =~ m/$PARSE_TABLE{$key}/ ) {
			$line_type = $key;
		}
	}

	if ( $line_type ne "null" && $line =~ m/$PARSE_TABLE{$line_type}/) {
		if ( defined $1 && ! defined $2 ) {
			$PARSE_RULES{$line_type}->($1);
		} elsif ( defined $1 && defined $2 && defined $3 && defined $4 ) {
			# This is for `import`
			$PARSE_RULES{$line_type}->($1,$2,$3,$4);
		} else {
			$PARSE_RULES{$line_type}->();
		}
	} else {
		print("$line\n");
	}
}

# For testing module definitions
if ( defined $ARGV[1] && $ARGV[1] eq "--import-test" ) {
	my $mod_ref = parse_module_file($src_content);
	print Dumper $mod_ref;
	exit 0;
}
	
# MAIN starts here - split the input and parse it
foreach my $line ( split("\n", $src_content) ) {
	chomp $line;
	if ( $line eq "" ) {
		next;
	}
	line_parse($line);
}

# Dump the AST for now. This is where we'd render the output
print Dumper %AST;

my $graph = GraphViz2->new(
        edge   => {color => 'grey'},
        global => {directed => 1},
        graph  => {label => $AST{'Title'}, rankdir => 'TB'},
	node   => {shape => 'square'},
);

# Given a mod_ref, construct a graph object
# that represents a module
sub module_node_constructor($$) {
	my $graph = shift;
	my $mod_ref = shift;
	$graph->push_subgraph(
		name => "cluster_$$mod_ref{'Module'}",
		graph => {label => "$$mod_ref{'Module'}"},
		node => {color => 'black', shape => 'circle'},
	);

	# $graph->push_subgraph(
	# 		name => "cluster_mod_info",
	# 		graph => {label => "mod_info"},
	# 		node => {color => 'grey', shape => 'square'},
	# );
	# foreach my $node_name ( keys %{$mod_ref} ) {
	# 	if ( $node_name =~ m/Module|Manufacturer|Rev/ ) { 
	# 		$graph->add_node(name => "$node_name\n: $$mod_ref{$node_name}", shape => 'square');
	# 	}
	# }

	# $graph->pop_subgraph;

	if ( defined $AST{'Sets'}->{$$mod_ref{'Module'}} ) {
		my $sets_ref = $AST{'Sets'}->{$$mod_ref{'Module'}};
		foreach my $set ( keys %{$sets_ref} ) {
			my $name = "cluster" . "_" . "$set";
			my $label = "$set" . "_" . "settings";
			$graph->push_subgraph(
				name => $name,
				graph => {label => $label},
				node => {color => "green", shape => 'square'},
			);
			$graph->add_node(name => "$set : $$sets_ref{$set}->{'Param'} : $$sets_ref{$set}->{'Value'}");
			$graph->pop_subgraph;
		}
	}

	# Handle connections
	if ( defined $AST{'Connections'} ) {
		my $conn_ref = $AST{'Connections'};
		foreach my $conn ( keys %{$conn_ref} ) {
			if ($$mod_ref{'Module'} eq $$conn_ref{$conn}->{'Output_Module'} ) {
				my $name = "cluster" . "_" . "$$conn_ref{$conn}->{'Output_Port'}_$conn";
				my $label = "$$conn_ref{$conn}->{'Output_Port'}_$conn";
				$graph->push_subgraph(
					name => $name,
					graph => {label => $label},
					node => {color => "blue"},
				);
				$graph->add_node(name => "$$conn_ref{$conn}->{'Output_Port'}");
				$graph->pop_subgraph;
			} elsif ($$mod_ref{'Module'} eq $$conn_ref{$conn}->{'Input_Module'} ) {
				my $name = "cluster" . "_" . "$$conn_ref{$conn}->{'Input_Mod_Dst'}_$conn";
				my $label = "$$conn_ref{$conn}->{'Input_Mod_Dst'}_$conn";
				$graph->push_subgraph(
					name => $name,
					graph => {label => $label},
					node => {color => 'purple'},
				);
				$graph->add_node(name => "$$conn_ref{$conn}->{'Input_Mod_Dst'}");
				$graph->pop_subgraph;
			}
			
		}
	}

	$graph->pop_subgraph;
}

# Draw modules
foreach my $mod_ref ( @{$AST{'Modules'}} ) {
	module_node_constructor($graph,$mod_ref);
}

# Draw connections
foreach my $conn_ref ( keys %{$AST{'Connections'}} ) {
	my $from = $AST{'Connections'}->{$conn_ref}->{'Output_Port'};
	my $to = $AST{'Connections'}->{$conn_ref}->{'Input_Mod_Dst'};
	$graph->add_edge(color => 'red', from => $from, to => $to);
}

my $format = 'svg';
$graph->run(format => $format, output_file => "test.svg");