package Test2::Tools::Spec;
use strict;
use warnings;

use Carp qw/croak/;
use Test2::Workflow qw/parse_args build current_build root_build init_root build_stack/;

use Test2::Workflow::Runner();
use Test2::Workflow::Task::Action();
use Test2::Workflow::Task::Group();
use Test2::Tools::Mock();
use Importer();

use vars qw/@EXPORT @EXPORT_OK/;
push @EXPORT => qw{describe cases};
push @EXPORT_OK => qw{include_workflow include_workflows spec_defaults};

my %HANDLED;
sub import {
    my $class = shift;
    my @caller = caller(0);

    my %root_args;
    my %runner_args;
    my @import;
    while (my $arg = shift @_) {
        if ($arg =~ s/^-//) {
            my $val = shift @_;

            if (Test2::Workflow::Runner->can($arg)) {
                $runner_args{$arg} = $val;
            }
            elsif (Test2::Workflow::Task::Group->can($arg)) {
                $root_args{$arg} = $val;
            }
            elsif ($arg eq 'root_args') {
                %root_args = (%root_args, %$val);
            }
            elsif ($arg eq 'runner_args') {
                %runner_args = (%runner_args, %$val);
            }
            else {
                croak "Unrecognized arg: $arg";
            }
        }
        else {
            push @import => $arg;
        }
    }

    if ($HANDLED{$caller[0]}++) {
        croak "Package $caller[0] has already been initialized"
            if keys(%root_args) || keys(%runner_args);
    }
    else {
        my $root = init_root(
            $caller[0],
            frame => \@caller,
            code => sub { 1 },
            %root_args,
        );

        my $runner = Test2::Workflow::Runner->new(%runner_args);

        Test2::Tools::Mock->add_handler(
            $caller[0],
            sub {
                my %params = @_;
                my ($class, $caller, $builder, $args) = @params{qw/class caller builder args/};

                my $do_it = eval "package $caller->[0];\n#line $caller->[2] \"$caller->[1]\"\nsub { \$runner\->add_mock(\$builder->()) }";

                # Running
                if (@{$runner->stack}) {
                    $do_it->();
                }
                else { # Not running
                    my $action = Test2::Workflow::Task::Action->new(
                        code     => $do_it,
                        name     => "mock $class",
                        frame    => $caller,
                        scaffold => 1,
                    );

                    my $build = current_build() || $root;

                    $build->add_primary_setup($action);
                    $build->add_stash($builder->()) unless $build->is_root;
                }

                return 1;
            }
        );

        my $stack = Test2::API::test2_stack;
        $stack->top; # Insure we have a hub
        my ($hub) = Test2::API::test2_stack->all;
        $hub->set_active(1);
        $hub->follow_up(
            sub {
                return unless $root->populated;
                my $g = $root->compile;
                $runner->push_task($g);
                $runner->run;
            }
        );
    }

    Importer->import_into($class, $caller[0], @import);
}

{
    no warnings 'once';
    *cases             = \&describe;
    *include_workflows = \&include_workflow;
}

sub describe {
    my @caller = caller(0);

    my $want = wantarray;

    my $build = build(args => \@_, caller => \@caller, stack_stop => defined $want ? 1 : 0);

    return $build if defined $want;

    my $current = current_build() || root_build($caller[0])
        or croak "No current workflow build!";

    $current->add_primary($build);
}

sub include_workflow {
    my @caller = caller(0);

    my $build = current_build() || root_build(\$caller[0])
        or croak "No current workflow build!";

    for my $task (@_) {
        croak "include_workflow only accepts Test2::Workflow::Task objects, got: $task"
            unless $task->isa('Test2::Workflow::Task');

        $build->add_primary($task);
    }
}

sub defaults {
    my %params = @_;

    my ($package, $tool) = @params{qw/package tool/};

    my @stack = (root_build($package), build_stack());
    return unless @stack;

    my %out;
    for my $build (@stack) {
        %out = () if $build->stack_stop;
        my $new = $build->defaults->{$tool} or next;
        %out = (%out, %$new);
    }

    return \%out;
}


