
package Text::Wigwam::Engine::Fusion::Tokenizer;

    use strict;
    use warnings;
    no warnings 'recursion';
    our $VERSION = '0.01';

    use Text::Wigwam::Engine::Fusion::Token;
    use Text::Wigwam::Engine::Fusion::Core;
    use Text::Wigwam::Engine::Fusion::Stack;
    use Text::Wigwam::Engine::Fusion::Paint::Group;
    use Text::Wigwam::Engine::Fusion::Paint::Sublist;
    use Text::Wigwam::Engine::Fusion::Paint::Token;

    use Text::Wigwam::Const( qw/ANY STRING NUM VAR/ );
    use Text::Wigwam::Engine::Fusion::Const(q/:all/);

sub new {
    my ($class, $Api, $Bugs, $text) = @_;
    my $self = bless {
        TBLOCK => Text::Wigwam::Engine::Fusion::Stack->new(),
        CBLOCK => Text::Wigwam::Engine::Fusion::Stack->new(),
        BUGS   => $Bugs,
        CORE   => Text::Wigwam::Engine::Fusion::Core->new(),
        API => $Api,
        ALIAS => {
            '%' => '#Hash',    # Inherent cast directive
            '@' => '#Array',   # Inherent cast directive
            '*' => '#Any',     # Inherent cast directive
            '$' => '#Scalar',  # Inherent cast directive
            '?' => '#Boolean', # Inherent cast directive
            '{' => '#Do',      # Inherent list directive (code block )
            '(' => '#List',    # Inherent list directive
            '<' => '#Qw',      # Inherent list directive
            '>' => '#/Qw',
            ')' => '#/List',
            '}' => '#/Do',
            %{ $Api->config->cache(q/aliases/) || {} },
        },
        NUMTYPES => {
            NO_HEX => {
                FLOAT   => q/([+-]?(?:\d+[.]?\d*|[.]\d+)(?:[Ee][+-]?\d+)?)\b/,
                REAL    => q/(-?\d+\.?\d*)\b/,
                INTEGER => q/([+-]?\d+)\b/,
                WHOLE   => q/(\d+)\b/,
                OFF     => q//,
            },
            HEX_ON => {
                FLOAT   => q/((?:0x\d+)|(?:[+-]?(?:\d+[.]?\d*|[.]\d+)(?:[Ee][+-]?\d+)?))\b/,
                REAL    => q/((?:0x\d+)|(?:-?\d+\.?\d*))\b/,
                INTEGER => q/((?:0x\d+)|(?:[+-]?\d+))\b/,
                WHOLE   => q/((?:0x)?\d+)\b/,
                OFF     => q/(0x\d+)/,
            }
        },
        LITERAL_META => {
            q/'/ => {
                n => "\n",
                r => "\r",
                t => "\t",
            },
            q/"/ => {
                n => "\n",
                r => "\r",
                t => "\t",
            }
        },
    }, ref($class) || $class;

    @$self{
      qw/
        CodeOpen
        CodeTerm
        TextOpen
        TextTerm
        CodeOpenTrim
        CodeTermTrim
        TextOpenTrim
        TextTermTrim
        STRICT
        NUMERALS
        HEXADECIMAL
      /
    }
    = $Api->get_options(
      qw/
        code_open
        code_term
        text_open
        text_term
        code_open_trim
        code_term_trim
        text_open_trim
        text_term_trim
        strict_tags
        numbers
        hexadecimal
      /
    );
    $self->{CodeOpen} ||= '[!!';
    $self->{CodeTerm} ||= '!!]';
    $self->{TextOpen} ||= '!!>';
    $self->{TextTerm} ||= '<!!';
    $self->{CodeOpenTrim} ||= '[!~';
    $self->{CodeTermTrim} ||= '~!]';
    $self->{TextOpenTrim} ||= '~!>';
    $self->{TextTermTrim} ||= '<!~';
    return $self->init($text);
}

sub core { $_[0]->{CORE} }
sub bugs { $_[0]->{BUGS} }
sub tstack { $_[0]->{TBLOCK} }
sub cstack { $_[0]->{CBLOCK} }

