package myinc::XSPP::Virtual;

use strict;
use warnings;

my %type_map;

sub new {
    return bless { virtual_methods => {},
                   virtual_classes => {},
                   skip_virtual_base => {},
                   }, $_[0];
}

sub register_plugin {
    my( $class, $parser ) = @_;
    my $instance = $class->new;
    
    $parser->add_toplevel_tag_plugin ( plugin => $instance, tag => 'VirtualTypeMap' );
    $parser->add_class_tag_plugin( plugin => $instance, tag => 'NoVirtualBase' );
    $parser->add_class_tag_plugin( plugin => $instance, tag => 'VirtualImplementation' );
    $parser->add_method_tag_plugin( plugin => $instance, tag => 'Virtual' );
    $parser->add_post_process_plugin( plugin => $instance );
}

sub handle_toplevel_tag {
    my( $self, $empty, $tag, %args ) = @_;
    
    if( $tag eq 'VirtualTypeMap' ) {
        my %map = @{$args{any_named_arguments}};
        my $typename = $map{Name}[0][0] || undef;
        die 'No Name in VirtualTypeMap' if !$typename;
        my $vtmap = {
            'convert_return'  => $map{ConvertReturn}[0][0] || undef,
            'default_value'   => $map{DefaultValue}[0][0] || undef,
            'type_char'       => $map{TypeChar}[0][0] || undef,
            'arguments'       => $map{Arguments}[0][0] || undef,
        };
        foreach my $key (sort keys( %$vtmap ) ) {
            delete($vtmap->{$key}) unless defined($vtmap->{$key});
        }
        $type_map{$typename} = $vtmap;
    }
    
    1;
}

sub handle_class_tag {
    my( $self, $class, $tag, %args ) = @_;

    if( $tag eq 'NoVirtualBase' ) {
        $self->{skip_virtual_base}{$class->cpp_name} = 1;
    } elsif( $tag eq 'VirtualImplementation' ) {
        my %map = @{$args{any_named_arguments}};

        $self->{virtual_implementation}{$class->cpp_name} =
            { name           => $map{Name}[0][0] || '',
              declaration    => join( "\n", @{$map{Declaration}[0] || []} ),
              implementation => join( "\n", @{$map{Implementation}[0] || []} ),
            };
    }

    1;
}

sub handle_method_tag {
    my( $self, $method, $tag, %args ) = @_;

    if(    $args{any_positional_arguments}
        && $args{any_positional_arguments}[0] eq 'pure' ) {
        $self->{virtual_methods}{$method} = [ $method, 1 ];
    } else {
        $self->{virtual_methods}{$method} = [ $method, 0 ];
    }

    1;
}

