Fn.t

use v5.36;
use Test2::V0;

use Types::Common -types;

sub Fn :prototype($$) {
    my ($Args, $Return) = @_;
    unless (ref $Args eq 'ARRAY') {
        Carp::croak "first argument must be an array reference (got $Args)";
    }
    unless ($Return->isa('Type::Tiny')) {
        Carp::croak "second argument must be a type constraint (got $Return)";
    }

    Type::Tiny->new(
        display_name => "Fn @$Args => $Return;",
        constraint => sub {
            my ($sub) = @_;

            my $Type = typed($sub);
            return unless $Type;

            my ($SArgs, $SReturn) = @{$Type->parameters};
            return is_variant(Tuple($SArgs), Tuple($Args))
                && is_covariant($SReturn, $Return);
        },
        parameters => [$Args, $Return],
    );
}

subtest 'is_compatible_fn' => sub {

    subtest '戻り値の型は、covariant' => sub {
        my $Point2D = Dict[ x => Int, y => Int ];
        my $Point3D = Dict[ x => Int, y => Int, z => Int ];

        my $Fn2D = Fn [] => $Point2D;
        my $Fn3D = Fn [] => $Point3D;

        ok is_compatible_fn($Fn2D, $Fn3D), '戻り値の型Point2Dは、Point3Dと互換性がある';
        ok !is_compatible_fn($Fn3D, $Fn2D), '戻り値の型Point3Dは、Point2Dと互換性がない';
    };

    subtest '引数は、variant' => sub {
        my $Fn = Fn [Int, Int] => Int;

        my $Fn0 = Fn [] => Int;
        my $Fn1 = Fn [Int] => Int;
        my $Fn3 = Fn [Int, Int, Int] => Int;

        ok is_compatible_fn($Fn, $Fn0), '引数の型が少なくても互換性がある';
        ok is_compatible_fn($Fn, $Fn1), '引数の型が少なくても互換性がある';
        ok !is_compatible_fn($Fn, $Fn3), '引数の型が多いと互換性はない';
    };

    #    subtest '引数のOptional/Rest' => sub {
    #        my $Fn = Fn [ Int, Int ] => Int;
    #
    #        my $FnOptional = Fn [ Optional[Int], Optional[Int] ] => Int;
    #        my $FnRest = Fn [ Slurpy[ArrayRef[Int]] ] => Int;
    #
    #        ok is_compatible_fn($Fn, $FnOptional);
    #        ok is_compatible_fn($Fn, $FnRest);
    #        ok !is_compatible_fn($FnOptional, $Fn);
    #    };
};

subtest 'is_variant' => sub {
    subtest 'dict' => sub {
        my $DictA = Dict[ a => Str, b => Int, c => Str ];
        my $DictB = Dict[ a => Str, b => Any ];

        ok is_variant($DictA, $DictB), 'DictA is structual subtype of DictB';
        ok !is_variant($DictB, $DictA), 'DictB is not structual subtype of DictA';
    };

    subtest 'tuple' => sub {
        my $TupleA = Tuple[Str, Int, Str];
        my $TupleB = Tuple[Str, Any];

        ok is_variant($TupleA, $TupleB), 'TupleA is structual subtype of TupleB';
        ok !is_variant($TupleB, $TupleA), 'TupleB is not structual subtype of TupleA';
    };
};

subtest 'is_structual_subtype' => sub {
    subtest 'premitive type' => sub {
        ok is_structual_subtype(Str, Str), 'Str is structual subtype of Str';

        ok is_structual_subtype(Str, Any), 'Str is structual subtype of Any';
        ok !is_structual_subtype(Any, Str), 'Any is not structual subtype of Str';

        ok is_structual_subtype(SimpleStr, Str), 'SimpleStr is structual subtype of Str';
        ok !is_structual_subtype(Str, SimpleStr), 'Str is not structual subtype of SimpleStr';

        ok is_structual_subtype(Int, Str), 'Int is structual subtype of Str !! (perl5 feature)';
        ok !is_structual_subtype(Str, Int), 'Str is not structual subtype of Int';
    };
};