sub init {
    my ($self, $text) = @_;
    return $self->begin_code_mode($text)
      if $self->api->get_options( q/code_mode/ );
    return $self->begin_text_mode($text);
}

sub begin_text_mode {
    my ($self, $text) = @_;
    my $gtoken = $self->add_token(
        Directive => (
            '#Do',
            [], #  [ 'BEGIN_TEMPLATE' ],
            "",
            ROOT_BLOCK | TEXT_BLOCK,
        )
    );
    $self->text_block($text);
     # Add the global terminator token
    $self->add_token( Terminator => Root => [] );
#    $self->add_token( Terminator => Root => [ 'END_TEMPLATE' ] );
    $gtoken->next( $self->core->stack_addr );
    return $self->core;
}

sub begin_code_mode {
    my ($self, $text) = @_;
    my $gtoken = $self->add_token(
        Directive => (
            '#Do',
            [], #  [ 'BEGIN_TEMPLATE' ],
            "",
            ROOT_BLOCK,
        )
    );
    $text =~ s/^\s*//s;
    $self->code_block($text);
     # Add the global terminator token
    $self->add_token( Terminator => Root => [  ] );
#    $self->add_token( Terminator => Root => [ 'END_TEMPLATE' ] );
    $gtoken->next( $self->core->stack_addr );
    return $self->core;
}

sub alias_term {
    my ($self) = @_;
    return $self->{ALIAS_TERM} ||= $self->_alias_term;
}