%type_map =
  ( 'bool'             => { convert_return => 'SvTRUE( ret )',
                            default_value  => 'false',
                            type_char      => 'b',
                            },
    'int'              => { convert_return => 'SvIV( ret )',
                            default_value  => '0',
                            type_char      => 'i',
                            },
    'long'             => { convert_return => 'SvIV( ret )',
                            default_value  => '0',
                            type_char      => 'l',
                            },
    'double'           => { convert_return => 'SvNV( ret )',
                            default_value  => '0.0',
                            type_char      => 'd',
                            },
    'wxAlignment'      => { convert_return => '(wxAlignment)SvIV( ret )',
                            default_value  => '(wxAlignment)0',
                            type_char      => 'i',
                            },
    'wxGridCellAttr::wxAttrKind' =>
                       => { convert_return => '(wxGridCellAttr::wxAttrKind)SvIV( ret )',
                            default_value  => '(wxGridCellAttr::wxAttrKind)0',
                            type_char      => 'i',
                            },
    'unsigned int'     => { convert_return => 'SvUV( ret )',
                            default_value  => '0',
                            type_char      => 'I',
                            },
    'wxUint32'         => { convert_return => 'SvIV( ret )',
                            default_value  => '0',
                            type_char      => 'i',
                            },    
    # TODO merge
    'size_t'           => { convert_return => 'SvUV( ret )',
                            default_value  => '0',
                            type_char      => 'I',
                            },
    'wxString'         => { convert_return => 'wxPli_sv_2_wxString( aTHX_ ret )',
                            default_value  => 'wxEmptyString',
                            type_char      => 'P',
                            arguments      => '&%s',
                            },
    'wxString&'         => { convert_return => 'wxPli_sv_2_wxString( aTHX_ ret )',
                            default_value  => 'wxEmptyString',
                            type_char      => 'P',
                            arguments      => '&%s',
                            },    
    'wxString*'         => { convert_return => '(wxString*)wxPli_sv_2_wxString( aTHX_ ret )',
                            default_value  => 'wxEmptyString',
                            type_char      => 'P',
                            arguments      => '&%s',
                            },
    # TODO merge
    'const wxString&'  => { convert_return => 'wxPli_sv_2_wxString( aTHX_ ret )',
                            default_value  => 'wxEmptyString',
                            type_char      => 'P',
                            arguments      => '&%s',
                            },
    'wxVariant&'       => { convert_return => 'wxPli_sv_2_wxvariant( aTHX_ ret )',
                            default_value  => 'wxVariant()',
                            type_char      => 'q',
                            arguments      => '&%s, "Wx::Variant"',
                            },
    'wxVariant'        => { convert_return => 'wxPli_sv_2_wxvariant( aTHX_ ret )',
                            default_value  => 'wxVariant()',
                            type_char      => 'q',
                            arguments      => '&%s, "Wx::Variant"',
                            },    
    # TODO merge
    'const wxVariant&' => { convert_return => 'wxPli_sv_2_wxvariant( aTHX_ ret )',
                            default_value  => 'wxVariant()',
                            type_char      => 'q',
                            arguments      => '&%s, "Wx::Variant"',
                            },
    'wxBitmap'        => { convert_return => '*(wxBitmap*)wxPli_sv_2_object( aTHX_ ret, "Wx::Bitmap" )',
                           default_value  => 'wxBitmap()',
                           type_char      => 'O',
                           arguments      => '&%s',
                           },
    # TODO merge
    'const wxBitmap&' => { convert_return => '*(wxBitmap*)wxPli_sv_2_object( aTHX_ ret, "Wx::Bitmap" )',
                           default_value  => 'wxBitmap()',
                           type_char      => 'O',
                           arguments      => '&%s',
                           },
    'const wxPoint&'  => { convert_return => 'wxPli_sv_2_wxpoint( aTHX_ ret )',
                           default_value  => 'wxPoint()',
                           type_char      => 'o',
                           arguments      => '&%s, "Wx::Point"',
                           },
    'wxSize'          => { convert_return => 'wxPli_sv_2_wxsize( aTHX_ ret )',
                           default_value  => 'wxSize()',
                           type_char      => 'o',
                           arguments      => '&%s, "Wx::Size"',
                           },        
    'const wxSize&'   => { convert_return => 'wxPli_sv_2_wxsize( aTHX_ ret )',
                           default_value  => 'wxSize()',
                           type_char      => 'o',
                           arguments      => '&%s, "Wx::Size"',
                           },    
    'const wxRect&'   => { convert_return => '*(wxRect*)wxPli_sv_2_object( aTHX_ ret, "Wx::Rect" )',
                           default_value  => 'wxRect()',
                           type_char      => 'O',
                           arguments      => '&%s',
                           },
    
    'const wxHeaderColumn&' =>
                         { convert_return => '*(wxHeaderColumn*)wxPli_sv_2_object( aTHX_ ret, "Wx::HeaderColumn" )',
                           type_char      => 'O',
                           arguments      => '&%s',
                           },
    'wxGrid*' =>         { convert_return => '(wxGrid*)wxPli_sv_2_object( aTHX_ ret, "Wx::Grid" )',
                           type_char      => 'O',
                           arguments      => '&%s',
                           },
    'wxGridCellAttr*' => { convert_return => 'convert_GridCellAttrOut( aTHX_ ret )',
                           type_char      => 'O',
                           arguments      => '&%s',
                           },
    );

sub _virtual_typemap {
    my( $type ) = @_;
    my $tm = $type_map{$type->print};

    die "No virtual typemap for ", $type->print unless $tm;

    return $tm;
}

sub _emit_method_conditions {
    my( $class ) = @_;
    my @res;

    foreach my $method ( @{$class->methods} ) {
        next unless $method->isa( 'ExtUtils::XSpp::Node::Preprocessor' );
        push @res, $method;
    }

    return @res;
}