done_testing;

use Carp ();
use Scalar::Util ();


# 関数の型の互換性
sub is_compatible_fn {
    my ($Fn1, $Fn2) = @_;
    my ($Args1, $Return1) = @{$Fn1->parameters};
    my ($Args2, $Return2) = @{$Fn2->parameters};

    return is_variant(Tuple($Args1), Tuple($Args2))
        && is_covariant($Return1, $Return2);
}

# 関数の引数の互換性
sub is_variant {
    my ($T1, $T2) = @_;

    if ($T1->is_a_type_of(Tuple)) {
        return unless $T2->is_a_type_of(Tuple);

        my @params1 = @{$T1->parameters};
        my @params2 = @{$T2->parameters};

        return if @params1 < @params2;

        for my $i (0 .. $#params2) {
            return unless is_variant($params1[$i], $params2[$i]);
        }
        return 1;
    }
    elsif ($T1->is_a_type_of(Dict)) {
        return unless $T2->is_a_type_of(Dict);

        my @params1 = @{$T1->parameters};
        my @params2 = @{$T2->parameters};

        return if @params1 < @params2;

        my %params1 = @params1;
        my %params2 = @params2;

        for my $key (keys %params2) {
            return unless is_variant($params1{$key}, $params2{$key});
        }
        return 1;
    }
    else {
        return is_structual_subtype($T1, $T2);
    }
}

sub is_covariant {
    my ($T1, $T2) = @_;
    is_variant($T2, $T1);
}

# 構造的部分型か？
sub is_structual_subtype {
    my ($T1, $T2) = @_;

    if ($T1->is_a_type_of(Dict)) {
        return unless $T2->is_a_type_of(Dict);

        my %params1 = @{$T1->parameters};
        my %params2 = @{$T2->parameters};

        return unless %params1 == %params2;

        for my $key (keys %params2) {
            return unless is_structual_subtype($params1{$key}, $params2{$key});
        }
        return 1;
    }
    elsif ($T1->is_a_type_of(Tuple)) {
        return unless $T2->is_a_type_of(Tuple);

        my @params1 = @{$T1->parameters};
        my @params2 = @{$T2->parameters};

        return unless @params1 == @params2;

        for my $i (0 .. $#params2) {
            return unless is_structual_subtype($params1[$i], $params2[$i]);
        }
        return 1;
    }
    else {
        return $T1->is_strictly_a_type_of($T2) || $T1->is_strictly_subtype_of($T2);
    }
}

my %memo;
sub typed {
    my ($ref, $Type) = @_;

    unless (ref $ref) {
        Carp::croak sprintf("first argument must be a reference (got %s)", _dump($ref));
    }

    my $id = Scalar::Util::refaddr $ref;

    if ($Type) {
        unless (Scalar::Util::blessed $Type && $Type->isa('Type::Tiny')) {
            Carp::croak sprintf("second argument must be a Type::Tiny (got %s)", _dump($Type));
        }

        if (exists $memo{$id}) {
            Carp::croak sprintf("Reference %s is already typed", _dump($ref));
        }

        $memo{$id} = $Type;

        if ($Type->is_a_type_of(Dict)) {
            my %params = @{$Type->parameters};
            for my $key (keys %params) {
                my $F = $params{$key};
                my $value = $ref->{$key};

                if (ref $value) {
                    typed($value, $F);
                }
            }
        }
        elsif ($Type->is_a_type_of(Tuple)) {
            my @params = @{$Type->parameters};
            for my $i (0 .. $#params) {
                my $F = $params[$i];
                my $value = $ref->[$i];

                if (ref $value) {
                    typed($value, $F);
                }
            }
        }
    }

    return $memo{$id};
}