#!/usr/bin/perl

use 5.010;
use strict;
use warnings FATAL => 'all';
use FindBin '$Bin';

use vars qw($VERSION);
use Data::Clone;
use File::Slurp;
use YAML::Syck qw(Dump);

# VERSION
unless (defined $VERSION) {
    my $dist = read_file "$Bin/../dist.ini";
    $dist =~ /^\s*version\s*=\s*(.+)/m and $VERSION = $1;
}

our ($Type, $Clause);

# describe literal
sub _l {
    my $d = shift;
    return "undefined value" if !defined($d);
    return $d unless ref($d);
    my $res = Dump($_);
    $res =~ s/\s+\z//s;
    $res;
}

sub gen_type_check_tests {
    my %args = @_;
    my @res;

    for (@{ $args{accept} }) {
        push @res, {
            name   => "type check: must accept "._l($_),
            input  => $_,
            schema => $Type,
            valid  => 1,
        };
    }
    for (@{ $args{reject} }) {
        push @res, {
            name   => "type check: must reject "._l($_),
            input  => $_,
            schema => $Type,
            valid  => 0,
        };
    }

    @res;
}

# req, forbidden, default
#
# args:
#
# - value -> used to test 'forbidden'. must be a valid value.
#
# - ok_defaults -> used to test 'default' and that default values are still
# validated, min 1 value
#
# - nok_defaults -> see above
#
# - ok_clauses -> used to test 'clause' and 'clset'. minimal 2 values, clauses
# must be different
#
# - nok_clauses -> see above.
#
sub gen_BaseType_tests {
    my %args = @_;
    my @res;

    push @res, {
        name   => "must accept undefined value",
        schema => $Type,
        input  => undef,
        valid  => 1,
    };

    # req
    push @res, {
        name   => "req=0 must accept undefined value",
        schema => [$Type, req=>0],
        input  => undef,
        valid  => 1,
    };
    push @res, {
        name   => "req=1 must reject undefined value",
        schema => [$Type, req=>1],
        input  => undef,
        valid  => 0,
    };

    # forbidden
    push @res, {
        name   => "forbidden=0 must accept defined value",
        schema => [$Type, forbidden=>0],
        input  => $args{value},
        valid  => 1,
    };
    push @res, {
        name   => "forbidden=1 must reject defined value",
        schema => [$Type, forbidden=>1],
        input  => $args{value},
        valid  => 0,
    };

    # default
    for (@{ $args{ok_defaults} }) {
        push @res, {
            name   => "default: must accept valid default "._l($_),
            input  => undef,
            schema => ["$Type*", default=>$_],
            valid  => 1,
        };
    }
    for (@{ $args{nok_defaults} }) {
        push @res, {
            name   => "default: must reject invalid default "._l($_),
            input  => undef,
            schema => ["$Type*", default=>$_],
            valid  => 0,
        };
    }

    # clause
    push @res, {
        name   => "clause (dies, unknown clause)",
        input  => $args{value},
        schema => ["$Type*", clause=>[foo => 1]],
        dies   => 1,
    };
    push @res, {
        name   => "clause (ok)",
        input  => $args{value},
        schema => ["$Type*", clause=>$args{ok_clauses}[0]],
        valid  => 1,
    } if $args{ok_clauses};
    # to test that the existence of clause does not override clauses outside it
    push @res, {
        name   => "clause (ok) + clause nok = nok",
        input  => $args{value},
        schema => [
            "$Type*",
            clause=>$args{ok_clauses}[0],
            $args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
        ],
        valid  => 0,
    } if $args{ok_clauses};
    push @res, {
        name   => "clause (nok)",
        input  => $args{value},
        schema => ["$Type*", clause=>$args{nok_clauses}[0]],
        valid  => 0,
        errors => 1,
    } if $args{ok_clauses};

    # XXX clause 'clause' + .op and/or/none

    push @res, {
        name   => "clset (dies, unknown clause)",
        input  => $args{value},
        schema => ["$Type*", clset=>{foo=>1}],
        dies   => 1,
    };
    push @res, {
        name   => "clset (dies, unknown attr)",
        input  => $args{value},
        schema => ["$Type*", clset=>{min_len=>1, "min_len.foo"=>1}],
        dies   => 1,
    };
    push @res, {
        name   => "clset (empty = ok)",
        input  => $args{value},
        schema => ["$Type*", clset=>{}],
        valid  => 1,
    };
    push @res, {
        name   => "clset (ignored clause/attr = ok)",
        input  => $args{value},
        schema => ["$Type*", clset=>{_foo=>1, "foo._bar"=>2}],
        valid  => 1,
    };
    push @res, {
        name   => "clset (ok + ok = ok)",
        input  => $args{value},
        schema => ["$Type*", clset=>{
            $args{ok_clauses}[0][0] => $args{ok_clauses}[0][1],
            $args{ok_clauses}[1][0] => $args{ok_clauses}[1][1],
        }],
        valid  => 1,
    } if $args{ok_clauses};
    # to test that the existence of clset does not override clauses outside it
    push @res, {
        name   => "clset (ok) + clause nok = nok",
        input  => $args{value},
        schema => [
            "$Type*",
            clset=>{
                $args{ok_clauses}[0][0] => $args{ok_clauses}[0][1],
            },
            $args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
        ],
        valid  => 0,
    } if $args{ok_clauses};
    push @res, {
        name   => "clset (ok + nok = nok)",
        input  => $args{value},
        schema => ["$Type*", clset=>{
            $args{ok_clauses}[0][0]  => $args{ok_clauses}[0][1],
            $args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
        }],
        valid  => 0,
    } if $args{ok_clauses};
    push @res, {
        name   => "clset (nok + ok = nok)",
        input  => $args{value},
        schema => ["$Type*", clset=>{
            $args{nok_clauses}[0][0] => $args{nok_clauses}[0][1],
            $args{ok_clauses}[1][0]  => $args{ok_clauses}[1][1],
        }],
        valid  => 0,
    } if $args{ok_clauses};
    push @res, {
        name   => "clset (nok + nok = nok)",
        input  => $args{value},
        schema => ["$Type*", clset=>{
            $args{nok_clauses}[0][0] => $args{nok_clauses}[0][1],
            $args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
        }],
        valid  => 0,
    } if $args{ok_clauses};

    # XXX clause 'clset' + .op and/or/none

    @res;
}

