File Coverage

blib/lib/English/Script.pm

Criterion	Covered	Total	%
statement	207	208	99.5
branch	93	114	81.5
condition	19	36	52.7
subroutine	32	32	100.0
pod	8	8	100.0
total	359	398	90.2

package English::Script {
    # ABSTRACT: Parse English subset and convert to data or code

    use 5.014;
    use exact;

    use Parse::RecDescent;
    use YAML::XS 'Dump';

    our $VERSION = '1.04'; # VERSION

    sub new {
        my $self = shift;
        $self = ( ref $self ) ? bless( { %$self, @_ }, ref $self ) : bless( {@_}, $self );

        $self->{grammar} //= q#
            content :
                ( comment | sentence )(s) /^\Z/
                { +{ $item[0] => $item[1] } }
                |

            comment :
                /\([^\(\)]*\)/
                {
                    $item[1] =~ /\(([^\)]+)\)/;
                    +{ $item[0] => ( $1 || '' ) };
                }
                |

            sentence :
                command /[\.;]\s/
                { pop @item; +{@item} }
                |

            command :
                (
                    say | set | append | add | subtract | multiply | divide |
                    otherwise_if | if | otherwise | for
                )
                { +{@item} }
                |

            say : /\bsay\b/ ( list | expression )
                { +{ $item[0] => $item[2] } }
                |

            set : /\bset\b/ object '=' ( list | expression )
                { +{ $item[0] => [ $item[2], $item[4] ] } }
                |

            append : /\bappend\b/ ( list | expression ) '=' object
                { +{ $item[0] => [ $item[2], $item[4] ] } }
                |

            add : /\badd\b/ expression '=' object
                { +{ $item[0] => [ $item[2], $item[4] ] } }
                |

            subtract : /\bsubtract\b/ expression '`' object
                { +{ $item[0] => [ $item[2], $item[4] ] } }
                |

            multiply : /\bmultiply\b/ object '~' expression
                { +{ $item[0] => [ $item[2], $item[4] ] } }
                |

            divide : /\bdivide\b/ object '~' expression
                { +{ $item[0] => [ $item[2], $item[4] ] } }
                |

            otherwise_if : /\botherwise,\s*if\b/ expression '::' ( block | command )
                { +{ $item[0] => { %{ $item[2] }, %{ $item[4] } } } }
                |

            if : /\bif\b/ expression '::' ( block | command )
                { +{ $item[0] => { %{ $item[2] }, %{ $item[4] } } } }
                |

            otherwise : /\botherwise\b,?/ ( block | command )
                { +{ $item[0] => $item[2] } }
                |

            for : /\bfor(?:\s+each)?\b/ object '=^' object block
                {
                    +{
                        $item[0] => {
                            item => $item[2],
                            list => $item[4],
                            %{ $item[5] },
                        }
                    };
                }
                |

            block : '{{{' ( comment | sentence )(s?) '}}}'
                { +{ $item[0] => $item[2] } }
                |

            list :
                object ( list_item_seperator object )(s)
                { +{ shift @item => [ shift @item, @{ $item[0] } ] } }
                |

            list_item_seperator : /,\s*(&&\s+)?/
                |

            expression:
                object sub_expression(s?)
                { +{ $item[0] => [ $item[1], map { @$_ } @{ $item[2] } ] } }
                |

            sub_expression:
                operator object
                { [ $item[1], $item[2] ] }
                |

            operator :
                (
                    '+' | '-' | '/' | '*' |
                    '>=' | '>' | '<=' | '<' | '!@=' | '@=' | '!=' | '==' | '!^=' | '^=' |
                    '&&' | '||'
                )
                {
                    $item[1] =
                        ( $item[1] eq '!@=' ) ? 'not in'     :
                        ( $item[1] eq '@='  ) ? 'in'         :
                        ( $item[1] eq '!^=' ) ? 'not begins' :
                        ( $item[1] eq '^='  ) ? 'begins'     : $item[1];
                    +{@item};
                }
                |

            object : call(s?) ( string | number | word | '=+' | '=-' )(s)
                {
                    pop @{ $item[2] } while (
                        @{ $item[2] } > 1 and
                        $item[2][-1]{word} =~ /^(?:value|string|text|number|list|array)$/
                    );

                    for ( @{ $item[2] } ) {
                        if ( $_ eq '=+' ) {
                           $_ = { boolean => 'true' };
                        }
                        elsif ( $_ eq '=-' ) {
                           $_ = { boolean => 'false' };
                        }
                    }

                    my $data            = {};
                    $data->{calls}      = $item[1] if ( @{$item[1]} );
                    $data->{components} = $item[2] if ( @{$item[2]} );

                    +{ $item[0] => $data };
                }
                |

            call :
                ( '~=' | '$=' | /\[\d+\]/ )
                {
                    $item[1] =
                        ( $item[1] =~ /\[(\d+)\]/ ) ? { 'item' => $1 } :
                        ( $item[1] eq '~='        ) ? 'length'         :
                        ( $item[1] eq '$='        ) ? 'shift'          : $item[1];
                    +{@item};
                }
                |

            string :
                /"[^"]*"/
                {
                    $item[1] =~ /"([^"]*)"/;
                    +{ $item[0] => $1 };
                }
                |

            number :
                /\-?(?:\d+,)*(?:\d+\.)*\d+\b/
                {
                    $item[1] =~ s/[^\d\.\-]//g;
                    +{@item};
                }
                |

            word :
                /\w+(?:'s)?\b/
                { +{@item} }
                |
        #;

        $self->renderer( $self->{renderer} // 'JavaScript', $self->{render_args} );

        return $self;
    }

    sub grammar {
        my ( $self, $grammar ) = @_;
        $self->{grammar} = $grammar if ($grammar);
        return $self->{grammar};
    }

    sub append_grammar {
        my ( $self, $grammar ) = @_;
        $self->{grammar} .= "\n" . $grammar if ($grammar);
        return $self;
    }

    sub _instantiate_renderer {
        my ( $self, $renderer, $render_args ) = @_;

        my $class = __PACKAGE__ . "::$renderer";
        eval "require $class";

        return $class->new( $render_args || {} );
    }

    sub renderer {
        my ( $self, $renderer, $render_args ) = @_;
        $self->{render_args} = $render_args;

        if (
            $renderer and (
                not $self->{renderer_obj} or
                $self->{renderer} and $renderer ne $self->{renderer}
            )
        ) {
            my $class = __PACKAGE__ . "::$renderer";
            eval "require $class";

            $self->{renderer}     = $renderer;
            $self->{renderer_obj} = $self->_instantiate_renderer( $self->{renderer}, $self->{render_args} );
        }

        return $self->{renderer};
    }

    sub _prepare_input {
        my ( $self, $input ) = @_;

        my $bits;

        $input =~ s/\(([^\)]+)\)/
            push( @{ $bits->{comments} }, $1 );
            '(' . scalar @{ $bits->{comments} } - 1 . ')';
        /ge;

        $input =~ s/"([^"]+)"/
            push( @{ $bits->{strings} }, $1 );
            '"' . scalar @{ $bits->{strings} } - 1 . '"';
        /ge;

        $input = lc $input;
        $input =~ s/\b(?:a|an|the|value\s+of|list\s+of|there\s+are|there\s+is)\b//g;

        for (
            # call
            [ 'length of'         => '~=' ],
            [ 'removed item from' => '$=' ],

            # operator
            [ 'plus'                        => '+'   ],
            [ 'minus'                       => '-'   ],
            [ 'divided by'                  => '/'   ],
            [ 'times'                       => '*'   ],
            [ 'is greater than or equal to' => '>='  ],
            [ 'is greater than'             => '>'   ],
            [ 'is less than or equal to'    => '<='  ],
            [ 'is less than'                => '<'   ],
            [ 'is not in'                   => '!@=' ],
            [ 'is in'                       => '@='  ],
            [ 'is not'                      => '!='  ],
            [ 'is'                          => '=='  ],
            [ 'does not begin with'         => '!^=' ],
            [ 'begins with'                 => '^='  ],

            # assignment
            [ 'to'   => '=' ],
            [ 'from' => '`' ],
            [ 'by'   => '~' ],

            # logical
            [ 'and' => '&&' ],
            [ 'or'  => '||' ],

            # value
            [ 'true'  => '=+' ],
            [ 'false' => '=-' ],

            # in
            [ 'in' => '=^' ],
        ) {
            $_->[0]  =~ s/\s/\\s+/g;
            $input =~ s/\b($_->[0])\b/$_->[1]/g;
        }

        $input =~ s/(?:,\s*)?\bthen\b/ ::/g;
        $input =~ s/(?:,\s*)?\bapply\b[\w\s]+\bblock\b\s*\./ {{{ /g;
        $input =~ s/[^\.\)]+\bend[\w\s]+\bblock\b/ }}} /g;

        $input =~ s/\bitem\s*([\d,\.]+)(?:\s*of)?/\[$1\]/g;
        $input =~ s/\((\d+)\)/'(' . $bits->{comments}[$1] . ')'/ge;
        $input =~ s/"(\d+)"/'"' . $bits->{strings}[$1] . '"'/ge;

        return $input . "\n";
    }

    sub _parse_prepared_input {
        my ( $self, $prepared_input ) = @_;

        my ( $stderr, $parse_tree );
        {
            local *STDERR;
            open( STDERR, '>', \$stderr );

            local $::RD_ERRORS = 1;
            local $::RD_WARN   = 1;

            $parse_tree = Parse::RecDescent->new( $self->{grammar} )->content($prepared_input);
        }
        if ($stderr) {
            $stderr =~ s/\r?\n[ ]{23}/ /g;
            $stderr =~ s/(?:\r?\n){2,}/\n/g;
            $stderr =~ s/^\s+//mg;

            my @errors = map {
                /^\s*(?\w+)(?:\s+\(line\s+(?\d+)\))?:\s+(?.+)/s;
                my $error = {%+};
                $error->{type} = ucfirst lc $error->{type};
                $error;
            } split( /\n/, $stderr );

            return { errors => \@errors };
        }
        else {
            return $parse_tree;
        }
    }

    sub parse {
        my ( $self, $input ) = @_;
        $self->{data} = $self->_parse_prepared_input( $self->_prepare_input($input) );
        croak('Failed to parse input') if ( exists $self->{data}{errors} );
        return $self;
    }

    sub data {
        my ($self) = @_;
        return $self->{data};
    }

    sub yaml {
        my ($self) = @_;
        return Dump( $self->{data} );
    }

    sub render {
        my ( $self, $renderer, $render_args ) = @_;

        my $renderer_obj = ( $renderer or $render_args )
            ? $self->_instantiate_renderer(
                $renderer    // $self->{renderer},
                $render_args // $self->{render_args},
            )
            : $self->{renderer_obj};

        return $renderer_obj->render( $self->{data} );
    }
}

