path: root/toolbin/transform_dsl.pl

#!/usr/bin/perl6
use v6;

grammar DSL {
    my $e = "document start";
    token TOP { ^ <include_block>* <quant_block>* $ }

    token include_block {
	'include' \s+ '"' <filename> '"' \s* ';' \s*
    }
    token quant_block {
	<quant_type> \s+ <name> \s* '{' \s*
	     [[{$e=$/} <decl>|<evolve>|<on_block>|<emit_block>|<comment>] \s*] *
	\s* '}' \s* }
    token on_block {
	'on' \s+ <name> \s* '{' \s*
	    [[{$e=$/} <evolve>|<comment>] \s*] *
	\s* '}' }
    token emit_block {
	'emit' \s+ <name> \s* '{' \s*
	    [[{$e=$/} <evolve>|<default>|<after>|<if_>|<comment>] \s*] *
	\s* '}' }

    token decl { <type> \s+ <name> \s* ['=' \s* <expr> \s*]? ';' }
    token evolve { <name>\' \s* '=' \s* <expr> \s* ';' }
    token default { 'default' \s+ <bool> \s* ';' }
    token if_ { 'if' \s+ <name>\' <expr> \s* ';' }
    token after { 'after' \s+ <expr> \s* ';' }
    token comment { '//' \N* $$ }

    token name { \w+ }
    token filename { \w+ }
    token type { [':'|\w]+ }
    token quant_type { ['discrete'|'continuous'|'const'] }
    token bool { ['true'|'false'] }
    token expr { <-[;{}]>* } # MAYBE TODO: improve

    method error() {
	return $e;
    }
}

sub transform($quant_blocks) {
	my %quant_types;
	my %vars;
	my %consts;
	my %res = :const(''), :decl(''), :evolve(''), :on(''),
	:qdq(''), :emit(''), :gpe(''), :gen(''), :debug('');

	my %rawexpr_evolve;

	# funs to replace def strings to C++-Code
	sub replace_consts($expr is copy) {
	    for %consts.kv -> $name, $val {
		$expr = $expr.subst(rx/<<$name>>/, "$val /* $name */", :g);
	    }
	    return $expr;
	}

	sub replace_dt($expr is copy) {
	    $expr = $expr.subst(rx/<<'dt'>>/, "td()", :g);
	    return $expr;
	}

	sub replace_expr($expr is copy, %local_exprs) {
	    # replace post-event vars ONCE
	    for %vars.kv -> $prop, $quant {
		# post event is only defined for continuous quants
		next if %quant_types{$quant} eq 'discrete';
		$expr = $expr.subst(rx/<<$prop>>"'"/, "(%local_exprs{$prop})", :g);
	    }
	    return $expr;
	}

	sub replace_vars($expr is copy) {
	    # replace normal vars
	    for %vars.kv -> $prop, $quant {
		if %quant_types{$quant} eq 'continuous' {
		    $expr = $expr.subst(rx/<<$prop>>/, "_CP($prop)", :g);
		} else {
		    die unless %quant_types{$quant} eq 'discrete';
		    $expr = $expr.subst(rx/<<$prop>>/, "_DP($prop)", :g);
		}
	    }
	    return $expr;
	}

	sub replace_all($expr is copy, %local_exprs) {
	    $expr = replace_consts(
		    replace_dt(
		    replace_vars(
		    replace_expr($expr, %local_exprs))));
	    $expr = $expr.subst(rx/"_PROT">>/, "q", :g);
	    return $expr;
	}

	sub replace_all_after($expr is copy, %local_exprs) {
	    $expr = $expr.subst(rx/"'"/, "_PROTTICK", :g);
	    $expr = replace_vars($expr);
	    $expr = $expr.subst(rx/"_PROTTICK"/, "'", :g);
	    return replace_consts(
		   replace_expr($expr, %local_exprs));
	}
	
	# gather all properties (required to patch expressions)
	for @($quant_blocks) {
	    my $qc = $_<name>;
	    my $qt = $_<quant_type>;
	    %quant_types{$qc} = $qt;
	    for @($_<decl>) {
		my $name = $_<name>;
		if $qt eq 'const' {
		    if not %consts{$name} {
			my $type = $_<type>;
			%consts{$name} = $_<expr>;
			%res<const> ~= "const $type $name = $_<expr>;\n";
		    }
		} else {
		    die "multiple declaration of $_<name>" if %(%vars, %consts){$name};
		    %vars{$name} = $qc;
		}
	    }
	    for @($_<evolve>) { %rawexpr_evolve{$_<name>} = $_<expr>; }
	}
	
	# print definitions
	for @($quant_blocks) {
	    my $qc = $_<name>;
	    my $emit = $_<emit_block>;
	    my %types;
	    next if ($qc eq 'const');
	    %res = %res <<~>> "// Quantor: $qc\n";
	    for @($_<decl>) {
		%types{$_<name>} = $_<type>;
		if %quant_types{%vars{$_<name>}} eq 'continuous' {
		    %res<decl> ~=
			"GEN_CP($qc, $_<name>, \"$_<name>\", $_<type>, ("
			~ replace_consts($_<expr>) ~ "));\n";
		} else {
		    %res<decl> ~=
			"GEN_DP($qc, $_<name>, \"$_<name>\", $_<type>);\n";
		}
	    }
	    for @($_<evolve>) {
		%res<evolve> ~= "GEN_CP_EVOLVE($_<name>, "
		    ~ replace_all($_<expr>, %rawexpr_evolve) ~ ");\n";
	    }
	    for @($_<emit_block>) {
		my $dqc = $_<name>;
		my %rawexpr_emit =
		    gather for @($_<evolve>) { take %($_<name>, $_<expr>); };
		my %rawexpr_after =
		    gather for @(%vars) { my $k=$_.key; take %($k, "_TP($k)"); };

		%res<emit> ~= "GEN_QUANT_EMIT($qc, $dqc, $_<default>[0]<bool>);\n";
		if $_<after>.elems > 0 {
		    # TODO: generate has-var-delay statement at most
		    #       once per discrete quant
		    %res<emit> ~=
			"GEN_QUANT_HASVARDELAY($dqc);\n"
			~ "GEN_DP_DELAY($dqc, $qc, "
			~ replace_all_after($_<after>[0]<expr>, %rawexpr_after)
			~ ");\n";
		}
		for @($_<evolve>) {
		    die "$_<name> of %vars{$_<name>} != $qc, $dqc"
			unless (%vars{$_<name>} eq $dqc) || (%vars{$_<name>} eq $qc);
		    %res<gpe> ~=
			"GEN_CP_GENERATE($qc, $dqc, $_<name>) \{ "
			~ "value = " ~ replace_all($_<expr>, %rawexpr_emit)
			~ "; \}\};\n";
		}
	    }
	    for @($_<on_block>) {
		my $src_quant = $_<name>;
		%res<qdq> ~= "GEN_QDQ($_<name>, $qc);\n";
		my %is_evolved;
		my %rawexpr_on =
		    gather for @($_<evolve>) { take %($_<name>, $_<expr>); };
		for @($_<evolve>) {
		    my $dprop = $_<name>;
		    %res<on> ~= "GEN_CP_APPLY($dprop, $src_quant, true) \{\n"
			~ "  const %types{$dprop} tmp = "
			~ replace_all($_<expr>, %rawexpr_on) ~ ";\n"
			~ "  transaction.template set<$dprop>(tmp);\n";
		    for @($emit) {
			my $dst_quant = $_<name>;
			my %rawexpr_emit =
			    gather for @($_<evolve>) { take %($_<name>, $_<expr>); };
			for @($_<if_>) {
			    if $_<name> eq $dprop {
				# %res<on> ~= "std::cout << \"combine(tmp($dprop" ~ replace_consts($_<expr>) ~ ")\" << std::endl;";
				%res<on> ~= "  intent.template get<$dst_quant>()"
				    ~ ".combine(tmp" ~ replace_consts($_<expr>)
				    ~ ");\n";
			    }
			}
		    }
		    %res<on> ~= "\}\};\n"; # sic!
		    %is_evolved{$dprop} = True;
		}
		for @($emit) {
		    my $dst_quant = $_<name>;
		    for @($_<if_>) {
			unless %is_evolved{$_<name>} {
			    # HINT: use _CP for access because the value is unchanged
			    %res<on> ~=
				"GEN_CP_APPLY($_<name>, $src_quant, false) \{\n"
				# ~ "std::cout << \"combine(_CP($_<name>" ~ replace_consts($_<expr>) ~ ")\" << std::endl;"
				~ "  intent.template get<$dst_quant>()"
				~ ".combine(_CP($_<name>)" ~ replace_consts($_<expr>)
				~ ");\n\}\};\n";
			    # TODO: replace consts
			}
		    }
		}
	    }
	}

	# create list of
	%res<lists> =
	    "typedef boost::mpl::list<\n\t"
	    ~ %vars.keys.map({"boost::mpl::pair<$_, boost::mpl::bool_<true>>"}).join(",\n\t")
	    ~ "\n> all;\n\n"
	    ~ "typedef boost::mpl::list<\n\t"
	    ~ %vars.keys.map({"boost::mpl::pair<$_, boost::mpl::bool_<false>>"}).join(",\n\t")
	    ~ "\n> all_ro;";
	
	# push results
	%res = %res <<~>> "\n";
	say "#ifndef RASIMU_SIMULATION_DEFINITION
#define RASIMU_SIMULATION_DEFINITION

#include \"core/property_abbrevations_begin.hpp\"

namespace ModelConsts \{
%res<const>
\}
%res<decl>
%res<evolve>
%res<on>
%res<qdq>
%res<emit>
%res<gen>
%res<gpe>","

namespace Lists \{
%res<lists>","
\}

// generated by ",qqx{perl6 --version|grep version},"

/* DEBUG MSGS
%res<debug>
*/
#include \"core/property_abbrevations_end.hpp\"
#endif // RASIMU_SIMULATION_DEFINITION";
}

sub parse($src) {
    my $p = DSL.new;
    if $p.parse(slurp $src) {
	my @qbs = @($<quant_block>);
	for @($<include_block>) {
	    @qbs.push(parse($_<filename> ~ ".model"));
	}
	return @qbs;
    } else {
	die "Error after:\n", $p.error;
    }
}

sub MAIN($src) {
    transform(parse($src));
    #parse($src).perl.say;
}