sub gen_op_attr_tests {
    my %args = @_;
    my @res;

    die "BUG: Need at least 2 values for ok_values"
        unless @{$args{ok_values}}>1;
    die "BUG: Need at least 2 values for nok_values"
        unless @{$args{nok_values}}>1;

    push @res, {
        name   => "!$Clause (nok)",
        input  => $args{input},
        schema => [$Type, "!$Clause" => $args{ok_values}[0]],
        valid  => 0,
    };
    push @res, {
        name   => "!$Clause (ok)",
        input  => $args{input},
        schema => [$Type, "!$Clause" => $args{nok_values}[0]],
        valid  => 1,
    };

    push @res, {
        name   => "$Clause.op=not (nok)",
        input  => $args{input},
        schema => [$Type, $Clause=>$args{ok_values}[0], "$Clause.op"=>"not"],
        valid  => 0,
    };
    push @res, {
        name   => "$Clause.op=not (ok)",
        input  => $args{input},
        schema => [$Type, $Clause=>$args{nok_values}[0], "$Clause.op"=>"not"],
        valid  => 1,
    };

    push @res, {
        name   => "$Clause& (no items)",
        input  => $args{input},
        schema => [$Type, "$Clause&" => []],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause& (ok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause&" => $args{ok_values}],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause& (nok + ok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause&" => [$args{nok_values}[0], $args{ok_values}[0]]],
        valid  => 0,
        errors => 1,
    };
    push @res, {
        name   => "$Clause& (ok + nok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause&" => [$args{ok_values}[0], $args{nok_values}[0]]],
        valid  => 0,
        errors => 1,
    };
    push @res, {
        name   => "$Clause& (nok + nok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause&" => [$args{nok_values}[0], $args{nok_values}[1]]],
        valid  => 0,
        errors => 1,
    };

    push @res, {
        name   => "$Clause.op=and (no items)",
        input  => $args{input},
        schema => [$Type, $Clause=>[], "$Clause.op"=>"and"],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=and (ok)",
        input  => $args{input},
        schema => [$Type, $Clause=>$args{ok_values}, "$Clause.op"=>"and"],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=and (nok + ok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{nok_values}[0], $args{ok_values}[0]],
                   "$Clause.op"=>"and",
               ],
        valid  => 0,
        errors => 1,
    };
    push @res, {
        name   => "$Clause.op=and (ok + nok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{ok_values}[0], $args{nok_values}[0]],
                   "$Clause.op"=>"and",
               ],
        valid  => 0,
        errors => 1,
    };
    push @res, {
        name   => "$Clause.op=and (nok + nok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{nok_values}[0], $args{nok_values}[1]],
                   "$Clause.op"=>"and",
               ],
        valid  => 0,
        errors => 1,
    };

    push @res, {
        name   => "$Clause| (no items)",
        input  => $args{input},
        schema => [$Type, "$Clause|" => []],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause| (ok)",
        input  => $args{input},
        schema => [$Type, "$Clause|" => $args{ok_values}],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause| (nok + ok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause|" => [$args{nok_values}[0], $args{ok_values}[0]]],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause| (ok + nok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause|" => [$args{ok_values}[0], $args{nok_values}[0]]],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause| (nok + nok)",
        input  => $args{input},
        schema => [$Type,
                   "$Clause|" => [$args{nok_values}[0], $args{nok_values}[1]]],
        valid  => 0,
        errors => 1,
    };

    push @res, {
        name   => "$Clause.op=or (no items)",
        input  => $args{input},
        schema => [$Type, $Clause => [], "$Clause.op"=>"or"],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=or (ok)",
        input  => $args{input},
        schema => [$Type, $Clause=>$args{ok_values}, "$Clause.op"=>"or"],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=or (nok + ok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{nok_values}[0], $args{ok_values}[0]],
                   "$Clause.op"=>"or",
               ],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=or (ok + nok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{ok_values}[0], $args{nok_values}[0]],
                   "$Clause.op"=>"or",
               ],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=or (nok + nok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{nok_values}[0], $args{nok_values}[1]],
                   "$Clause.op"=>"or",
               ],
        valid  => 0,
        errors => 1,
    };

    push @res, {
        name   => "$Clause.op=none (empty items)",
        input  => $args{input},
        schema => [$Type, $Clause=>[], "$Clause.op"=>"none"],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=none (nok + nok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{nok_values}[0], $args{nok_values}[1]],
                   "$Clause.op"=>"none"],
        valid  => 1,
    };
    push @res, {
        name   => "$Clause.op=none (nok + ok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{nok_values}[0], $args{ok_values}[0]],
                   "$Clause.op"=>"none"],
        valid  => 0,
        errors => 1,
    };
    push @res, {
        name   => "$Clause.op=none (ok + nok)",
        input  => $args{input},
        schema => [$Type,
                   $Clause=>[$args{ok_values}[0], $args{nok_values}[0]],
                   "$Clause.op"=>"none"],
        valid  => 0,
        errors => 1,
    };
    push @res, {
        name   => "$Clause.op=none (ok + ok)",
        input  => $args{input},
        schema => [$Type, $Clause=>$args{ok_values}, "$Clause.op"=>"none"],
        valid  => 0,
        errors => 1,
    };

    @res;
}

