#!/usr/bin/env perl
use strict;
use warnings;

use FindBin;
use lib "$FindBin::Bin/lib";
use Gears::Util;

use Getopt::Std;
use File::Spec;

my %opt;
getopts("wo:" => \%opt);

my $impl_file = shift or die 'require impl file';
my $impl_ir         = Gears::Util->parse_with_rewrite(File::Spec->rel2abs($impl_file));
my $interface_file  = Gears::Util->find_header($impl_ir->{isa},"$FindBin::Bin/..");

my $inter_ir        = Gears::Util->parse_with_rewrite($interface_file);


my $output_file = $impl_file;
$output_file =~ s/\.h/.cbc/;
my $stdout    = *STDOUT;

if ($opt{w}) {
    open $stdout, '>', $output_file;
} elsif ($opt{o}) {
    open $stdout, '>', $opt{o};
}


emit_include_part($stdout, $inter_ir->{name});
emit_impl_header_in_comment($stdout, $impl_file);
emit_constracutor($stdout,$impl_ir,$inter_ir);
emit_code_gears($stdout,$impl_ir,$inter_ir);
close $stdout;

sub emit_include_part {
  my ($out, $interface) = @_;
  print $out <<"EOF"
#include "../context.h"
#interface "$interface.h"

EOF
}

sub emit_impl_header_in_comment {
  my ($out, $impl_file) = @_;
  my $line =  Gears::Util->slup($impl_file);
  print $out "// ----\n";
  map { print $out "// $_\n" } split /\n/, $line;
  print $out "// ----\n\n";
}

sub emit_constracutor {
  my ($out, $impl_ir, $inter_ir) = @_;

  my @inter_data     = @{$inter_ir->{data}};
  my @impl_data      = @{$impl_ir->{data}};
  my $instance_inter = shift @inter_data;

  if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) {
    $instance_inter = $1;
  }

  my $instance_impl  = lcfirst $impl_ir->{name};
  $instance_impl     =~ s/([A-Z])/_\l$1/g;

  print $out <<"EOF";
$impl_ir->{isa}* create$impl_ir->{name}(struct Context* cbc_context) {
    struct $impl_ir->{isa}* $instance_inter  = new $impl_ir->{isa}();
    struct $impl_ir->{name}* $instance_impl = new $impl_ir->{name}();
    $instance_inter->$instance_inter = (union Data*)$instance_impl;
EOF

  for my $datum (@impl_data) {
        if ($datum =~ /\w+ \w+\* (\w+)/) {
            print $out "    ${instance_impl}->$1 = NULL;\n";
            next;
        }
        if ($datum =~ /\w+ \w+ (\w+)/) {
            print $out "    ${instance_impl}->$1 = 0;\n";
        }

        if ($datum =~ /\w+(\*)? (\w+)/) {
            my $is_pointer = $1;
            my $var_name = $2;
            if ($1) {
                print $out "    ${instance_impl}->$var_name = NULL;\n";
            } else {
                print $out "    ${instance_impl}->$var_name  = 0;\n";
            }
        }
  }

  for my $datum (@inter_data) {
        if ($datum =~ /\w+ \w+\* (\w+)/) {
            print $out "    ${instance_inter}->$1 = NULL;\n";
            next;
        }
        if ($datum =~ /\w+ \w+ (\w+)/) {
            print $out "    ${instance_inter}->$1 = 0;\n";
            next;
        }
        if ($datum =~ /\w+(\*)? (\w+)/) {
            my $is_pointer = $1;
            my $var_name = $2;
            if ($1) {
                print $out "    ${instance_inter}->$var_name = NULL;\n";
            } else {
                print $out "    ${instance_inter}->$var_name  = 0;\n";
            }
        }
  }


  for my $code (@{$impl_ir->{codes}}) {
      my $code_gear = $code->{name};
      print $out "    ${instance_impl}->$code_gear = C_$code_gear$impl_ir->{name};\n"
  }

  for my $code (@{$inter_ir->{codes}}) {
      my $code_gear = $code->{name};
      print $out "    ${instance_inter}->$code_gear = C_$code_gear$impl_ir->{name};\n"
  }

print $out "    return $instance_inter;\n";
print $out "}\n";
}


sub emit_code_gears {
  my ($out, $impl_ir, $inter_ir) = @_;
  my $impl = $impl_ir->{name};
  my $interface_name = $inter_ir->{name};

  my @inter_data = @{$inter_ir->{data}};
  my $instance_inter = shift @inter_data;
  if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) {
    $instance_inter = $1;
  }
  my $instance_impl = lcfirst $impl_ir->{name};
  $instance_impl =~ s/([A-Z])/_\l$1/g;
  my $data_gear_types = {};

  if (defined $impl_ir->{codes}) {
    for my $cg (@{$impl_ir->{codes}}) {
      my $data_gears = $cg->{args};
      while ($data_gears =~ /Type\*\s*(\w+),/g) {
          $data_gears =~ s/Type\*/struct $impl*/;
      }

      while ($data_gears =~ /Isa\*\s*(\w+),/g) {
          $data_gears =~ s/Isa\*/struct $interface_name*/;
      }
      print $out "__code $cg->{name}$impl(";
      print $out "$data_gears) {\n\n";

      #__code next(...), __code whenEmpty(...)
      my @cg = ();
      while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) {
        push(@cg, $1);
      }

      if (@cg) {
        if (@cg == 2) {
          print $out "  if (:TODO:) {\n";
          print $out "       goto ",shift(@cg),";\n";
          print $out "  }\n";
          print $out "  goto ",shift(@cg),";\n";
        } else {
          print $out "  goto ",shift(@cg),";\n";
        }
      }
      print $out "}\n\n";
    }
  }

  for my $code_ir (@{$inter_ir->{codes}}) {
    my $data_gears = $code_ir->{args};
    $data_gears =~ s/Impl/struct $impl/g;

    while ($data_gears =~ /Type\*\s*(\w+),/g) {
        $data_gears =~ s/Type\*/struct $interface_name*/;
    }

    print $out "__code $code_ir->{name}$impl(";
    print $out "$data_gears) {\n\n";

    #__code next(...), __code whenEmpty(...)
    my @cg = ();
    while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) {
      push(@cg, $1);
    }

    if (@cg) {
      if (@cg == 2) {
        print $out "  if (:TODO:) {\n";
        print $out "       goto ",shift(@cg),";\n";
        print $out "  }\n";
        print $out "  goto ",shift(@cg),";\n";
      } else {
        print $out "  goto ",shift(@cg),";\n";
      }
    }
    print $out "}\n\n";
  }
}