package English::Script::JavaScript {
    use 5.014;
    use exact;
    use JavaScript::Packer;

    our $VERSION = '1.04'; # VERSION

    sub new {
        my ( $self, $args ) = @_;
        return bless( { args => $args }, $self );
    }

    sub render {
        my ( $self, $data ) = @_;
        $self->{objects} = {};
        my $js = $self->content($data);

        return ( ref $self->{args} eq 'HASH' and %{ $self->{args} } )
            ? JavaScript::Packer->init->minify( \$js, $self->{args} )
            : $js;
    }

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

        my $text = join( '',
            map {
                ( exists $_->{comment}  ) ? $self->comment( $_->{comment}   ) :
                ( exists $_->{sentence} ) ? $self->sentence( $_->{sentence} ) : ''
            } @{ $content->{content} }
        );

        return join( "\n", (
            map {
                'if ( typeof( ' . $_ . ' ) == "undefined" ) ' . ( (/\./) ? '' : 'var ' ) . $_ .
                    ( ( $self->{objects}{$_} ) ? ' = ' . $self->{objects}{$_} : ' = ""' ) . ';'
            } sort keys %{ $self->{objects} }
        ), $text );
    }

    sub comment {
        my ( $self, $comment ) = @_;
        ( my $text = $_->{comment} ) =~ s|^|// |mg;
        return $text . "\n";
    }

    sub sentence {
        my ( $self, $sentence ) = @_;
        return $self->command( $sentence->{command} );
    }

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

        my ($command_name) = keys %$command;
        my $tree           = $command->{$command_name};

        if ( $command_name eq 'say' ) {
            return join( ' ',
                'console.log(', (
                    ( exists $tree->{list} )       ? $self->list( $tree->{list}             ) :
                    ( exists $tree->{expression} ) ? $self->expression( $tree->{expression} ) : 'undefined'
                ), ')',
            ) . ";\n";
        }
        elsif ( $command_name eq 'set' ) {
            my $object = $self->object( $tree->[0]{object} );
            $self->{objects}{$object} = '[]' if ( exists $tree->[1]{list} );

            return join( ' ',
                $object, '=', (
                    ( exists $tree->[1]{expression} )
                        ? $self->expression( $tree->[1]{expression} ) :
                    ( exists $tree->[1]{list} )
                        ? '[ ' . $self->list( $tree->[1]{list} ) . ' ]' : 'undefined'
                )
            ) . ";\n";
        }
        elsif ( $command_name eq 'append' ) {
            my $object_core   = $self->object_core( $tree->[1]{object} );
            my $object        = $self->object_calls( $tree->[1]{object}, $object_core );
            my $obj_is_a_list = ( $self->{objects}{$object} and $self->{objects}{$object} eq '[]' ) ? 1 : 0;
            my @predicate     =
                ( exists $tree->[0]{list}       ) ? $self->list( $tree->[0]{list} )             :
                ( exists $tree->[0]{expression} ) ? $self->expression( $tree->[0]{expression} ) : '';

            return join( ' ', (
                ($obj_is_a_list)
                    ? ( $object . '.push(', @predicate, ')' )
                    : ( $object, '+=', @predicate )
            ) ) . ";\n";
        }
        elsif ( $command_name eq 'add' ) {
            return join( ' ',
                $self->object( $tree->[1]{object} ), '+=', $self->expression( $tree->[0]{expression} ),
            ) . ";\n";
        }
        elsif ( $command_name eq 'subtract' ) {
            return join( ' ',
                $self->object( $tree->[1]{object} ), '-=', $self->expression( $tree->[0]{expression} ),
            ) . ";\n";
        }
        elsif ( $command_name eq 'multiply' ) {
            return join( ' ',
                $self->object( $tree->[0]{object} ), '*=', $self->expression( $tree->[1]{expression} ),
            ) . ";\n";
        }
        elsif ( $command_name eq 'divide' ) {
            return join( ' ',
                $self->object( $tree->[0]{object} ), '/=', $self->expression( $tree->[1]{expression} ),
            ) . ";\n";
        }
        elsif ( $command_name eq 'otherwise_if' ) {
            return 'else if ( ' .
                join( ' ', $self->expression( $tree->{expression} ) ) . " ) {\n" . join( ' ', (
                    ( exists $tree->{command} ) ? $self->command( $tree->{command} ) :
                    ( exists $tree->{block}   ) ? $self->block( $tree->{block}     ) : ''
                ) ) . "}\n";
        }
        elsif ( $command_name eq 'if' ) {
            return 'if ( ' .
                join( ' ', $self->expression( $tree->{expression} ) ) . " ) {\n" . join( ' ', (
                    ( exists $tree->{command} ) ? $self->command( $tree->{command} ) :
                    ( exists $tree->{block}   ) ? $self->block( $tree->{block}     ) : ''
                ) ) . "}\n";
        }
        elsif ( $command_name eq 'otherwise' ) {
            return "else {\n" . join( ' ', (
                ( exists $tree->{command} ) ? $self->command( $tree->{command} ) :
                ( exists $tree->{block}   ) ? $self->block( $tree->{block}     ) : ''
            ) ) . "}\n";
        }
        elsif ( $command_name eq 'for' ) {
            my $item = $self->object( $tree->{item}{object} );
            my $list = $self->object( $tree->{list}{object} );

            return 'for ( ' . $item . ' of ' . $list . " ) {\n" . join( ' ', (
                $self->block( $tree->{block} )
            ) ) . "}\n";
        }

        return '';
    }

    sub block {
        my ( $self, $block ) = @_;
        return join( '',
            map {
                ( exists $_->{comment}  ) ? $self->comment( $_->{comment}   ) :
                ( exists $_->{sentence} ) ? $self->sentence( $_->{sentence} ) : ''
            } @$block
        );
    }

    sub list {
        my ( $self, $list ) = @_;
        return join( ', ', map { $self->object( $_->{object} ) } @$list );
    }

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

        my @parts = map {
            ( exists ( $_->{object} ) ) ? +{ object => $self->object( $_->{object} ) } : +{%$_};
        } @$expression;

        for ( my $i = 0; $i < @parts; $i++ ) {
            if ( exists $parts[$i]{operator} ) {
                if ( $parts[$i]{operator} eq 'in' ) {
                    $parts[ $i - 1 ]{object} =
                        $parts[ $i + 1 ]{object} . '.indexOf( ' . $parts[ $i - 1 ]{object} . ' )';
                    $parts[$i]{operator}     = '>';
                    $parts[ $i + 1 ]{object} = -1;
                }
                elsif ( $parts[$i]{operator} eq 'not in' ) {
                    $parts[ $i - 1 ]{object} =
                        $parts[ $i + 1 ]{object} . '.indexOf( ' . $parts[ $i - 1 ]{object} . ' )';
                    $parts[$i]{operator}     = '==';
                    $parts[ $i + 1 ]{object} = -1;
                }
                elsif ( $parts[$i]{operator} eq 'begins' ) {
                    $parts[ $i - 1 ]{object} =
                        $parts[ $i - 1 ]{object} . '.indexOf( ' . $parts[ $i + 1 ]{object} . ' )';
                    $parts[$i]{operator}     = '==';
                    $parts[ $i + 1 ]{object} = 0;
                }
                elsif ( $parts[$i]{operator} eq 'not begins' ) {
                    $parts[ $i - 1 ]{object} =
                        $parts[ $i - 1 ]{object} . '.indexOf( ' . $parts[ $i + 1 ]{object} . ' )';
                    $parts[$i]{operator}     = '!=';
                    $parts[ $i + 1 ]{object} = 0;
                }
            }
        }

        return map { ( exists $_->{object} ) ? $_->{object} : $_->{operator} } @parts;
    }

    sub object {
        my ( $self, $object ) = @_;
        return $self->object_calls( $object, $self->object_core($object) );
    }

    sub object_core {
        my ( $self, $object ) = @_;

        my $text = '';
        if ( exists $object->{components} ) {
            if ( $object->{components}[0]{boolean} ) {
                $text .= join( ' ', map { values %$_ } @{ $object->{components} } );
            }
            elsif ( not $object->{components}[0]{string} ) {
                my $contains_non_number = grep { not exists $_->{number} } @{ $object->{components} };
                $object->{components}[0] = { word => '_' . $object->{components}[0]{number} }
                    if ( $contains_non_number and exists $object->{components}[0]{number} );

                my @parts = map { values %$_ } @{ $object->{components} };
                $text .= join( '.', @parts );

                if ($contains_non_number) {
                    for ( my $i = 0; $i < @parts; $i++ ) {
                        $self->{objects}{
                            join( '.', @parts[ 0 .. $i ] )
                        } //= ( $i == @parts - 1 ) ? '' : '{}';
                    }
                }
            }
            else {
                $text .= '"' . join( '', map { values %$_ } @{ $object->{components} } ) . '"';
            }
        }

        return $text;
    }

    sub object_calls {
        my ( $self, $object, $text ) = @_;

        my $object_text = $text;
        if ( exists $object->{calls} ) {
            for my $call ( reverse map { values %$_ } @{ $object->{calls} } ) {
                if ( $call eq 'length' ) {
                    $text .= '.length';
                }
                elsif ( $call eq 'shift' ) {
                    $text .= '.shift';
                    $self->{objects}{$object_text} = '[]';
                }
                elsif ( ref $call eq 'HASH' and exists $call->{item} ) {
                    $text .= '[' . ( $call->{item} - 1 ) . ']';
                }
            }
        }

        return $text;
    }
}

1;

__END__