sub gen_err_level_tests {
    my %args = @_;
    (
        {
            name   => ".err_level=error (clause=$args{clause}, ok)",
            input  => $args{ok_value},
            schema => [$Type, $args{clause} => $args{cval}],
            valid  => 1,
        },
        {
            name   => ".err_level=error (clause=$args{clause}, nok)",
            input  => $args{nok_value},
            schema => [$Type, $args{clause} => $args{cval}],
            valid  => 0,
        },
        {
            name   => ".err_level=warn (clause=$args{clause}, ok)",
            input  => $args{ok_value},
            schema => [$Type, $args{clause} => $args{cval},
                       "$args{clause}.err_level"=>"warn"],
            valid  => 1,
        },
        {
            name   => ".err_level=warn (clause=$args{clause}, nok)",
            input  => $args{nok_value},
            schema => ["$Type*", $args{clause} => $args{cval},
                       "$args{clause}.err_level"=>"warn"],
            valid  => 1,
            warnings => 1,
        },
    );
    # XXX .err_level=fatal (needs two clauses)
}

sub gen_Comparable_tests {
    my %args = @_;
    my @res;

    my $v  = $args{values}[0];
    my $v2 = $args{values}[1];

    # is
    push @res, {
        name   => "is: must accept same value",
        schema => [$Type, is=>$v],
        input  => $v,
        valid  => 1,
    };
    push @res, {
        name   => "is: must reject different value",
        schema => [$Type, is=>$v2],
        input  => $v,
        valid  => 0,
    };
    local $Clause = "is";
    push @res, gen_op_attr_tests(
        input      => $v,
        ok_values  => [$v, $v],
        nok_values => [$v2, $v2],
    );

    # in
    push @res, {
        name   => "in: must accept valid choices",
        schema => [$Type, in=>$args{values}],
        input  => $v,
        valid  => 1,
    };
    push @res, {
        name   => "in: must reject empty choices",
        schema => [$Type, in=>[]],
        input  => $v,
        valid  => 0,
    };
    local $Clause = "in";
    push @res, gen_op_attr_tests(
        input      => $v,
        ok_values  => [$args{values}, clone($args{values})],
        nok_values => [[], []],
    );

    @res;
}