sub _alias_term {
    my ($self) = @_;
    my (%aterm, %inv_aliases);
    map { $inv_aliases{$self->{ALIAS}{$_}} = $_ } keys %{$self->{ALIAS}};
    for my $token (keys %inv_aliases) {
        next unless my ($dir) = $token =~ m{^#/(.*)$};
        $aterm{$inv_aliases{"#$dir"}} = $inv_aliases{$token}
          or do {
            warn "No aliased terminator defined for #$dir";
            $aterm{$inv_aliases{$token}} = "#/$dir"
        };
    }
    return \%aterm;
}

sub make_token {
    my ($self, @params) = @_;
    Text::Wigwam::Engine::Fusion::Token->new( @params );
}

sub add_token {
    my ($self, @params) = @_;
    return $self->core->add_tokens( $self->make_token(@params) );
}

sub all_tags {
    my ($self) = @_;
    return @$self{
      qw/
        CodeOpen
        CodeTerm
        TextOpen
        TextTerm
        CodeOpenTrim
        CodeTermTrim
        TextOpenTrim
        TextTermTrim
      /
    };
}
sub strict { $_[0]->{STRICT} }
sub api { $_[0]->{API} }
sub _use_hex { return $_[0]->{HEXADECIMAL} ? "HEX_ON" : "NO_HEX" }
sub number_re {
    my ($self) = @_;
    my $numtypes = $self->{NUMTYPES}{$self->_use_hex};
    my $res = $self->{NUMERALS} || 'FLOAT';
    return exists $numtypes->{uc $res} ? $numtypes->{uc $res} : $numtypes->{FLOAT};
}

sub alias { $_[0]->{ALIAS} }
sub alias_re {
    my ($self) = @_;
    my @keys = reverse sort keys %{$self->{ALIAS}};
    my @qm_alias;
    push( @qm_alias, quotemeta $_ ) for @keys;
    return join( '|' => @qm_alias );
}
sub has_term {
    my ($self, $token) = @_;
    return $self->alias_term->{$token};
}
sub parse_literal {
    my ($self, $type, $val) = @_;
    my $lmeta = $self->{LITERAL_META}{$type}
      or return $val;

     # Process escaped characters
    $val =~ s{
        \\(.)
     }{
        exists $lmeta->{$1}
            ? $lmeta->{$1}   # Process valid metacharacter,
            : $1            # or revert to raw character
    }gsex;
#    $val =~ s/(\\[^"\$\@]+)/qq("$1")/eeg; # better? slower? safe?
#    $val = hex($val) if $val =~ /^0x\d+$/;
    return $val;
}

sub text_block {
    my ($self, $text) = @_;
    my (
        $CodeOpenTag,
        $CodeTermTag,
        $TextOpenTag,
        $TextTermTag,
        $CodeOpenTrim,
        $CodeTermTrim,
        $TextOpenTrim,
        $TextTermTrim,
    ) = $self->all_tags;

     # Find the next tag delimiter or text block terminator
    my ($blok, $ante, $post);
    if(
      $text =~ /^
        (.*?)                              # Everything up to...
        ([\r]?[\n]?)                       # a possible new-line...
        ([ \t]*)                           # and-or white-space..
        (                                  # (capture the actual tag)
         (\Q$CodeOpenTrim\E|(\Q$TextTermTrim\E)) | # a trimming tag, or...
         (\Q$TextTermTag\E)|\Q$CodeOpenTag\E       # a conventional tag...
        )
        \s*                                # (ignore trailing w.s.)
        (.*)                               # capture everything beyond
      $/sx
    ){
        my $utag = $4;
        $blok = $6 || $7; # <!! or <!~ text block terminator
        $post = $8;
         # Trim w/s up to & including the first newline, or not.
        $ante = $5 ? $1 : "$1$2$3";

         # If we encounter <!! when there's no preceding !!>,
         # then we translate it to a [!! instead.

        if( $blok && ! $self->tstack->size ){ # any preceding text block tags?
            $blok = 0; # force it to an ltag delimiter
            $self->bugs->warning(
                "Encountered an unexpected text block terminator '$utag'",
                $self->core->stack_addr,
            );
        }
        if( $blok ){
             # Encountered a text block terminator ( i.e. <!! )
             # Add the plain-text preceding the block
             # terminator (unless it's zero chars.)
            $self->add_token(
                Literal => (
                    STRING,
                    $ante,
                    [ $ante ],
                    PTXT
                )
            ) if length $ante;
             # Add a text block terminator token
            $self->add_token( Terminator => Text => [ $utag ] );
            $self->tstack->last_in->next( $self->core->stack_addr ); # Optimize
            $self->tstack->pop;
        }
        else {
             # Encountered a code open delimiter ( i.e. [!! )
             # Add the plain-text preceding the tag delimiter
             # (unless it's zero chars.)
            $self->add_token(
                Literal => (
                    STRING,
                    $ante,
                    [ $ante ],
                    PTXT
                )
            ) if length $ante;
             # Add code block #Do token
            $self->cstack->push(
                $self->add_token(
                    Directive => (
                        '#Do',
                        [ $utag ],
                        $CodeTermTag,
                        CODE_BLOCK,
                    )
                )
            );
        }
        $self->code_block($post);
    }
    else {
        $self->add_token(
            Literal => (
                STRING,
                $text,
                [ $text ],
                PTXT,
            )
        );
    }
    return;
}

sub code_block {
    my ($self, $text) = @_;
    my $alias   = $self->alias;
    my $aliasre = $self->alias_re;
    my $numre   = $self->number_re;
    my (
        $CodeOpenTag,
        $CodeTermTag,
        $TextOpenTag,
        $TextTermTag,
        $CodeOpenTrim,
        $CodeTermTrim,
        $TextOpenTrim,
        $TextTermTrim,
    ) = $self->all_tags;

    while( $text ne '' ){
         # Ignore comments
        $text = $1 if $text
          =~ m{^
               (?:
                 /[*]      # Open comment delimiter:  /*
                 .*?       # Comment text
                 [*]/      # Close comment delimiter: */
                 \s*       # Ignore trailing whitespace
               )+          # One comment or many consecutive comments
               (.*)$  # Capture all after comment
             }xs
        ;

         # Look for potential tag delimiters
        if(
          $text =~ /^
            (                            # $1 captures the tag
                (\Q$TextTermTag\E)       # $2 detects <!!
              | (                        # $3 detects trim tags
                   (\Q$TextTermTrim\E)   # $4 detects <!~
                 | \Q$CodeTermTrim\E     # checks for ~!]
                 | (\Q$TextOpenTrim\E)   # $5 detects ~!>
                )
              | (\Q$TextOpenTag\E)       # $6 detects !!>
              | \Q$CodeTermTag\E         # checks for !!]
            )
            ([ \t]*[\r]?[\n]?)?          # $7 captures whitespace
            (.*)                         # $8 captures all else
          $/sx
        ){
            $text = $3 ? $8 : "$7$8";
            my $rtag = $1;

            if( $5 || $6 ){ # Text block terminator
                 # Add an implied #Do token
                $self->tstack->push(
                    $self->add_token(
                        Directive => (
                            '#Do',
                            [ $rtag ],
                            $TextTermTag,
                            TEXT_BLOCK,
                        )
                    )
                );
            }
            elsif( $2 || $4 ){
             # Encountered '[!! ... <!!',
                $self->bugs->warning(
                   "Encountered an unexpected text block terminator '$rtag'",
                   $self->core->stack_addr + 2,
                );
            }
            elsif( ! $self->cstack->size ){ # Any preceding code blocks?
                $self->bugs->warning(          # Translate ... !!] to !!>
                   "Encountered an unexpected code block terminator '$rtag'",
                   $self->core->stack_addr,
                );
                $self->add_token(
                    Directive => (
                        '#Do',
                        [ $rtag ],
                        $TextTermTag,
                        TEXT_BLOCK,
                    )
                );
            }
            else { # Add a tag terminator token !!]
                $self->add_token( Terminator => Code => [ $rtag ] );
#                $self->cstack->last_in->next( $self->core->stack_addr );
                $self->cstack->pop;
            }
            $self->text_block( $text );
            return;
        }

         # Look for expression terminator (experimental)
        if(
            $text =~ /^
                ([,;])      # Expression terminators
                \s*         # Ignore trailing whitespace
                (.*)$       # Capture remaining text
            /xs
        ){
            $text = $2;
            my $org = $1;
            $self->add_token( Terminator => Expression => [ $org ] );
        }

         # Look for aliased directives
        elsif(
            $text =~ /^
                ($aliasre)    # Match against aliases
                \s*           # Ignore trailing whitespace
                (.*)$         # Capture remaining text
            /sx
        ){
            my $org = $1;
            $text = $2;
            my $tok = $alias->{$org}
              or die "Something's seriously wrong, here";
            if( $tok =~ m{^#/\w+$}s ){      # Aliased terminator token
                $self->add_token(
                    Terminator => Explicit => ( $org, [ $org ] )
                );
            }
            elsif( lc $tok eq '#/*' ){
               $self->add_token(
                    Terminator => Generic => ( [ $org ] )
                );
            }
            else {                              # Aliased directive Token
#                warn "$org has terminator: ". $self->has_term($org)
#                  if $self->has_term($org);
                $self->add_token(
                    Directive => (
                        $tok,
                        [ $org ],
                        $self->has_term($org),
                    )
                );
            }
        }

         # Look for explicit directives
        elsif(
          my ($org, $once, $is_term, $term_id, $tok) = 
            $text =~ m{^
              (
                [#]                     # Token type directive/terminator
                ([|#]?)                 # run once
                (?:
                  (?:
                    (/)?                # $3: Explicit terminator?
                    (?:[\w+\-.:`\[\]]+) # Identifier
                  )
                 |(
                    /\*                 # or generic terminator: #/*
                  )
                )
              )
                \s*(.*)$
            }sx
        ){
            $text = $5;
            my $tok = lc $org;
            $self->core->set_init_addr($self->core->stack_addr)
              if ($once);
            if( $is_term ){
                $self->add_token(
                    Terminator => Explicit => ( $org, [ $org ] )
                );
            }
#            elsif( $tok eq '#/*' ){
            elsif(
                 $term_id
#             || $tok eq '#end'
            ){
                $self->add_token(
                    Terminator => Generic => ( [ $org ] )
                );
            }
            else {
                $self->add_token(
                    Directive => (
                        $tok,
                        [ $org ],
                        undef,
                        0,
                        $once ? 1 : 0,
                    )
                );
            }
        }
         # Object method invocation via variable
        elsif(
            $text =~ /^
              (
                 (?:
                        [0-9a-zA-Z_+\-.:`\[\]] # Allow valid characters
                     |  \\[.:`\[\]]            # and escaped meta chars
                 )+
              )
              ->
              (
                 (?:
                        [0-9a-zA-Z_+\-.:`\[\]] # Allow valid characters
                     |  \\[.:`\[\]]            # and escaped meta chars
                 )+
              )
              \s*(.*)$
            /sx
        ){
            my $obj = $1;
            my $met = $2;
            $text = $3;
            $self->core->add_tokens(
                $self->make_token(
                    Directive => ( '#Invoke', [ $obj.'->'.$met ] )
#                    Directive => ( '#Invoke', [ '#Invoke' ] )
                ),
                $self->make_token(
                    Variable => (
                        $obj,
                        [], #[ $obj ],
                    )
                ),
                $self->make_token(
                    Literal => (
                        STRING,
                        $met,
                        [], #[ $met ],
                        QSTR,
                    )
                )
            );
        }
         # Barewords: Variables, Numeric literals, Hexadecimal
        elsif(
            $text =~ /^
              (
                 (?:
                        [0-9a-zA-Z_+\-.:`\[\]] # Allow valid characters
                     |  \\[.:`\[\]]            # and escaped meta chars
                 )+
              )\s*(.*)$
            /xs
        ){
            my $tok = $1;
            $text = $2;

            if( $numre && $tok =~ /^$numre$/s ){ # Is it a number?
               $self->add_token(
                   Literal => (
                       STRING | NUM,
                       $tok =~ /0x\d+/ ? hex($tok) : $tok,
                       [ $tok ],
                       NUMB,
                    )
                );
            }
            else {                               # Must be a Variable
                if( my $err = $self->api->invalid_var($tok) ){
                    $self->bugs->fatal(
                        "$err: '$tok'",
                        $self->core->stack_addr,
                    );
                }
                $self->add_token( Variable => ( $tok, [ $tok ] ) );
            }
        }

      # Class method invocation via literals (experimental)
        elsif(
            $text =~ /^
                (["'])             # Detect and capture quote char
                (
                  (?:
                    [a-zA-Z0-9]    # Valid class name characters,
                  | ::             # and namespace delimiters only
                  )*?
                )
                \1                 # Match against captured quote char
                ->
                (
                  (?:
                        [0-9a-zA-Z_+\-.:`\[\]] # Allow valid characters...
                     |  \\[.:`\[\]]            # and escaped meta chars
                  )+
                )
                \s*             # Ignore trailing white space
                (.*)$           # Capture remaining text
            /xs
        ){
            my ($quot, $lit, $val, $met) = ( $1, $2, $2, $3 );
            $text = $4;
            $self->core->add_tokens(
                $self->make_token(
                    Directive => ( '#InvokeClass', [ "$quot$lit$quot".'->'.$met ] )
            ##        Directive => ( '#InvokeClass', [ '#InvokeClass' ] )
                ),
                $self->make_token(
                    Literal => (
                        STRING,
                        $val,
                        [], #[ $lit ],
                        QSTR,
                    )
                ),
                $self->make_token(
                    Literal => (
                        STRING,
                        $met,
                        [], #[ $met ],
                        QSTR,
                    )
                )
            );
        }

         # Look for a quoted literal
        elsif(
            $text =~ /^
                (["'])          # Detect and capture quote type
                (
                    (?:
                        [^\1\\] # Match all but our quote char...
                      | \\.     # unless it's escaped
                    )*?
                )
                \1              # Match against captured quote char
                \s*             # Ignore trailing whitespace
                (.*)$           # Capture remaining text
            /xs
        ){
            my ($quot, $lit, $val) = ( $1, $2, $2 );
            $text = $3;

            $val = $self->parse_literal($quot, $val);

            $self->add_token(
              Literal => $self->api->is_num($val) ?                        
                (
                  NUM | STRING,
                  $val,
                  [ "$quot$lit$quot" ],
                  QSTR | NUMB
                )
              :
                (
                  STRING,
                  $val,
                  [ "$quot$lit$quot" ],
                  QSTR
                )
            );
        }

         # If we've gotten this far, something's awry in the template
        else{
            $text =~ /^([^\s]+)\s*(.*)/s;
            $text = $2;
            $self->bugs->fatal(
                "Encountered an unrecognized token, '$1'",
                $self->core->stack_addr,
            );
        }
    }
    return;
}

1;