# Generate a bunch of subs that only have minor differences between them.
BEGIN {
    @EXPORT = qw{
        tests it
        case
        before_all  around_all  after_all
        before_case around_case after_case
        before_each around_each after_each
    };

    @EXPORT_OK = qw{
        mini
        iso   miso
        async masync
    };

    my %stages = (
        case  => ['add_variant'],
        tests => ['add_primary'],
        it    => ['add_primary'],

        iso  => ['add_primary'],
        miso => ['add_primary'],

        async  => ['add_primary'],
        masync => ['add_primary'],

        mini => ['add_primary'],

        before_all => ['add_setup'],
        after_all  => ['add_teardown'],
        around_all => ['add_setup', 'add_teardown'],

        before_case => ['add_variant_setup'],
        after_case  => ['add_variant_teardown'],
        around_case => ['add_variant_setup', 'add_variant_teardown'],

        before_each => ['add_primary_setup'],
        after_each  => ['add_primary_teardown'],
        around_each => ['add_primary_setup', 'add_primary_teardown'],
    );

    my %props = (
        case  => [],
        tests => [],
        it    => [],

        iso  => [iso => 1],
        miso => [iso => 1, flat => 1],

        async  => [async => 1],
        masync => [async => 1, flat => 1],

        mini => [flat => 1],

        before_all => [scaffold => 1],
        after_all  => [scaffold => 1],
        around_all => [scaffold => 1, around => 1],

        before_case => [scaffold => 1],
        after_case  => [scaffold => 1],
        around_case => [scaffold => 1, around => 1],

        before_each => [scaffold => 1],
        after_each  => [scaffold => 1],
        around_each => [scaffold => 1, around => 1],
    );

    sub spec_defaults {
        my ($tool, %params) = @_;
        my @caller = caller(0);

        croak "'$tool' is not a spec tool"
            unless exists $props{$tool} || exists $stages{$tool};

        my $build = current_build() || root_build($caller[0])
            or croak "No current workflow build!";

        my $old = $build->defaults->{$tool} ||= {};
        $build->defaults->{$tool} = { %$old, %params };
    }

    my $run = "";
    for my $func (@EXPORT, @EXPORT_OK) {
        $run .= <<"        EOT";
#line ${ \(__LINE__ + 1) } "${ \__FILE__ }"
sub $func {
    my \@caller = caller(0);
    my \$args = parse_args(args => \\\@_, caller => \\\@caller);
    my \$action = Test2::Workflow::Task::Action->new(\@{\$props{$func}}, %\$args);

    return \$action if defined wantarray;

    my \$build = current_build() || root_build(\$caller[0])
        or croak "No current workflow build!";

    if (my \$defaults = defaults(package => \$caller[0], tool => '$func')) {
        for my \$attr (keys \%\$defaults) {
            next if defined \$action->\$attr;
            my \$sub = "set_\$attr";
            \$action->\$sub(\$defaults->{\$attr});
        }
    }

    \$build->\$_(\$action) for \@{\$stages{$func}};
}
        EOT
    }

    my ($ok, $err);
    {
        local $@;
        $ok = eval "$run\n1";
        $err = $@;
    }

    die $@ unless $ok;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Tools::Spec - RSPEC implementation on top of Test2::Workflow

=head1 DESCRIPTION

This uses L<Test::Workflow> to implement an RSPEC variant. This variant
supports isolation and/or concurrency via forking or threads.

=head1 SYNOPSIS

    use Test2::Bundle::Extended;
    use Test2::Tools::Spec;

    describe foo => sub {
        before_all  once => sub { ... };
        before_each many => sub { ... };

        after_all  once => sub { ... };
        after_each many => sub { ... };

        case condition_a => sub { ... };
        case condition_b => sub { ... };

        tests foo => sub { ... };
        tests bar => sub { ... };
    };

    done_testing;

=head1 EXPORTS

All of these use the same argument pattern. The first argument must always be a
name for the block. The last argument must always be a code reference.
Optionally a configuration hash can be inserted between the name and the code
reference.

    FUNCTION "name" => sub { ... };

    FUNCTION "name" => {...}, sub { ... };

=over 4

=item NAME

The first argument to a Test2::Tools::Spec function MUST be a name. The name
does not need to be unique.

=item PARAMS

This argument is optional. If present this should be a hashref.

Here are the valid keys for the hashref:

=over 8

=item flat => $bool

If this is set to true then the block will not render as a subtest, instead the
events will be inline with the parent subtest (or main test).

=item async => $bool

Set this to true to mark a block as being capable of running concurrently with
other test blocks. This does not mean the block WILL be run concurrently, just
that it can be.

=item iso => $bool

Set this to true if the block MUST be run in isolation. If this is true then
the block will run in its own thread or fork.

=item todo => $reason

Use this to mark an entire block as TODO.

=item skip => $reason

Use this to prevent a block from running at all.

=back

=item CODEREF

This argument is required. This should be a code reference that will run some
assertions.

=back

=head2 ESSENTIALS

=over 4

=item tests NAME => sub { ... }

=item tests NAME => \%params, sub { ... }

=item tests($NAME, \%PARAMS, \&CODE)

=item it NAME => sub { ... }

=item it NAME => \%params, sub { ... }

=item it($NAME, \%PARAMS, \&CODE)

This defines a test block. Test blocks are essentially subtests. All test
blocks will be run, and are expected to produce events. Test blocks can run
multiple times if the C<case()> function is also used.

C<it()> is an alias to C<tests()>.

These ARE NOT inherited by nested describe blocks.

=item case NAME => sub { ... }

=item case NAME => \%params, sub { ... }

=item case($NAME, \%PARAMS, \&CODE)

This lets you specify multiple conditions in which the test blocks should be
run. Every test block within the same group (C<describe>) will be run once per
case.

These ARE NOT inherited by nested describe blocks, but nested describe blocks
will be executed once per case.

=item before_each NAME => sub { ... }

=item before_each NAME => \%params, sub { ... }

=item before_each($NAME, \%PARAMS, \&CODE)

Specify a codeblock that should be run multiple times, once before each
C<tests()> block is run. These will run AFTER C<case()> blocks but before
C<tests()> blocks.

These ARE inherited by nested describe blocks.

=item before_case NAME => sub { ... }

=item before_case NAME => \%params, sub { ... }

=item before_case($NAME, \%PARAMS, \&CODE)

Same as C<before_each()>, except these blocks run BEFORE C<case()> blocks.

These ARE NOT inherited by nested describe blocks.

=item before_all NAME => sub { ... }

=item before_all NAME => \%params, sub { ... }

=item before_all($NAME, \%PARAMS, \&CODE)

Specify a codeblock that should be run once, before all the test blocks run.

These ARE NOT inherited by nested describe blocks.

=item around_each NAME => sub { ... }

=item around_each NAME => \%params, sub { ... }

=item around_each($NAME, \%PARAMS, \&CODE)

Specify a codeblock that should wrap around each test block. These blocks are
run AFTER case blocks, but before test blocks.

    around_each wrapit => sub {
        my $cont = shift;

        local %ENV = ( ... );

        $cont->();

        ...
    };

The first argument to the codeblock will be a callback that MUST be called
somewhere inside the sub in order for nested items to run.

These ARE inherited by nested describe blocks.

=item around_case NAME => sub { ... }

=item around_case NAME => \%params, sub { ... }

=item around_case($NAME, \%PARAMS, \&CODE)

Same as C<around_each> except these run BEFORE case blocks.

These ARE NOT inherited by nested describe blocks.

=item around_all NAME => sub { ... }

=item around_all NAME => \%params, sub { ... }

=item around_all($NAME, \%PARAMS, \&CODE)

Same as C<around_each> except that it only runs once to wrap ALL test blocks.

These ARE NOT inherited by nested describe blocks.

=item after_each NAME => sub { ... }

=item after_each NAME => \%params, sub { ... }

=item after_each($NAME, \%PARAMS, \&CODE)

Same as C<before_each> except it runs right after each test block.

These ARE inherited by nested describe blocks.

=item after_case NAME => sub { ... }

=item after_case NAME => \%params, sub { ... }

=item after_case($NAME, \%PARAMS, \&CODE)

Same as C<after_each> except it runs right after the case block, and before the
test block.

These ARE NOT inherited by nested describe blocks.

=item after_all NAME => sub { ... }

=item after_all NAME => \%params, sub { ... }

=item after_all($NAME, \%PARAMS, \&CODE)

Same as C<before_all> except it runs after all test blocks have been run.

These ARE NOT inherited by nested describe blocks.

=back

=head2 SHORTCUTS

These are shortcuts. Each of these is the same as C<tests()> except some
parameters are added for you.

These are NOT exported by default/.

=over 4

=item mini NAME => sub { ... }

Same as:

    tests NAME => { flat => 1 }, sub { ... }

=item iso NAME => sub { ... }

Same as:

    tests NAME => { iso => 1 }, sub { ... }

=item miso NAME => sub { ... }

Same as:

    tests NAME => { mini => 1, iso => 1 }, sub { ... }

=item async NAME => sub { ... }

Same as:

    tests NAME => { async => 1 }, sub { ... }

B<Note:> This conflicts with the C<async()> exported from L<threads>. Don't
import both.

=item masync NAME => sub { ... }

Same as:

    tests NAME => { minit => 1, async => 1 }, sub { ... }

=back

=head2 CUSTOM ATTRIBUTE DEFAULTS

Sometimes you want to apply default attributes to all C<tests()> or C<case()>
blocks. This can be done, and is lexical to your describe or package root!

    use Test2::Bundle::Extended;
    use Test2::Tools::Spec ':ALL';

    # All 'tests' blocks after this declaration will have C<<iso => 1>> by default
    spec_defaults tests => (iso => 1);

    tests foo => sub { ... }; # isolated

    tests foo, {iso => 0}, sub { ... }; # Not isolated

    spec_defaults tests => (iso => 0); # Turn it off again

Defaults are inherited by nested describe blocks. You can also override the
defaults for the scope of the describe:

    spec_defaults tests => (iso => 1);

    describe foo => sub {
        spec_defaults tests => (async => 1); # Scoped to this describe and any child describes

        tests bar => sub { ... }; # both iso and async
    };

    tests baz => sub { ... }; # Just iso, no async.

You can apply defaults to any type of blocks:

    spec_defaults case => (iso => 1); # All cases are 'iso';

Defaults are not inherited when a builder's return is captured.

    spec_defaults tests => (iso => 1);

    # Note we are not calling this in void context, that is the key here.
    my $d = describe foo => {
        tests bar => sub { ... }; # Not iso
    };

=head1 EXECUTION ORDER

As each function is encountered it executes, just like any other function. The
C<describe()> function will immedietly execute the codeblock it is given. All
other functions will stash their codeblocks to be run later. When
C<done_testing()> is run the workflow will be compiled, at which point all
other blocks will run.

Here is an overview of the order in which blocks get called once compiled (at
C<done_testing()>).

    before_all
        for-each-case {
            before_case
                case
            after_case

            # AND/OR nested describes
            before_each
                tests
            after_each
        }
    after_all

=head1 SOURCE

The source code repository for Test2-Workflow can be found at
F<http://github.com/Test-More/Test2-Workflow/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2016 Chad Granum E<lt>exodist7@gmail.comE<gt>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F<http://dev.perl.org/licenses/>

=cut