sub gen_Sortable_tests {
    my %args = @_;
    my @res;

    die "BUG: Please supply 3 values" unless @{ $args{values} } == 3;

    # $v2 must be > $v1, and $v3 must be >= $v2
    my ($v1, $v2, $v3) = @{ $args{values} };

    push @res, (

        {
            name   => "min: "._l($v2)." "._l($v1),
            input  => $v2,
            schema => [$Type, min => $v1],
            valid  => 1,
        },
        {
            name   => "min: "._l($v2)." "._l($v2),
            input  => $v2,
            schema => [$Type, min => $v2],
            valid  => 1,
        },
        {
            name   => "min: "._l($v1)." "._l($v2).' -> fail',
            input  => $v1,
            schema => [$Type, min => $v2],
            valid  => 0,
        },

        {
            name   => "xmin: "._l($v2)." "._l($v1),
            input  => $v2,
            schema => [$Type, xmin => $v1],
            valid  => 1,
        },
        {
            name   => "xmin: "._l($v2)." "._l($v2).' -> fail',
            input  => $v2,
            schema => [$Type, xmin => $v2],
            valid  => 0,
        },
        {
            name   => "xmin: "._l($v1)." "._l($v2).' -> fail',
            input  => $v1,
            schema => [$Type, xmin => $v2],
            valid  => 0,
        },

        {
            name   => "max: "._l($v2)." "._l($v1).' -> fail',
            input  => $v2,
            schema => [$Type, max => $v1],
            valid  => 0,
        },
        {
            name   => "max: "._l($v2)." "._l($v2),
            input  => $v2,
            schema => [$Type, max => $v2],
            valid  => 1,
        },
        {
            name   => "max: "._l($v1)." "._l($v2),
            input  => $v1,
            schema => [$Type, max => $v2],
            valid  => 1,
        },

        {
            name   => "xmax: "._l($v2)." "._l($v1).' -> fail',
            input  => $v2,
            schema => [$Type, xmax => $v1],
            valid  => 0,
        },
        {
            name   => "xmax: "._l($v2)." "._l($v2).' -> fail',
            input  => $v2,
            schema => [$Type, xmax => $v2],
            valid  => 0,
        },
        {
            name   => "xmax: "._l($v1)." "._l($v2),
            input  => $v1,
            schema => [$Type, xmax => $v2],
            valid  => 1,
        },

        {
            name   => "between: "._l($v2)." "._l($v1)." & "._l($v3),
            input  => $v2,
            schema => [$Type, between => [$v1, $v3]],
            valid  => 1,
        },
        {
            name   => "between: "._l($v2)." "._l($v1)." & "._l($v2),
            input  => $v2,
            schema => [$Type, between => [$v1, $v2]],
            valid  => 1,
        },
        {
            name   => "between: "._l($v2)." "._l($v2)." & "._l($v2),
            input  => $v2,
            schema => [$Type, between => [$v2, clone($v2)]],
            valid  => 1,
        },
        {
            name   => "between: "._l($v1)." "._l($v2)." & "._l($v3).' -> fail',
            input  => $v1,
            schema => [$Type, between => [$v2, $v3]],
            valid  => 0,
        },

        {
            name   => "xbetween: "._l($v2)." "._l($v1)." & "._l($v3),
            input  => $v2,
            schema => [$Type, xbetween => [$v1, $v3]],
            valid  => $v3 eq $v2 ? 0:1,
        },
        {
            name   => "xbetween: "._l($v2)." "._l($v1)." & "._l($v2).' -> fail',
            input  => $v2,
            schema => [$Type, xbetween => [$v1, $v2]],
            valid  => 0,
        },
        {
            name   => "xbetween: "._l($v2)." "._l($v2)." & "._l($v2).' -> fail',
            input  => $v2,
            schema => [$Type, xbetween => [$v2, clone($v2)]],
            valid  => 0,
        },
        {
            name   => "xbetween: "._l($v1)." "._l($v2)." & "._l($v3).' -> fail',
            input  => $v1,
            schema => [$Type, xbetween => [$v2, $v3]],
            valid  => 0,
        },

    );

    # disabled temporarily because failing for bool, even though i've adjust
    # stuffs
    #local $Clause = "between";
    #push @res, gen_op_attr_tests(
    #    input      => $v1,
    #    # i know, lame, it's because bool only has two possible values
    #    ok_values  => [[$v1, clone($v1)], [$v1, clone($v1)]],
    #    nok_values => [[$v2, clone($v2)], [$v2, clone($v2)]],
    #);

    # XXX op attr for xbetween

    @res;
}

