package SMOP::RI::Writer;
use warnings;
use v5.10;
use strict;
use List::MoreUtils qw(uniq);
use Mildew::Frontend::M0ld;
use Mildew::Backend::OptC;

sub mangle {
    my @list = @_;
    for (@list) {
	s/\`/Grave/g;
	s/\~/Tilde/g;
	s/\!/Bang/g;
	s/\@/At/g;
	s/\#/Sharp/g;
	s/\$/Dollar/g;
	s/\%/Percent/g;
	s/\^/Caret/g;
	s/\&/Amp/g;
	s/\*/Star/g;
	s/\(/Paren/g;
	s/\)/Thesis/g;
	s/\-/Minus/g;
	s/\+/Plus/g;
	s/\=/Equal/g;
	s/\{/Cur/g;
	s/\}/Ly/g;
	s/\[/Bra/g;
	s/\]/Ket/g;
	s/\|/Vert/g;
	s/\\/Back/g;
	s/\:/Colon/g;
	s/\;/Semi/g;
	s/\'/Single/g;
	s/\"/Double/g;
	s/\</Lt/g;
	s/\>/Gt/g;
	s/\«/Fre/g;
	s/\»/Nch/g;
	s/\,/Comma/g;
	s/\./Dot/g;
	s/\?/Question/g;
	s/\//Slash/g;
	s/([^a-zA-Z_0-9])/sprintf("_%02x_",ord($1))/eg;
    }
    'SMOP__ID__' . (join '_', @list);
}

sub process_ri {
    my ($ri_file,$c_file) = @_;
    open(my $from,"<:encoding(UTF-8)",$ri_file);
    open(my $to,">:encoding(UTF-8)",$c_file);

    my @properties = qw(RI RI.id prefix include prototype singleton nagc.nofree prefix struct lowlevel);
    my %properties;
    
    my %methods;
    my $method;
    
    my %mold;
    my $mold;
    
    my %yeast;
    my $yeast;
    
    my @attrs;
    my @getters;
    my @getsetattr;
    
    my @idconsts;
    
    my @has;
    
    my %raw;
    
    
    sub debug {
    }
    while (my $line = <$from>) {
        if ($line =~ /^\%\s*(\w*)\s*\{\s*$/) {
             debug "raw.$1 start\n";
             $raw{$1} = '';
             until((my $raw_line = <$from>) =~ /^\%}\s*$/) {
                 debug "raw $raw_line";
                 $raw{$1} .= $raw_line;
             }
             debug "raw.R1 stop\n";
        } elsif ($method) {
            if ($line =~ /^%/) {
                undef $method;
                redo;
            } else {
                debug "in method $line";
                $methods{$method} .= $line;
                next;
            }
        } elsif ($mold) {
            if ($line =~ /^%/) {
                undef $mold;
                redo;
            } else {
                debug "in mold $line";
                $mold{$mold} .= $line;
                next;
            }
        } elsif ($yeast) {
            if ($line =~ /^%/) {
                undef $yeast;
                redo;
            } else {
                debug "in yeast $line";
                $yeast{$yeast} .= $line;
                next;
            }
        } elsif ($line =~ /^%method \s* (.*?) (?: \( ([^(]*) \) )?$/x) {
            $method = $1;
            my $sig = $2;
            $methods{$method} = '';
            if ($sig) {
                my (@params) = split(/,/,$sig);
                my $i = 1;
                for my $param (@params) {
                    $methods{$method} .= "  SMOP__Object* $param = SMOP__NATIVE__capture_positional(interpreter, capture, $i);\n";
                    $i++;
                }
            }
            debug "method start:$method\n";
        } elsif ($line =~ /^%mold\s*(.*)$/) {
            $mold = $1;
            debug "mold start:$mold\n";
        } elsif ($line =~ /^%yeast\s*(.*)$/) {
            $yeast = $1;
            debug "mold start:$yeast\n";
        } elsif ($line =~ /^%attr\s*(.*)\n$/) {
            push(@attrs,$1);
        } elsif ($line =~ /^%idconst\s*(.*)\n$/) {
            push(@idconsts,$1);
        } elsif ($line =~ /^%getter\s*(\S+)$/) {
            push(@getters,$1);
        } elsif ($line =~ /^%getset\s*(\S+)$/) {
            push(@getsetattr,$1);
        } elsif ($line =~ / ^\s*$ | ^\# | ^\/\/ /x) {
            debug "ws/comment:$line";
        } elsif ($line =~ /^%has\s*(\$|\@|\%)(\S+)(?:\s*=(.+))?\n$/) {
            my $sigil = $1;
            my $name = $2;
            my $initial = $3;
            my $id = $name;
            $id =~ s/^\^\!/CaretBang/;
            push @attrs, 'SMOP__Object* '.$id;
            push @has, [$sigil, $id,$initial];
            push(@idconsts,$name);
        } else {
            for my $property (@properties) {
                if ($line =~ /^% \s* \Q$property\E \s+ (.*)$/x) {
                    $properties{$property} = $1;
                    debug "prop $property = $1\n";
                    goto FOUND;
                }
            }
            die "unrecognised line: $line";
            FOUND: ;
        } 
    }
    
    die "a %prefix is required\n" unless $properties{prefix};
    
    my $struct = $properties{struct} // $properties{prefix} . '_struct';
    
    print $to qq[/* generated by tools/ri - do not edit*/
    #include <smop/base.h>
    #include <smop/nagc.h>
    #include <smop/mold.h>
    #include <smop/yeast.h>
    #include <smop/s0native.h>
    #include <smop/util.h>
    #include <stdlib.h>
    #include <stdio.h>
    
    static void DESTROYALL(SMOP__Object* interpreter,
                                  SMOP__Object* invocant);
    ];
    unless (defined $properties{lowlevel}) {
        print $to "#include <smop/capture.h>\n";
        print $to "#include <smop/native.h>\n";
    }
    if ($properties{prototype}) {
        print $to "#include <smop/s1p.h>\n";
    }
    for (split (/,/,$properties{include} || '')) {
        print $to "#include $_\n";
    }
    
    my $id = defined $properties{"RI.id"} ? $properties{"RI.id"} : "unknown RI";
    
    if ($properties{prototype}) {
        print $to "SMOP__Object* $properties{prototype};\n";
    }
    if ($properties{singleton}) {
        print $to "SMOP__Object* $properties{singleton};\n";
    }
    if ($properties{RI}) {
        print $to "SMOP__Object* $properties{RI};\n";
    } else {
        print $to "static SMOP__Object* RI;\n";
    }
    my $RI = $properties{RI} || 'RI';
    for my $getter (@getters) {
        $methods{$getter} = qq[    smop_nagc_rdlock((SMOP__NAGC__Object*)invocant);
        ret = (($struct*)invocant)->$getter;
        smop_nagc_unlock((SMOP__NAGC__Object*)invocant);
        SMOP_REFERENCE(interpreter, ret);
    ];
    }
    
    for my $attr (@getsetattr) {
        $methods{$attr} = "if ((($struct*)invocant)->$attr) ret = SMOP_REFERENCE(interpreter,(($struct*)invocant)->$attr);\n";
        $methods{'set_' . $attr} = qq[
        SMOP__Object* value = SMOP__NATIVE__capture_positional(interpreter, capture, 1);
        if (!(($struct*)invocant)->$attr) {
         (($struct*)invocant)->$attr = value;
        } else {
          printf("trying to set a new $attr\\n");
          abort();
        }
        ];
    }
    @idconsts = uniq(keys %methods,@idconsts);
    
    for (@idconsts) {
        print $to 'static SMOP__Object* ',mangle($_),";\n";
    }
    
    for (keys %mold) {
        print $to 'static SMOP__Object* ',$_,";\n";
    }
    for (keys %yeast) {
        print $to 'static SMOP__Object* ',$_,";\n";
    }
    unless ($properties{struct}) {
        print $to qq[
    typedef struct $properties{prefix}_struct {
      SMOP__NAGC__Object__BASE
    ];
        for my $attr (@attrs) {
            print $to "$attr;\n";
        }
        print $to "} $properties{prefix}_struct;\n";
    }
    
    print $to $raw{''} || '';
    
    
    
    
    for my $has (@has) {
        my $sigil = $has->[0];
        my $name = $has->[1];
        my $initializer;
        if ($has->[2]) {
            $initializer = $has->[2];
        } elsif ($sigil eq '$') {
          $initializer = 'SMOP__S1P__Scalar_create(interpreter, SMOP__NATIVE__bool_false)';
        } elsif ($sigil eq '@') {
          $initializer = 'SMOP__S1P__Array_create(interpreter)';
        } elsif ($sigil eq '%') {
          $initializer = 'SMOP__S1P__Hash_create(interpreter)';
        } else {
          die 'unknown sigil in %has';
        }
        $methods{$name} = qq[
        smop_nagc_rdlock((SMOP__NAGC__Object*)invocant);
        SMOP__Object** pointer = &((($struct*)invocant)->$name);
        smop_nagc_unlock((SMOP__NAGC__Object*)invocant);
        if (!*pointer) {
           smop_nagc_wrlock((SMOP__NAGC__Object*)invocant);
           *pointer = $initializer;
           smop_nagc_unlock((SMOP__NAGC__Object*)invocant);
        }
        ret = *pointer;
        SMOP_REFERENCE(interpreter, ret);
    ];
    }
    
    print $to q[
    static SMOP__Object* message(SMOP__Object* interpreter,
                                         SMOP__ResponderInterface* self,
                                         SMOP__Object* identifier,
                                         SMOP__Object* capture) {
    ];
    my $in_msg = $raw{inmessage} || '';
    my $pre_msg = $raw{premessage} || '';
    my $message = $raw{message} || q[
      /*___NATIVE_CAPTURE_ONLY___;
      ___CONST_IDENTIFIER_ONLY___;*/
      SMOP__Object* invocant = (SMOP__Object*) SMOP__NATIVE__capture_positional(interpreter, capture,0);
      SMOP__Object* ret = SMOP__NATIVE__bool_false;
      %%PREMESSAGE%%
      %%METHODS%%
      %%INMESSAGE%%
      {
        ___UNKNOWN_METHOD___;
      }
      if (invocant) SMOP_RELEASE(interpreter,invocant);
      SMOP_RELEASE(interpreter,capture);
      return ret;
    ];
    my $methods = '';
    while (my ($method,$body) = each %methods) {
        $methods .= "if (" . mangle($method) . " == identifier) {\n$body  } else ";
    }
    $message =~ s/%%PREMESSAGE%%/$pre_msg/g;
    $message =~ s/%%METHODS%%/$methods/g;
    $message =~ s/%%INMESSAGE%%/$in_msg/g;
    print $to $message;
    print $to q[
    }
    ];
    
    my $destroyall = $raw{'DESTROYALL_ALL'} // '
    static void DESTROYALL(SMOP__Object* interpreter,
                           SMOP__Object* invocant) {
        %%INDESTROYALL%%
        %%ATTRS%%
        %%FREE%%
    }
    ';
    if ($raw{'DUMP'}) {
        print $to '
    static SMOP__Object* DUMP(SMOP__Object* interpreter,
                              SMOP__ResponderInterface* responder,
                              SMOP__Object* obj) {
';
        print $to $raw{'DUMP'};
        print $to '   }';
    }
    
    my $attrs = '';
    if (@has) {
      $attrs .= qq[
      smop_nagc_wrlock((SMOP__NAGC__Object*)invocant);
      ];
      for my $has (@has) {
        my $name = $has->[1];
        $attrs .= qq[
      SMOP__Object* p_$name = ((($struct*)invocant)->$name);
      ((($struct*)invocant)->$name) = NULL;
        ];
      }
      $attrs .= qq[
      smop_nagc_unlock((SMOP__NAGC__Object*)invocant);
      ];
      for my $has (@has) {
        my $name = $has->[1];
        $attrs .= qq[
      if (p_$name) SMOP_RELEASE(interpreter, p_$name);
        ];
      }
    }
    
    $destroyall =~ s/%%INDESTROYALL%%/$raw{'DESTROYALL'} || ''/eg;
    $destroyall =~ s/%%ATTRS%%/$attrs/g;
    
    if ($properties{'nagc.nofree'}) {
        $destroyall =~ s/%%FREE%%/smop_nagc_free(invocant);/g;
    } else {
        $destroyall =~ s/%%FREE%%//g;
    }
    
    print $to $destroyall;
    
    
    my $release = $properties{'nagc.nofree'} ? 'smop_nagc_release_nofree' : 'smop_nagc_release';
    
    my %yeasts_processed;
    my $frontend = Mildew::Frontend::M0ld->new();
    my $backend = Mildew::Backend::OptC->new();
    while (my ($name,$m0ld) = each %yeast) {
        $yeasts_processed{$name} = [$backend->yeast($frontend->parse($m0ld))];
    }
    while (my ($name,$yeast) = each %yeasts_processed) {
        print $to $yeast->[0];
    }
    
    my $DUMP = "smop_nagc_dump";
    if ($raw{'DUMP'}) {
        $DUMP = "DUMP";
    }
    print $to qq[
    void $properties{prefix}_init(SMOP__Object* interpreter) {
      $RI = SMOP__NAGC__RI__create(
        message,
        smop_nagc_reference,
        $release,
        smop_nagc_weakref,
        $DUMP,
        DESTROYALL,
        "$id");
    ];
    
    for (@idconsts) {
        print $to "  ",mangle($_)," = ","SMOP__NATIVE__idconst_create(\"$_\");\n";
    }
    
    if ($properties{prototype}) {
        print $to qq[
      $properties{prototype} = SMOP__Proto__create($RI);
    ];
    }
    
    print $to $raw{'init'} || '';
    
    while (my ($name,$mold) = each %mold) {
        print $to "  $name = ",preprocess_m0ld($mold),";\n";
    }
    
    while (my ($name,$yeast) = each %yeasts_processed) {
        print $to "  ",$yeast->[2],"\n";
        print $to "  $name = ",$yeast->[1],";\n";
    }
    
    print $to $raw{'init_post_mold'} || '';
    
    print $to "}\n";
    
    print $to qq[ 
    void $properties{prefix}_destr(SMOP__Object* interpreter) {
    ];
    while (my ($name,$mold) = each %mold) {
        print $to "SMOP_RELEASE(interpreter,$name);\n";
    }
    if ($properties{prototype}) {
        print $to qq[
         SMOP_RELEASE(interpreter,$properties{prototype});
        ];
    }
    
    print $to $raw{'destr'} || '';
    print $to qq[
      free($RI);
    }
    ];
    print $to $raw{'bottom'} || '';
}
1;