sub post_process {
    my( $self, $nodes ) = @_;

    my @copy = @$nodes;

    foreach my $node ( @copy ) {
        next unless $node->isa( 'ExtUtils::XSpp::Node::Class' );
        next if $self->{virtual_classes}{$node};
        my( @virtual, $abstract_class, @classes, %redefined );
        
        @classes = $node;
        # find virtual method in this class and in all base classes
        while( @classes ) {
            my $class = shift @classes;
            next if    $class ne $node
                    && $self->{skip_virtual_base}{$class->cpp_name};

            foreach my $method ( @{$class->methods} ) {
                next unless $method->isa( 'ExtUtils::XSpp::Node::Method' );
                # do not generate virtual handling code for methods that
                # are marked as virtual in a base class and redefined as
                # non-virtual in this class
                unless( $self->{virtual_methods}{$method} ) {
                    $redefined{$method->cpp_name} ||= 1;
                    next;
                }
                next if $redefined{$method->cpp_name};

                push @virtual, $self->{virtual_methods}{$method};
                $abstract_class ||= $virtual[-1][1];
            }

            push @classes, @{$class->base_classes};
        }

        next unless @virtual;

        # TODO wxPerl-specific
        my $cpp_class;
        if( $self->{virtual_implementation}{$node->cpp_name}{name} ) {
            $cpp_class = $self->{virtual_implementation}{$node->cpp_name}{name};
        } else {
            ( $cpp_class = $node->cpp_name ) =~ s/^wx/wxPl/;
        }
        my $perl_class;
        if( $abstract_class ) {
            ( $perl_class = $cpp_class ) =~ s/^wx/Wx::/;
        } else {
            ( $perl_class = $cpp_class ) =~ s/^wxPl/Wx::/;
        }
        my $file = lc "xspp/$cpp_class.h";

        my $include = ExtUtils::XSpp::Node::Raw->new
                          ( rows => [ "#include \"$file\"" ] );
        for( my $i = 0; $i <= $#$nodes; ++$i ) {
            next unless $nodes->[$i] == $node;
            splice @$nodes, $i, 0, $include;
            # TODO a very crude hack that should somehow be
            # encapsulated by XS++: the class definition in the
            # generated .h need to use the preprocessor conditions
            # applied to the various methods, but the conditions are
            # only emitted together with the method definition, which
            # require the header
            #
            # this forces the preprocessor #defines to be emitted just before
            # including the header
            splice @$nodes, $i, 0, _emit_method_conditions( $node );
            last;
        }

        # for abstract class, delete all constructors
        my @constructors = grep $_->isa( 'ExtUtils::XSpp::Node::Constructor' ),
                                @{$node->methods};
        my @cpp_code;
        $node->delete_methods( @constructors );

        push @cpp_code, sprintf <<EOC,
#include "cpp/v_cback.h"

class %s : public %s
{
    %s
    // TODO wxPerl-specific
    WXPLI_DECLARE_V_CBACK();
public:
    SV* GetSelf()
    {
        return m_callback.GetSelf();
    }

EOC
          $cpp_class, $node->cpp_name,
          $self->{virtual_implementation}{$node->cpp_name}{declaration} || '';

        # add the (implicit) default constructor
        unless( @constructors ) {
            push @constructors,
                 ExtUtils::XSpp::Node::Constructor->new
                     ( cpp_name        => $cpp_class,
                       arguments       => [],
                       emit_condition  => $node->condition_expression,
                       );
        }

        my( @new_constructors, @call_base );
        foreach my $constructor ( @constructors ) {
            my $cpp_parms = join ', ', map $_->name, @{$constructor->arguments};
            my $cpp_args = join ', ', map $_->print, @{$constructor->arguments};
            my $comma = @{$constructor->arguments} ? ',' : '';

            push @cpp_code, sprintf <<EOC,
    %s( const char* CLASS %s %s )
        : %s( %s ),
          m_callback( "%s" )
    {
        m_callback.SetSelf( wxPli_make_object( this, CLASS ), true );
    }
EOC
              $cpp_class, $comma, $cpp_args, $node->cpp_name, $cpp_parms, $perl_class;

            my $code = [ "RETVAL = new $cpp_class( CLASS $comma $cpp_parms );" ];

            my $ctor_name = $constructor->perl_name eq $node->cpp_name ? $cpp_class : $constructor->perl_name;
            my $new_ctor = ExtUtils::XSpp::Node::Constructor->new
                               ( cpp_name   => $cpp_class,
                                 perl_name  => $ctor_name,
                                 code       => $code,
                                 arguments  => $constructor->arguments,
                                 postcall   => $constructor->postcall,
                                 cleanup    => $constructor->cleanup,
                                 condition  => $constructor->condition,
                                 );

            push @new_constructors, $new_ctor;
        }

        foreach my $m ( @virtual ) {
            my( $method, $pure ) = @$m;
            my( @cpp_parms, @arg_types );
            foreach my $arg ( @{$method->arguments} ) {
                my $typemap = _virtual_typemap( $arg->type );
                my $format = $typemap->{arguments} || '%s';

                push @cpp_parms, sprintf $format, $arg->name;
                push @arg_types, $typemap->{type_char};
            }

            my @base_parms = map $_->name, @{$method->arguments};
            my( $cpp_parms, $arg_types );
            if( @cpp_parms ) {
                $cpp_parms = join ', ', @cpp_parms;
                $arg_types = '"' . join( '', @arg_types ) . '", ';
            } else {
                $cpp_parms = '';
                $arg_types = 'NULL';
            }

            push @cpp_code, '#if ' . ( $method->condition_expression || 1 );
            push @cpp_code, '    ' . $method->print_declaration;
            my $call_base = $node->cpp_name . '::' . $method->cpp_name .
              '(' . join( ', ', @base_parms ) . ')';
            if( $method->ret_type->is_void ) {
                my $default = $pure ? 'return' : $call_base;
                push @cpp_code, sprintf <<EOT,
    // TODO wxPerl-specific
    {
        dTHX;
        if( wxPliFCback( aTHX_ &m_callback, "%s" ) )
        {
            wxPliCCback( aTHX_ &m_callback, G_SCALAR|G_DISCARD,
                         %s %s );
        }
        else
            %s;
    }
EOT
                  $method->cpp_name, $arg_types, $cpp_parms, $default;
            } else {
                my $ret_type_map = _virtual_typemap( $method->ret_type );
                my $default = $pure ? $ret_type_map->{default_value} : $call_base;
                # pure virtual without default value: abort
                if( !defined $default ) {
                    # TODO better error message
                    $default = 'croak( "Must override" );';
                } else {
                    $default = 'return ' . $default;
                }
                my $convert = $ret_type_map->{convert_return};
                push @cpp_code, sprintf <<EOT,
    // TODO wxPerl-specific
    {
        dTHX;
        if( wxPliFCback( aTHX_ &m_callback, "%s" ) )
        {
            wxAutoSV ret( aTHX_ wxPliCCback( aTHX_ &m_callback, G_SCALAR,
                                             %s %s ) );
            return %s;
        }
        else
            %s;
    }
EOT
                  $method->cpp_name, $arg_types, $cpp_parms, $convert, $default;
            }
            push @cpp_code, '#endif';

            my $callbase_decl = $method->ret_type->print . ' ' .
                                'base_' . $method->cpp_name . '( ' .
                                join( ', ', map $_->print, @{$method->arguments} ) . ')' .
                                ( $method->const ? ' const' : '' );

            if( !$pure ) {
                push @cpp_code, '#if ' . ( $method->condition_expression || 1 );
                push @cpp_code, '    ' . $callbase_decl, '    {';

                if( $method->ret_type->is_void ) {
                    push @cpp_code, '        ' . $call_base . ';';
                } else {
                    push @cpp_code, '        return ' . $call_base . ';';
                }

                push @cpp_code, '    }';
                push @cpp_code, '#endif';

                my $call_base = ExtUtils::XSpp::Node::Method->new
                               ( cpp_name       => 'base_' . $method->cpp_name,
                                 perl_name      => $method->perl_name,
                                 arguments      => $method->arguments,
                                 condition      => $method->condition,
                                 emit_condition => $method->condition_expression,
                                 );

                push @call_base, $call_base;
            }
        }

        push @cpp_code, sprintf <<'EOT',
};
%s

EOT
          $self->{virtual_implementation}{$node->cpp_name}{implementation} || '';

        mkdir 'xspp' unless -d 'xspp';
        open my $h_file, '>', $file or die "open '$file': $!";
        print $h_file join "\n", @cpp_code;
        close $h_file;

        ExtUtils::XSpp::Typemap::add_class_default_typemaps( $cpp_class );
        if( $abstract_class ) {
            my $new_class = ExtUtils::XSpp::Node::Class->new
                                ( cpp_name        => $cpp_class,
                                  perl_name       => $perl_class,
                                  base_classes    => [ $node ],
                                  condition       => $node->condition,
                                  emit_condition  => $node->condition_expression,
                                  methods         => [ @new_constructors,
                                                       @call_base ],
                                  );

            push @$nodes, $new_class;
        } else {
            $node->add_methods( @new_constructors );

            if( @call_base ) {
                # make calls to base_* methods available; needs to be a
                # new class object because the generated methods are only
                # available in the generated C++ class
                #
                # does not specify base classes because the base class
                # list is emitted for the class in $node; at some
                # point XS++ should be fixed to detect and remove the
                # duplicate base class list
                my $new_class = ExtUtils::XSpp::Node::Class->new
                                    ( cpp_name        => $cpp_class,
                                      perl_name       => $perl_class,
                                      condition       => $node->condition,
                                      emit_condition  => $node->condition_expression,
                                      methods         => [ @call_base ],
                                      );

                push @$nodes, $new_class;
            }
        }
    }
}

1;