sub gen_HasElems_tests {
    my %args = @_;
    my @res;

    die "BUG: Please supply two values" unless @{$args{values}} == 2;

    my $v1 = $args{values}[0][0];
    my $l1 = $args{values}[0][1];
    my $v2 = $args{values}[1][0];
    my $l2 = $args{values}[1][1];

    die "BUG: First value's length must be less than second value's"
        unless $l1 < $l2;

    push @res, (
        {
            name   => "len (ok)",
            input  => $v1,
            schema => [$Type, len => $l1],
            valid  => 1,
        },
        {
            name   => "len (nok)",
            input  => $v1,
            schema => [$Type, len => $l2],
            valid  => 0,
        },
        {
            name   => "min_len (ok)",
            input  => $v1,
            schema => [$Type, min_len => $l1],
            valid  => 1,
        },
        {
            name   => "min_len (nok)",
            input  => $v1,
            schema => [$Type, min_len => $l2],
            valid  => 0,
        },
        {
            name   => "max_len (ok)",
            input  => $v1,
            schema => [$Type, min_len => $l1],
            valid  => 1,
        },
        {
            name   => "max_len (nok)",
            input  => $v2,
            schema => [$Type, max_len => $l1],
            valid  => 0,
        },
        {
            name   => "len_between (ok)",
            input  => $v1,
            schema => [$Type, len_between => [$l1, $l2]],
            valid  => 1,
        },
        {
            name   => "len_between (nok)",
            input  => $v2,
            schema => [$Type, len_between => [$l1, $l1]],
            valid  => 0,
        },

        # XXX has

        {
            name   => "each_index (ok)",
            input  => $v2,
            schema => [$Type, each_index => $args{ok_each_index}],
            valid  => 1,
        },
        {
            name   => "each_index (nok)",
            input  => $v2,
            schema => [$Type, each_index => $args{nok_each_index}],
            valid  => 0,
        },
        {
            name   => "each_elem (ok)",
            input  => $v2,
            schema => [$Type, each_elem => $args{ok_each_elem}],
            valid  => 1,
        },
        {
            name   => "each_elem (nok)",
            input  => $v2,
            schema => [$Type, each_elem => $args{nok_each_elem}],
            valid  => 0,
        },

        # XXX check_each_index
        # XXX check_each_elem
        # XXX uniq
        # XXX exists
    );

    if ($args{elems_test}) {
        for ($args{elems_test}) {
            push @res, (
                {
                    name   => 'elems (ok)',
                    input  => $_->{value},
                    schema => [$Type, elems => $_->{ok}],
                    valid  => 1,
                },
                {
                    name   => 'elems (nok)',
                    input  => $_->{value},
                    schema => [$Type, elems => $_->{nok}],
                    valid  => 0,
                },
            );
        }
    }

    # XXX multi vals for all clauses

    @res;
}

sub gen_int_tests {
    my %args = @_;
    my @res;

    local $Type = "int";

    (
        gen_type_check_tests(
            accept => [-1, 0, 1],
            reject => [1.1, "a", [], {}], # XXX -Inf, NaN, Inf
        ),
        gen_BaseType_tests(
            value => 2,
            ok_defaults  => [1],
            nok_defaults => [[]],
            ok_clauses   => [[min=>1], [max=>2]],
            nok_clauses  => [[min=>3], [xmax=>2]],
        ),
        gen_err_level_tests(
            clause    => 'div_by',
            cval      => 3,
            ok_value  => 9,
            nok_value => 8,
        ),
        gen_Comparable_tests(
            values => [1, 2],
        ),
        gen_Sortable_tests(
            values => [-3, 2, 4],
        ),

        {
            name   => 'mod: (nok)',
            input  => 10,
            schema => [int => mod => [3, 2]],
            valid  => 0,
        },
        {
            name   => 'mod: (ok)',
            input  => 11,
            schema => [int => mod => [3, 2]],
            valid  => 1,
        },

        {
            name   => 'div_by: (nok)',
            input  => 7,
            schema => [int => div_by => 3],
            valid  => 0,
        },
        {
            name   => 'div_by: (ok)',
            input  => 6,
            schema => [int => div_by => 3],
            valid  => 1,
        },

    );

    # XXX op attr for mod
    # XXX op attr for div_by
    # XXX div_by 0
}

sub gen_float_tests {
    my %args = @_;
    my @res;

    local $Type = "float";

    (
        gen_type_check_tests(
            accept => [-1.1, -1, 0, 1, 1.1], # XXX -Inf, NaN, Inf
            reject => ["a", [], {}],
        ),
        gen_BaseType_tests(
            value => 1.1,
            ok_defaults  => [1.1],
            nok_defaults => [[]],
            ok_clauses   => [[min=>1], [max=>1.1]],
            nok_clauses  => [[min=>2], [max=>1]],
        ),
        gen_err_level_tests(
            clause    => 'min',
            cval      => 0,
            ok_value  =>  0.1,
            nok_value => -0.1,
        ),
        gen_Comparable_tests(
            values => [1.1, 1.2],
        ),
        gen_Sortable_tests(
            values => [-3.1, 2.1, 4.1],
        ),

        # is_{nan,inf,pos_inf,neg_inf} is currently tested in perl compiler
    );
}

sub gen_array_tests {
    my %args = @_;
    my @res;

    local $Type = "array";

    push @res, (
        gen_type_check_tests(
            accept => [[], [1, "a"], [[]]],
            reject => [1, "a", {}],
        ),
        gen_BaseType_tests(
            value => [1],
            ok_defaults  => [[]],
            nok_defaults => ["a"],
            ok_clauses   => [[min_len=>0], [max_len=>1]],
            nok_clauses  => [[min_len=>2], [max_len=>0]],
        ),
        gen_err_level_tests(
            clause    => 'is',
            cval      => [],
            ok_value  => [],
            nok_value => [0],
        ),
        gen_Comparable_tests(
            values => [[1], [2]],
        ),

        gen_HasElems_tests(
            # two values, each value is [VAL, LEN].
            values => [ [[1], 1], [[1, 1.2], 2] ],
            # will be tested on the second value
            ok_each_index  => [int =>  max => 1],
            nok_each_index => [int => xmax => 1],
            ok_each_elem   => "float",
            nok_each_elem  => "int",
            # 'elems' is actually not part of HasElems currently, but we stick
            # it in here for the moment. str might get 'elems' too.
            elems_test     => {value=>[1, 1.2], ok=>["int","float"], nok=>["int","int"]},
        ),
    );

    my $sch = [array => {elems => ["int*", ["float", default=>2]]}];
    push @res, (
        {
            name   => 'elems (nok, first elem required)',
            input  => [undef, 1],
            schema => $sch,
            valid  => 0,
        },
        {
            name   => 'elems (ok, missing elem set to undef)',
            input  => [1],
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'elems (ok, second elem optional)',
            input  => [1, undef],
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'elems (ok 2)',
            input  => [1, 1.1],
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'elems (ok, extra elems ignored)',
            input  => [1, 1.1, undef],
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'elems (ok, extra elems ignored 2)',
            input  => [1, 1.1, "foo"],
            schema => $sch,
            valid  => 1,
        },
    );

    $sch = [array => {elems => ["int", ["int", default=>2]],
                      "elems.create_default"=>0}];
    push @res, (
        {
            name   => 'elems (ok, create_default=0)',
            input  => [1],
            schema => $sch,
            valid  => 1,
            output => [1],
        },
        {
            name   => 'elems (ok 2, create_default=0)',
            input  => [1, undef],
            schema => $sch,
            valid  => 1,
            output => [1, 2],
        },
    );

    @res;
}

sub gen_str_tests {
    my %args = @_;
    my @res;

    local $Type = "str";

    push @res, (
        gen_type_check_tests(
            accept => [0, 1.1, "", "str\n"],
            reject => [[], {}],
        ),
        gen_BaseType_tests(
            value => "a",
            ok_defaults  => ["a"],
            nok_defaults => [[]],
            ok_clauses   => [[match=>"a"], [len=>1]],
            nok_clauses  => [[match=>"b"], [len=>2]],
        ),
        gen_err_level_tests(
            clause    => 'is',
            cval      => "a",
            ok_value  => "a",
            nok_value => "a\n",
        ),
        gen_Comparable_tests(
            values => ["a", "b"],
        ),

        gen_Sortable_tests(
            values => ["", "a", "ab"],
        ),

        gen_HasElems_tests(
            # two values, each value is [VAL, LEN]
            values => [ ["a", 1], ["abc", 3] ],
            # will be tested on the second value
            ok_each_index  => [int =>  max => 2],
            nok_each_index => [int => xmax => 2],
            ok_each_elem   => "str",
            nok_each_elem  => "float",
            # currently only array has 'elems' clause, and it's not part of
            # HasELems role
            #elems_test     => {value=>"abc", ok=>["str","str","str"], nok=>["str","str",[str=>is=>"d"]]},
        ),

        {
            name   => 'match: (ok)',
            input  => "a",
            schema => [str => match => "[abc]"],
            valid  => 1,
        },
        {
            name   => 'match: (nok)',
            input  => "z",
            schema => [str => match => "[abc]"],
            valid  => 0,
        },
        {
            name   => 'match: (dies, invalid regex)',
            input  => "a",
            schema => [str => match => "("],
            dies   => 1,
        },

        {
            name   => 'is_re: 1 (ok)',
            input  => "a",
            schema => [str => is_re => 1],
            valid  => 1,
        },
        {
            name   => 'is_re: 1 (nok)',
            input  => "a(",
            schema => [str => is_re => 1],
            valid  => 0,
        },
        {
            name   => 'is_re: 0 (ok)',
            input  => "a(",
            schema => [str => is_re => 0],
            valid  => 1,
        },
        {
            name   => 'is_re: 0 (nok)',
            input  => "a",
            schema => [str => is_re => 0],
            valid  => 0,
        },

    );

    @res;
}

sub gen_hash_tests {
    my %args = @_;
    my @res;
    my ($sch, $sch2);

    local $Type = "hash";

    push @res, (
        gen_type_check_tests(
            accept => [{}, {a=>1}, {""=>[]}],
            reject => [1, "a", []],
        ),
        gen_BaseType_tests(
            value => {a=>1},
            ok_defaults  => [{}],
            nok_defaults => ["a"],
            ok_clauses   => [[min_len=>1], [max_len=>1]],
            nok_clauses  => [[min_len=>2], [max_len=>0]],
        ),
        gen_err_level_tests(
            clause    => 'is',
            cval      => {a=>0},
            ok_value  => {a=>0},
            nok_value => {a=>1},
        ),
        gen_Comparable_tests(
            values => [{}, {a=>1}],
        ),

        gen_HasElems_tests(
            # two values, each value is [VAL, LEN].
            values => [ [{a=>1}, 1], [{a=>1, b=>1.1}, 2] ],
            # will be tested on the second value
            ok_each_index  => [str => len=>1],
            nok_each_index => [str => len=>2],
            ok_each_elem   => "float",
            nok_each_elem  => "int",
            # currently only array has 'elems' clause, and it's not part of
            # HasELems role
        )
    );

    $sch  = [hash => {keys => {a=>"int", b=>"float*"}}];
    $sch2 = [hash => {keys => {a=>"int", b=>"float*"}}];

    push @res, (
        {
            name   => 'keys: (ok, empty)',
            input  => {},
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'keys: (ok, only a, a valid 1)',
            input  => {a=>undef},
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'keys: (ok, only a, a valid 2)',
            input  => {a=>1},
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'keys: (nok, only a, a invalid)',
            input  => {a=>1.1},
            schema => $sch,
            valid  => 0,
        },
        {
            name   => 'keys: (ok, only a, valid 2)',
            input  => {a=>1},
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'keys: (ok, a & b, valid)',
            input  => {a=>1, b=>1.1},
            schema => $sch,
            valid  => 1,
        },
        {
            name   => 'keys: (nok, a & b, b invalid)',
            input  => {a=>1, b=>undef},
            schema => $sch,
            valid  => 0,
        },
        {
            name   => 'keys: (nok, a & b, a invalid)',
            input  => {a=>1.1, b=>1.1},
            schema => $sch,
            valid  => 0,
        },
        {
            name   => 'keys: (nok, a & b, a & b invalid)',
            input  => {a=>1.1, b=>undef},
            schema => $sch,
            valid  => 0,
        },
        {
            name   => 'keys: (nok, extra)',
            input  => {a=>1, b=>1.1, c=>1},
            schema => $sch,
            valid  => 0,
        },
        {
            name   => 'keys: (ok, extra, restrict=0)',
            input  => {a=>1, b=>1.1, c=>1},
            schema => $sch,
            valid  => 0,
        },
    );


    $sch = [hash => {keys => {a=>"int", b=>["int", default=>2]}}];
    push @res, (
        {
            name   => 'keys (create_default=1) 1',
            input  => {},
            schema => $sch,
            valid  => 1,
            output => {b=>2},
        },
        {
            name   => 'keys (create_default=1) 2',
            input  => {b=>undef},
            schema => $sch,
            valid  => 1,
            output => {b=>2},
        },
    );
    $sch = [hash => {keys => {a=>"int", b=>["int", default=>2]},
                     "keys.create_default" => 0}];
    push @res, (
        {
            name   => 'keys (create_default=0) 1',
            input  => {},
            schema => $sch,
            valid  => 1,
            output => {},
        },
        {
            name   => 'keys (create_default=0) 2',
            input  => {b=>undef},
            schema => $sch,
            valid  => 1,
            output => {b=>2},
        },
    );

    # XXX re_keys
    # XXX req_keys
    # XXX allowed_keys
    # XXX allowed_keys_re

    @res;
}

sub gen_bool_tests {
    my %args = @_;
    my @res;

    # XXX how to dump YAML's boolean?

    local $Type = "bool";

    (
        gen_type_check_tests(
            accept => [0, 1],
            reject => [[], {}], # in perl, "a", -2, 3.4 are ok
        ),
        gen_BaseType_tests(
            value => 1,
            ok_defaults  => [1],
            nok_defaults => [[]],
            # perl-specific, no real bool value
            #ok_clauses   => [[is_true=>1], [is=>1]],
            #nok_clauses  => [[is_true=>0], [is=>0]],
        ),
        gen_err_level_tests(
            clause    => 'is',
            cval      => 1,
            ok_value  => 1,
            nok_value => 0,
        ),
        gen_Comparable_tests(
            values => [0, 1],
        ),
        gen_Sortable_tests(
            values => [0, 1, 1],
        ),

        {
            name   => 'is_true: 1 (ok)',
            input  => 1,
            schema => [$Type => is_true => 1],
            valid  => 1,
        },
        {
            name   => 'is_true: 1 (nok)',
            input  => 0,
            schema => [$Type => is_true => 1],
            valid  => 0,
        },
        {
            name   => 'is_true: 0 (ok)',
            input  => 0,
            schema => [$Type => is_true => 0],
            valid  => 1,
        },
        {
            name   => 'is_true: 0 (nok)',
            input  => 1,
            schema => [$Type => is_true => 0],
            valid  => 0,
        },
        {
            name   => 'is_true: undef (ok 1)',
            input  => 0,
            schema => [$Type => is_true => undef],
            valid  => 1,
        },
        {
            name   => 'is_true: undef (ok 2)',
            input  => 1,
            schema => [$Type => is_true => undef],
            valid  => 1,
        },
    );
}

sub gen_any_tests {
    my %args = @_;
    my @res;

    local $Type = "any";

    (
        {
            name   => 'of (nok + nok)',
            input  => 3,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 0,
        },
        {
            name   => 'of (ok + nok)',
            input  => 2,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 1,
        },
        {
            name   => 'of (nok + ok)',
            input  => 5,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 1,
        },
        {
            name   => 'of (ok + ok)',
            input  => 10,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 1,
        },
    );
}

sub gen_all_tests {
    my %args = @_;
    my @res;

    local $Type = "all";

    (
        {
            name   => 'of (nok + nok)',
            input  => 3,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 0,
        },
        {
            name   => 'of (ok + nok)',
            input  => 2,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 0,
        },
        {
            name   => 'of (nok + ok)',
            input  => 5,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 0,
        },
        {
            name   => 'of (ok + ok)',
            input  => 10,
            schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
            valid  => 1,
        },
    );
}

{
    my $now = localtime();
    local $YAML::Syck::Headless = 1;
    local $YAML::Syck::ImplicitTyping = 1;
    for my $type (qw(int float array str hash bool any all)) {
        my $v = "v$VERSION (generated by $0 on $now)",
        my $f = "gen_${type}_tests";
        no strict 'refs';
        write_file(
            "$Bin/../share/spectest/10-type-$type.yaml",
            Dump({version => $v, tests => [$f->()]}),
        );
    }
}
