File Coverage

blib/lib/Dios/Types.pm

Criterion	Covered	Total	%
statement	545	651	83.7
branch	226	310	72.9
condition	113	198	57.0
subroutine	71	85	83.5
pod	2	2	100.0
total	957	1246	76.8

package Dios::Types;
our $VERSION = '0.000001';

use 5.014; use warnings;
use Carp;
use Scalar::Util qw< reftype blessed looks_like_number openhandle >;
use overload;
use Sub::Uplevel;

$Carp::CarpInternal{'Dios::Types'}=1;

### IF KEYWORDS {
use Keyword::Declare;

### IF KEYWORDS }

my %exportable = ( validate => 1, validator_for => 1 );
sub import {

    # Throw away the package name...
    shift @_;

    # Cycle through each SUB => AS pair...
    while (my ($exported, $export_as) = splice(@_, 0, 2)) {
        # If it's not a rename, don't change the name...
        if ($export_as && $exportable{$export_as}) {
            unshift @_, $export_as;
            undef $export_as;
        }

        # If it's not exported, don't export it...
        croak "Can't export $exported" if !$exportable{$exported};

        # Unrenamed exports are exported under their own names...
        $export_as //= $exported;

        # Do the export...
        no strict 'refs';
        *{caller.'::'.$export_as} = \&{$exported};
    }

### IF KEYWORDS {

    keytype TypeSpec is /
        (?&PerlIdentifier) (?: \[ (?>(?&PPR_balanced_squares)) \])?+
        (?:
            (?&PerlOWS) [&|] (?&PerlOWS)
            (?&PerlIdentifier) (?: \[ (?>(?&PPR_balanced_squares)) \])?+
        )*+
    /x;

    keytype TypeParams is / \[ (?>(?&PPR_balanced_squares)) \] /x;

    # Create a new subtype of a known type, adding a constraint...
    keyword subtype (
                      Ident $new_type,
                 TypeParams $new_type_params = q{},
                        'of',
                   TypeSpec $known_type,
                     'where',
                      Block   $constraint
    ) {
        my $subtype_defn
            = qq{Dios::Types::_define_subtype('$new_type', '$new_type_params', 'Is',        '[$known_type]',  sub $constraint) };
        qq{if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $subtype_defn }; BEGIN{ $subtype_defn }};
    }


    # Alias a new subtype to a known type...
    keyword subtype (
                      Ident $new_type,
                 TypeParams $new_type_params = q{},
                        'of',
                   TypeSpec $known_type,
    ) {
        my $subtype_defn
            = qq{Dios::Types::_define_subtype('$new_type', '$new_type_params', 'Is', '[$known_type]') };
        qq{if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $subtype_defn }; BEGIN{ $subtype_defn }};
    }

### IF KEYWORDS }

}

my @user_defined_type;

### IF KEYWORDS {

sub _define_subtype {
    my ($new_typename, $new_type_params, $old_typename, $old_type_params, $constraint) = @_;
    $constraint //= sub{1};

    local $Dios::Types::lexical_hints = (caller 0)[10] // {};

    # Reassemble the complete base type...
    $old_typename .= $old_type_params;

    # We are building a sub that builds type handlers...
    my $new_type_handler_generator;

    # The simple case (where the new type is not parameterized)...
    if (!length($new_type_params)) {
        my $old_type_handler = _build_handler_for($old_typename);

        $new_type_handler_generator = sub {
            return sub {
                my $okay = $old_type_handler->($_[0]);
                return _error_near($_[0], $new_typename, $okay) if !$okay;
                return _error_near($_[0], $new_typename       ) if !$constraint->(local $_ = $_[0]);
                return 1;
            }
        };
    }

    # The more complex case, where the new type has parameters...
    else {
        # Extract the new parameter names...
        my @new_type_param_names = split /\s*,\s*/, $new_type_params =~ s{\A\[\s*+|\s*+\]\Z}{}grx;

        $new_type_handler_generator = sub {
            my ($typename) = @_;
            my @params = split /\s*,\s*/, $typename =~ s{\A \w++ \[ \s*+ | \s*+ \] \Z}{}grx;
            my $substituted_typename = $old_typename;
            for my $n (0..$#params) {
                $substituted_typename =~ s{$new_type_param_names[$n]}{$params[$n]}gxms;
            }

            my $old_type_handler
                = _build_handler_for($substituted_typename,
                                     "generated by parameterized subtype: $typename\n");

            return sub {
                my $okay = $old_type_handler->($_[0]);
                return _error_near($_[0], $typename, $okay) if !$okay;
                if (! eval{ local $SIG{__WARN__} = sub{}; $constraint->(local $_ = $_[0]) }) {
                    my $constraint_desc = _describe_constraint($_[0], undef, $constraint, $@);
                    return _error_near(
                        $_[0], qq{Value ($_[0]) did not satisfy the constraint: $constraint_desc\n }
                    );
                }
                return 1;
            }
        };
    }

    $^H{"Dios::Types subtype=$new_typename"} = @user_defined_type;
    push @user_defined_type,            $new_type_handler_generator;
}

### IF KEYWORDS }

sub _error_near ($$;$) {
    my ($where, $what, $previous_errors) = @_;

    { package Dios::Types::Error;
      use overload 'bool' => sub{0}, fallback => 1;
      sub msg {
        my $self = shift;
        return $self->[0] ne $self->[-1] ? "$self->[-1]\n(because $self->[0])" : $self->[0];
      }
    }

    $previous_errors = bless [], 'Dios::Types::Error' if (reftype($previous_errors)//q{}) ne 'ARRAY';
    push @{$previous_errors}, _perl($where) . " isn't of type $what";

    return $previous_errors;
}

# Standard type checking...
my %handler_for = (
    # Any Perl value or ref...
    Slurpy     => sub { 1 },
    Any        => sub { 1 },

    # Anything that is true or false (and that's everything in Perl!)
    Bool       => sub { 1 },

    # Anything defined, or not...
    Def        => sub {  defined $_[0] },
    Undef      => sub { !defined $_[0] },
    Void       => sub { !defined $_[0] || ref $_[0] eq 'ARRAY' && !@{$_[0]} },

    # Values, references, and filehandles...
    Value      => sub { defined($_[0]) && !ref($_[0]) },
    Ref        => sub { ref $_[0] },
    IO         => \&openhandle,
    Glob       => sub { ref($_[0]) eq 'GLOB' },

    # An integer...
    Int => sub {
        # If it's an object, must have a warning-less numeric overloading...
        if (ref($_[0])) {
            # Normal references aren't integers...
            return 0 if !blessed($_[0]);

            # Is there an overloading???
            my $converter = overload::Method($_[0],'0+')
                or return 0;

            # Does this object convert to a number without complaint???
            my $warned;
            local $SIG{__WARN__} = sub { $warned = 1 };
            my $value = eval{ $converter->($_[0],undef,undef) }
                // return 0;
            return 0 if $warned;
            return $value =~ m{\A \s*+ [+-]?+ (?: \d++ (\.0*+)?+ | inf(?:inity)?+ ) \s*+ \Z}ixms;
        }

        # Value must be defined, non-reference, looks like an integer...
        return defined($_[0])
            && $_[0] =~ m{\A \s*+ [+-]?+ (?: \d++ (\.0*+)?+ | inf(?:inity)?+ ) \s*+ \Z}ixms;
    },

    # A number
    Num => sub {
        return 0 if !defined $_[0] || lc($_[0]) eq 'nan';
        &looks_like_number
    },

    # A string, or stringifiable object, or array ref, or hash ref, that is empty...
    Empty => sub {
        my $value = shift;

        # Must be defined...
        return 0 if !defined($value);

        # May be an empty array or hash...
        my $reftype = ref($value);
        return 1 if $reftype eq 'ARRAY' && !@{$value};
        return 1 if $reftype eq 'HASH'  && !keys %{$value};

        # May be an object that overloads stringification...
        my $converter = $reftype && overload::Method($value, q{""});
        return 1 if $converter && $converter->($value,undef,undef) eq q{};

        # Otherwise, has to be an empty string...
        return $value eq q{};
    },

    # A string, or stringifiable object...
    Str => sub { defined($_[0]) && (ref($_[0]) ? defined overload::Method(shift,q{""}) : 1) },

    # A blessed object...
    Obj   => \&blessed,

    # Any loaded class (must have @ISA or $VERSION or at least one method defined)...
    Class => sub {
        return 0 if ref $_[0] || not $_[0];
        my $stash = \%main::;
        for my $partial_name (split /::/, $_[0]) {
            return 0 if !exists $stash->{$partial_name.'::'};
            $stash = $stash->{$partial_name.'::'};
        }
        return 1 if exists $stash->{'ISA'};
        return 1 if exists $stash->{'VERSION'};
        for my $globref (values %$stash) {
            return 1 if *{$globref}{CODE};
        }
        return 0;
    },
);

# Built-in type checking...
for my $type (qw< SCALAR ARRAY HASH CODE GLOB >) {
    $handler_for{ ucfirst(lc($type)) } = sub { (reftype($_[0]) // q{}) eq $type };
}
$handler_for{ Regex } = sub { (reftype($_[0]) // q{}) eq 'REGEXP' };
$handler_for{ List  } = $handler_for{ Array };

# Standard type hierrachy...
my %BASIC_NARROWER = (
    Slurpy                           => {                                                               },
        Any                          => { map {$_=>1} qw< Slurpy                                       >},
            Bool                     => { map {$_=>1} qw< Slurpy Any                                   >},
                Undef                => { map {$_=>1} qw< Slurpy Any Bool                              >},
                Def                  => { map {$_=>1} qw< Slurpy Any Bool                              >},
                    Value            => { map {$_=>1} qw< Slurpy Any Bool Def                          >},
                        Num          => { map {$_=>1} qw< Slurpy Any Bool Def Value Str                >},
                            Int      => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Num            >},
                        Str          => { map {$_=>1} qw< Slurpy Any Bool Def Value                    >},
                            Class    => { map {$_=>1} qw< Slurpy Any Bool Def Value Str                >},
                            Empty    => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array List Hash >},
                    Ref              => { map {$_=>1} qw< Slurpy Any Bool Def                          >},
                        Scalar       => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                        Regex        => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                        Code         => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                        Glob         => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                        IO           => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                        Obj          => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                        Array        => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                            List     => { map {$_=>1} qw< Slurpy Any Bool Def Ref Array                >},
                            Empty    => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array Hash List >},
                        Hash         => { map {$_=>1} qw< Slurpy Any Bool Def Ref                      >},
                            Empty    => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array Hash List >},
);

# This is the full typename syntax...
my $BASIC_TYPES = join('|', keys %handler_for);

my $TYPED_OR_PURE_ETC = qr{ \s*+ ,? \s*+ \.\.\.}xms;
my $TYPED_ETC         = qr{         \s*+ \.\.\.}xms;
my $PURE_ETC          = qr{ \s*+ ,  \s*+ \.\.\.}xms;

my $KEYED_TYPENAME = q{
    \\s*
    (?: ' (? [^'\\\\]*+ (?: \\\\. [^'\\\\]*+ )*+ ) '
      |   (? (?&IDENT)                           )
    )
    (? \\s* [?] )?
    (?: \\s* => \\s* (? (?&CONJ_TYPENAME) )  )?
};

my $TYPENAME_GRAMMAR = qr{

    (?
                  (?        (?&QUAL_IDENT)              )
    |   Is    \[  (?   \s*+ (?&DISJ_TYPENAME_BAR)  \s*+ )  \]
    |   Is    \[  (?   \s*+ (?&CONJ_TYPENAME)      \s*+ )  \]
    |   Not   \[  (?    \s*+ (?&DISJ_TYPENAME)      \s*+ )  \]
    |   List  \[  (?   \s*+ (?&DISJ_TYPENAME)      \s*+ )  \]
    |   Array \[  (?  \s*+ (?&DISJ_TYPENAME)      \s*+ )  \]
    |   Tuple \[  (?  \s*+ (?&TUPLE_FORMAT)       \s*+ )  \]
    |   Hash  \[  (?   \s*+ (?&DISJ_TYPENAME) (?: \s*+ => \s*+ (?&DISJ_TYPENAME) )?+ \s*+ )  \]
    |   Dict  \[  (?   \s*+ (?&DICT_FORMAT)        \s*+ )  \]
    |   Ref   \[  (?    \s*+ (?&DISJ_TYPENAME)      \s*+ )  \]
    |   Eq    \[  (?     \s*+ (?&STR_SPEC)           \s*+ )  \]
    |   Match \[  (?  \s*+ (?®EX_SPEC)         \s*+ )  \]
    |   Can   \[  (?    \s*+ (?&OPT_QUAL_IDENT) \s*+ (?: , \s*+ (?&OPT_QUAL_IDENT) \s*+ )*+ ) \]
    |   Overloads \[  (?  [^]]++ )  \]
    |             (?       (?&BASIC)                )
    |             (?        (?!(?&BASIC)) (?&IDENT) (?: \s*+ \[ \s*+ (?&TYPE_LIST) \s*+ \] )?+  )
    )

    (?(DEFINE)

        (? (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )++ )
        (?     (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )*+ )
        (?     (?&ATOM_TYPENAME) (?: \s* [&] \s* (?&ATOM_TYPENAME) )*+ )

        (?
                          (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )++
                        | (?&ATOM_TYPENAME) (?: \s* [&] \s* (?&ATOM_TYPENAME) )++
        )

        (?
            (?&TYPE_LIST) (?: \s*+ ,? \s*+ \.\.\. )?
        )

        (?
            (?&CONJ_TYPENAME) (?: \s*,\s* (?&CONJ_TYPENAME) )*+
        )

        (?
            (?&KEYED_TYPENAME) (?: \s*,\s* (?&KEYED_TYPENAME) )*+  $PURE_ETC?
        )

        (?
            $KEYED_TYPENAME
        )

        (?   (?: [^][\\]++ |  \\[][\\] )*+ )

        (? (?: [^][\\]++ |  \\\S  |  \[ \^? \]? [^]]*+ \] )*+ )

        (? \b (?: $BASIC_TYPES ) \b )

        (?     (?&IDENT) (?: :: (?&IDENT) )++ )

        (? (?&IDENT) (?: :: (?&IDENT) )*+ )

        (? [^\W\d] \w*+ )
    )
}xms;

my $FROM_TYPENAME_GRAMMAR = qr{ (?(DEFINE) $TYPENAME_GRAMMAR ) }xms;

my $IS_REF_TYPE
    = qr/\A (?: List | Array | Hash | Code | Scalar | Regex | Tuple | Dict | Glob | IO | Obj ) \b/x;

# Complex types are built on the fly...
sub _build_handler_for {
    my ($type, $context, $level) = @_;

    # Reformat conjunctions and disjunctions to avoid left recursion...
    if ($type =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z  $FROM_TYPENAME_GRAMMAR }xms) {
        $type = "Is[$1]";
    }

    # Parse the type specification...
    $type =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms
        or croak "Incomprehensible type name: $type\n",
                 (defined $context ? $context : q{});

    my %type_is = %+;

    # Conjunction handlers test each component type and fail if any fails...
    if ( exists $type_is{conj}  ) { my @types = grep {defined} $type_is{conj} =~ m{ ((?&ATOM_TYPENAME))
                                                                                      $FROM_TYPENAME_GRAMMAR
                                                                                  }gxms;
                                        my @handlers = map {_build_handler_for($_)} @types;
                                        return sub {
                                            for (@handlers) {
                                                my $okay = $_->($_[0]);
                                                return _error_near($_[0], join(' or ', @types), $okay)
                                                    if !$okay;
                                            }
                                            return 1;
                                        }
                                  }

    # Disjunction handlers test each component type and fail if all of them fail...
    if ( exists $type_is{disj}  ) { my @types = grep {defined} $type_is{disj} =~ m{ ((?&CONJ_TYPENAME))
                                                                                      $FROM_TYPENAME_GRAMMAR
                                                                                  }gxms;
                                    my @handlers = map {_build_handler_for($_)} @types;
                                    return sub {
                                        for (@handlers) {
                                            return 1 if $_->($_[0]);
                                        }
                                        return _error_near($_[0], join(' or ', @types));
                                    }
                                  }

    # Basic types, just use the built-in handler...
    if ( exists $type_is{basic} ) { return $handler_for{$type_is{basic}}; }

    # User defined types match an object of that type...
    if ( exists $type_is{user}  ) { my $typename = $type_is{user};
                                    my $root_name = $typename =~ s{\[.*}{}rxms;
                                    my $idx = $Dios::Types::lexical_hints->{"Dios::Types subtype=$root_name"};
                                    return sub {
                                        # Is it user-defined???
                                        if (defined $idx) {
                                            for ($_[0]) {
                                                return $user_defined_type[$idx]($typename)($_)
                                                    || _error_near($_[0], $typename);
                                            }
                                        }

                                        return blessed($_[0]) && $_[0]->isa($typename)
                                            || _error_near($_[0], $typename);
                                    }
                                  }

    # Array[T] types require an array ref, whose every element is of type T...
    if ( exists $type_is{array} ) { my $value_handler = _build_handler_for($type_is{array});
                                    return sub {
                                        return _error_near($_[0], "Array[$type_is{array}]")
                                            if (reftype($_[0]) // q{}) ne 'ARRAY';

                                        for (@{$_[0]}) {
                                            next if my $okay = $value_handler->($_);
                                            return _error_near($_, $type_is{array}, $okay);
                                        }

                                        return 1;
                                    }
                                  }

    # List[T] types require an array ref, whose every element is of type T...
    if ( exists $type_is{list} ) { my $value_handler = _build_handler_for($type_is{list});
                                    return sub {
                                        return _error_near($_[0], "List[$type_is{list}]")
                                            if (reftype($_[0]) // q{}) ne 'ARRAY';

                                        for (@{$_[0]}) {
                                            next if my $okay = $value_handler->($_);
                                            return _error_near($_, $type_is{list}, $okay);
                                        }

                                        return 1;
                                    }
                                  }

    if ( exists $type_is{tuple} ) { my @types
                                        = grep {defined}
                                               $type_is{tuple} =~ m{ ((?&CONJ_TYPENAME) | $TYPED_OR_PURE_ETC )
                                                                        $FROM_TYPENAME_GRAMMAR
                                                                   }gxms;
                                    # Build type handlers for sequence...
                                    my ($final_any, $final_handler);
                                    if (@types > 1 && $types[-1] =~ /^$TYPED_ETC$/) {
                                        pop @types;
                                        $final_handler = _build_handler_for(pop @types);
                                    }
                                    elsif (@types > 0 && $types[-1] =~ /^$PURE_ETC$/) {
                                        pop @types;
                                        $final_any = 1;
                                        $final_handler = _build_handler_for('Any');
                                    }
                                    my @value_handlers = map {_build_handler_for($_)} @types;

                                    return sub {
                                        my $array_ref = shift;
                                        # Tuples must be array refs the same length as their specifications...
                                        return _error_near($array_ref, "Dict[$type_is{tuple}]")
                                            if (reftype($array_ref) // q{}) ne 'ARRAY'
                                            || !$final_handler && @{$array_ref} != @types;

                                        # The first N values must match the N types specified...
                                        for my $n (0..$#types) {
                                            my $okay = $value_handlers[$n]($array_ref->[$n]);
                                            return _error_near($array_ref, "Dict[$type_is{tuple}]", $okay)
                                                if !$okay;
                                        }

                                        # Succeed at once if no etcetera to test, or it etcetera guaranteed...
                                        return 1 if $final_any || @{$array_ref} == @types;

                                        # Any extra values must match the "et cetera" handler specified...
                                        for my $n ($#types+1..$#{$array_ref}) {
                                            my $okay = $final_handler->($array_ref->[$n]);
                                            return _error_near($array_ref, "Dict[$type_is{tuple}]", $okay)
                                                if !$okay;
                                        }

                                        return 1;
                                    }
                                  }

    # Hash[T] and Hash[T=>T] types require a hash ref, whose every value is of type T...
    my $HASH_KV_SPEC = qr{
        \A
        ((?&BalancedSquareBrackets))
        (?: (=>) (.*) )?+
        \Z

        (?(DEFINE)
            (?
                (?: [^][] | \[ (?&BalancedSquareBrackets) \] )*?
            )
        )
    }xms;
    if ( exists $type_is{hash}  ) { my ($type_k, $arrow, $type_v) = $type_is{hash} =~ $HASH_KV_SPEC;
                                    # Only value type specified...
                                    if (!$arrow) {
                                        $type_k =~ s/\A\s+|\s+\Z//g;
                                        my $value_handler = _build_handler_for($type_k);
                                        return sub {
                                            return _error_near($_[0], "Hash[$type_is{hash}]")
                                                if (reftype($_[0]) // q{}) ne 'HASH';

                                            for (values %{$_[0]}) {
                                                my $okay = $value_handler->($_);
                                                return _error_near($_, $type_is{hash}, $okay)
                                                    if !$okay;
                                            }

                                            return 1;
                                        }
                                    }
                                    # Both key and value type specified...
                                    else {
                                        $type_k =~ s/\A\s+|\s+\Z//g;
                                        $type_v =~ s/\A\s+|\s+\Z//g;
                                        my $key_handler   = _build_handler_for($type_k);
                                        my $value_handler = _build_handler_for($type_v);
                                        return sub {
                                            return _error_near($_[0], "Hash[$type_is{hash}]")
                                                if (reftype($_[0]) // q{}) ne 'HASH';

                                            for (keys %{$_[0]}) {
                                                my $okay = $key_handler->($_);
                                                return _error_near($_, $type_is{hash}, $okay)
                                                    if !$okay;
                                            }

                                            for (values %{$_[0]}) {
                                                my $okay = $value_handler->($_);
                                                return _error_near($_, $type_is{hash}, $okay)
                                                    if !$okay;
                                            }

                                            return 1;
                                        }
                                    }
                                  }

    # Dict[ k => T, k => T, ... ] requires a hash key, with the specified keys type-matched too...
    if ( exists $type_is{dict}  ) { my (%handler_for, @required_keys, $extra_keys_allowed);
                                    while ($type_is{dict} =~ m{ (? $KEYED_TYPENAME)|(? $PURE_ETC)
                                                                    $FROM_TYPENAME_GRAMMAR}gxms
                                    ) {
                                        # Create a type checker for each specified key (once!)...
                                        if (exists $+{keyed}) {
                                            my ($key, $valtype, $optional) = @+{qw< key valtype optional >};
                                            croak qq{Two type specifications for key '$key' },
                                                  qq{in Dict[$type_is{dict}]}
                                                        if exists $handler_for{$key};
                                            $handler_for{$key}
                                                = _build_handler_for($valtype // 'Any');
                                            push @required_keys, $key if !$optional;
                                        }
                                        # And remember whether other keys are allowed...
                                        else {
                                            $extra_keys_allowed = 1;
                                        }
                                    }

                                    # Build type handlers for sequence...
                                    return sub {
                                        my $hash_ref = shift;
                                        # It has to be a hash reference...
                                        return _error_near($hash_ref, "Dict[$type_is{dict}]")
                                            if (reftype($hash_ref) // q{}) ne 'HASH';

                                        # With all the required keys...
                                        for my $key (@required_keys) {
                                            return _error_near($_, "Dict[$type_is{dict}]")
                                                if !exists $hash_ref->{$key};
                                        }

                                        # Each entry has to have a permitted key and the right type of value...
                                        while (my ($key, $value) = each %{$hash_ref}) {
                                            if (exists $handler_for{$key}) {
                                                my $okay = $handler_for{$key}($value);
                                                return _error_near($_, "Dict[$type_is{dict}]", $okay)
                                                    if !$okay;
                                            }
                                            else {
                                                return _error_near($_, "Dict[$type_is{dict}]")
                                                    if !$extra_keys_allowed;
                                            }
                                        }

                                        return 1;
                                    }
                                  }

    # Ref[T] types require a reference, whose dereferenced value is of type T...
    # but with special magic if T is already itself a reference type
    if ( exists $type_is{ref}   ) { my $value_handler = _build_handler_for($type_is{ref});
                                    return $value_handler if $type_is{ref} =~ $IS_REF_TYPE;
                                    return sub {
                                        my $reftype = reftype($_[0]);
                                        return _error_near($_[0], "Ref[$type_is{ref}]")
                                            if !$reftype || $reftype ne 'REF' && $reftype ne 'SCALAR';
                                        my $okay = $value_handler->(${$_[0]});
                                        return $okay ? 1 : _error_near($_[0], "Ref[$type_is{ref}]", $okay)
                                    }
                                  }

    # Not[T] negates the usual test...
    if ( exists $type_is{not}   ) { my $negated_handler = _build_handler_for($type_is{not});
                                    return sub {
                                        my $not_okay = $negated_handler->($_[0]);
                                        return _error_near($_[0], "Not[$type_is{not}]", $not_okay)
                                            if $not_okay;
                                        return 1;
                                    }
                                  }

    # Eq[S] types require a stringifiable, that matches 'S'...
    if ( exists $type_is{eq}    ) { my $str = eval "q[$type_is{eq}]";
                                    return sub {
                                        return 1 if defined $_[0]
                                                 && (!blessed($_[0]) || overload::Method($_[0],q{""}))
                                                 && eval{ "$_[0]" eq $str };
                                        return _error_near($_[0], "Eq[$type_is{eq}]");
                                    }
                                  }

    # Match[R] types require a stringifiable, that matches /R/x...
    if ( exists $type_is{match} ) {
                                    my $regex = eval { qr{$type_is{match}}x };
                                    croak "Invalid regex syntax in Match[$type_is{match}]:\n $@" if $@;
                                    return sub {
                                        return 1 if defined $_[0]
                                                 && (!blessed($_[0]) || overload::Method($_[0],q{""}))
                                                 && eval{ "$_[0]" =~ $regex };
                                        return _error_near($_[0], "Match[$type_is{match}]");
                                    }
                                  }

    # Can[M] types require a class or object with the specified methods...
    if ( exists $type_is{can}   ) { my @method_names = split q{,}, $type_is{can};
                                    s{\s*}{}g for @method_names;
                                    return sub {
                                        return 0 if !blessed($_[0]) && !$handler_for{Class}($_[0]);
                                        for my $method_name (@method_names) {
                                            return _error_near($_[0], "Can[$type_is{can}]")
                                                if !eval{ $_[0]->can($method_name) };
                                        }
                                        return 1
                                    }
                                  }

    # Overloads[O] types require a class or object with the specified overloads...
    if ( exists $type_is{overloads} ) { my @ops = split q{,}, $type_is{overloads};
                                        s{\s*}{}g for @ops;
                                        return sub {
                                            use overload;
                                            return 0 if !blessed($_[0]) && !$handler_for{Class}($_[0]);
                                            for my $op (@ops) {
                                                return _error_near($_[0], "Can[$type_is{overloads}]")
                                                    if !overload::Method($_[0], $op);
                                            }
                                            return 1
                                        }
                                      }

    die "Internal error: could not generate a type from '$type'. Please report this as a bug."
}

sub _complete_desc {
    my ($desc, $value) = @_;
    $desc //= q{Value (%s)};
    my $value_perl = _perl($value);
    return $desc =~ s{(?
}

sub validate {
    my ($typename, $value) = splice(@_,0,2);
    my ($value_desc, @constraints);
    for my $arg (@_) {
        # Subs are undescribed constraints...
        if (ref($arg) eq 'CODE') {
            push @constraints, $arg;
        }

        # Anything else is part of the value description...
        elsif (defined $arg) {
            $value_desc .= $arg;
        }
    }

    # What's happening in the caller's lexical scope???
    local $Dios::Types::lexical_hints = (caller 0)[10] // {};

    # All but the basic handlers are built late, as needed...
    if (!exists $handler_for{$typename}) {
        $handler_for{$typename} = _build_handler_for($typename)
            or die 'Internal error: unable to build type checker. Please report this as a bug.';
    }

    # Either the type matches or we die...
    if (!$handler_for{$typename}($value)) {
        $value_desc = _complete_desc($value_desc, $value);
        croak qq{\u$value_desc}
            . ($value_desc =~ /\s$/ ? q{} : q{ })
            . qq{is not of type $typename};
    }
    return 1 if !@constraints;

    # Either every constraint matches or we die...
    for my $test (@constraints) {
        local $@;

        # If it fails to match...
        if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $value) }) {
            $value_desc = _complete_desc($value_desc, $value);
            my $constraint_desc = _describe_constraint($value, $value_desc, $test, $@);
            croak qq{\u$value_desc}
                . ($value_desc =~ /\s$/ ? q{} : q{ })
                . qq{did not satisfy the constraint: $constraint_desc\n }
        }
    }

    return 1;
}

sub _up_validate {
    my ($uplevels, $typename, $value) = splice(@_,0,3);
    my ($value_desc, @constraints);
    for my $arg (@_) {
        # Subs are undescribed constraints...
        if (ref($arg) eq 'CODE') {
            push @constraints, $arg;
        }

        # Anything else is part of the value description...
        elsif (defined $arg) {
            $value_desc .= $arg;
        }
    }

    # What's happening in the caller's lexical scope???
    local $Dios::Types::lexical_hints = (caller $uplevels)[10] // {};

    # All but the basic handlers are built late, as needed...
    if (!exists $handler_for{$typename}) {
        $handler_for{$typename} = _build_handler_for($typename)
            or die 'Internal error: unable to build type checker. Please report this as a bug.';
    }

    # Either the type matches or we die...
    if (!$handler_for{$typename}($value)) {
        $value_desc = _complete_desc($value_desc, $value);
        croak qq{\u$value_desc}
            . ($value_desc =~ /\s$/ ? q{} : q{ })
            . qq{is not of type $typename};
    }
    return 1 if !@constraints;

    # Either every constraint matches or we die...
    for my $test (@constraints) {
        local $@;

        # If it fails to match...
        if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $value) }) {
            $value_desc = _complete_desc($value_desc, $value);
            my $constraint_desc = _describe_constraint($value, $value_desc, $test, $@);
            croak qq{\u$value_desc}
                . ($value_desc =~ /\s$/ ? q{} : q{ })
                . qq{did not satisfy the constraint: $constraint_desc\n }
        }
    }

    return 1;
}

sub validator_for {
    my $typename = shift;
    my ($value_desc, @constraints);
    for my $arg (@_) {
        # Subs are undescribed constraints...
        if (ref($arg) eq 'CODE') {
            push @constraints, $arg;
        }

        # Anything else is part of the value description...
        elsif (defined $arg) {
            $value_desc .= $arg;
        }
    }

    # What's happening in the caller's lexical scope???
    local $Dios::Types::lexical_hints = (caller 0)[10] // {};

    # All but the basic handlers are built late, as needed...
    if (!exists $handler_for{$typename}) {
        $handler_for{$typename} = _build_handler_for($typename)
            or die 'Internal error: unable to build type checker. Please report this as a bug.';
    }

    # Return the smallest sub that validates the type...
    my $handler = $handler_for{$typename};

    return $handler if !$value_desc && !@constraints;

    return sub {
        return 1 if $handler->($_[0]);

        my $desc = _complete_desc($value_desc, $_[0]);
        croak qq{\u$desc}
            . ($desc =~ /\s$/ ? q{} : q{ })
            . qq{is not of type $typename};
    } if !@constraints;

    return sub {
        # Either the type matches or we die...
        if (!$handler_for{$typename}($_[0])) {
            my $desc = _complete_desc($value_desc, $_[0]);
            croak qq{\u$desc}
                . ($desc =~ /\s$/ ? q{} : q{ })
                . qq{is not of type $typename};
        }
        return 1 if !@constraints;

        # Either every constraint matches or we die...
        for my $test (@constraints) {
            local $@;

            # If it fails to match...
            if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $_[0]) }) {
                my $desc = _complete_desc($value_desc, $_[0]);
                my $constraint_desc = _describe_constraint($_[0], $desc, $test, $@);
                croak qq{\u$desc}
                    . ($desc =~ /\s$/ ? q{} : q{ })
                    . qq{did not satisfy the constraint: $constraint_desc\n }
            }
        }

        return 1;
    }
}

package Dios::Types::TypedArray {
    our @CARP_NOT = ('Dios::Types');
    sub TIEARRAY  { bless [$_[1]], $_[0] }
    sub FETCHSIZE { @{$_[0]} - 1 }
    sub STORESIZE { $#{$_[0]} = $_[1] + 1 }
    sub STORE     { my ($type, $desc, @constraint) = @{$_[0][0]};
                    Dios::Types::_up_validate(1, $type, $_[2], $desc, @constraint);
                    $_[0]->[$_[1]+1] = $_[2];
                    }
    sub FETCH     { $_[0]->[$_[1]+1] }
    sub CLEAR     { @{$_[0]} = $_[0][0] }
    sub POP       { @{$_[0]} > 1 ? pop(@{$_[0]}) : undef }
    sub PUSH      { my $o = shift; push(@{$o}, @_) }
    sub SHIFT     { splice(@{$_[0]},1,1) }
    sub UNSHIFT   { my $o = shift; splice(@$o,1,0,@_) }
    sub EXISTS    { exists $_[0]->[$_[1]+1] }
    sub DELETE    { delete $_[0]->[$_[1]+1] }
    sub EXTEND    { }

    sub SPLICE
    {
        my $ob  = shift;
        my $sz  = @{$ob} - 1;
        my $off = @_ ? shift : 0;
        $off   += $sz if $off < 0;
        my $len = @_ ? shift : $sz-$off;
        return splice(@$ob,$off+1,$len,@_);
    }
}

package Dios::Types::TypedHash {
    our @CARP_NOT = ('Dios::Types');
    sub TIEHASH  { bless [$_[1], {}], $_[0] }
    sub STORE    { my ($type, $desc, @constraint) = @{$_[0][0]};
                   Dios::Types::_up_validate(1, $type, $_[2], $desc, @constraint);
                   $_[0][1]{$_[1]} = $_[2]
                 }
    sub FETCH    { $_[0][1]{$_[1]} }
    sub FIRSTKEY { my $a = scalar keys %{$_[0][1]}; each %{$_[0][1]} }
    sub NEXTKEY  { each %{$_[0][1]} }
    sub EXISTS   { exists $_[0][1]{$_[1]} }
    sub DELETE   { delete $_[0][1]{$_[1]} }
    sub CLEAR    { %{$_[0][1]} = () }
    sub SCALAR   { scalar %{$_[0][1]} }
}

sub _set_var_type {
    my ($type, $varref, $value_desc, @constraint) = @_;
    my $vartype = ref $varref;

    if ($vartype ne 'ARRAY' && $vartype ne 'HASH') {
        croak 'Typed attributes require the Variable::Magic module, which could not be loaded'
            if !eval{ require Variable::Magic };

        Variable::Magic::cast( ${$varref}, Variable::Magic::wizard( set => sub {
            # Code around awkward Object::Insideout behaviour...
            return if ((caller 3)[3]//"") eq 'Object::InsideOut::DESTROY';

            # Code around more awkward Object::Insideout behaviour...
            no warnings 'redefine';
            local *croak = *confess{CODE};
            return if eval { _up_validate(+2, $type, ${$_[0]}, $value_desc, @constraint) };
            die $@ =~ s{\s+at .*}{}r
                   =~ s{[\h\S]*Dios.*}{}gr
                   =~ s{.*\(eval .*}{}gr
                   =~ s{\s*[\h\S]*called at}{ at}r
                   =~ s{.*called at.*}{}gr;
        }));
    }
    elsif ($vartype eq 'ARRAY') {
        return if tied @{$varref};
        tie @{$varref}, 'Dios::Types::TypedArray', [$type, $value_desc, @constraint];
    }
    elsif ($vartype eq 'HASH') {
        return if tied %{$varref};
        tie %{$varref}, 'Dios::Types::TypedHash',  [$type, $value_desc, @constraint];
    }
    else {
        die 'Internal error: argument to _set_var_type() must be scalar, array ref, or hash ref';
    }
}

# Implement return-type checking...
sub _validate_return_type {

    # Type info is first arg (an arrayref), subroutine body is final arg (a sub ref)...
    my ($name, $type, $where) = @{shift()};
    $where //= sub{1};
    my $function = pop;

    # List return context...
    if (wantarray) {
        # Tidy up type...
        $type =~ s{\A Void \| | \| Void \Z}{}xmsg;
        my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1);
        warn sprintf "Call to $name() not in void context at %s line %d\n", (caller 1)[1,2]
            if $void_warning && $type eq 'Void';

        # Execute the subroutine body in (apparently) the right context...
        my @retvals = uplevel 2, $function, @_;

        # Adapt the constraint to produce a more appropriate error message...
        my $listwhere = sub {
            for (@{shift()}) {
                die _describe_constraint($_,undef,$where) if !$where->($_)
            }
            return 1;
        };

        # Validate the return values...
        eval {
            if (@retvals == 1) {
                _up_validate(+1,
                    $type, $retvals[0], $where,
                    "Return value (" . (_perl(@retvals)=~s/^\(|\)$//gr) . ") of call to $name()\n"
                );
            }
            else {
                undef;
            }
        }
        //
        eval {
            _up_validate(+1,
                $type, \@retvals, $listwhere,
                "List of return values (" . (_perl(@retvals)=~s/^\(|\)$//gr) . ") of call to $name()\n"
            )
        }

        # ..or convert the error message to report from the correct line number...
        // die $@ =~ s{\s*+at \S+ line \d++.*+}{sprintf "\nat %s line %d\n", (caller 1)[1,2]}ser;

        # If the return values are valid, return them...
        return @retvals;
    }

    # Scalar context...
    elsif (defined wantarray) {
        # Tidy up type...
        $type =~ s{\A Void \| | \| Void \Z}{}xmsg;
        my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1);
        warn sprintf "Call to $name() not in void context at %s line %d\n", (caller 1)[1,2]
            if $void_warning && $type eq 'Void';

        # Execute the subroutine body in (apparently) the right context...
        my $retval = uplevel 2, $function, @_;

        # Validate the return value...
        eval {
            _up_validate(+1,
                $type, $retval, $where,
                "Scalar return value (" . _perl($retval) . ") of call to $name()\n"
            )
        }
        # ...or convert the error message to report from the correct line number...
        // die $@ =~ s{\s*at \S+ line \d+.*}{sprintf "\nat %s line %d\n", (caller 1)[1,2]}er;

        # If the return value is valid, return it...
        return $retval;
    }

    # Void context...
    else {
        # Execute the subroutine body in (apparently) the right context...
        uplevel 2, $function, @_;

        # Warn about explicit return types in void context, unless return type implies void is okay...
        my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1);
        warn sprintf
            "Useless call to $name() with explicit return type $type\nin void context at %s line %d\n",
            (caller 1)[1,2]
                if $void_warning && !eval{ _up_validate(+1, $type, undef) };

    }
}




# Compare two types...
sub _is_narrower {
    my ($type_a, $type_b, $unnormalized) = @_;

    # Short-circuit on identity...
    return 0 if $type_a eq $type_b;

    # Otherwise, normalize and decompose...
    if (!$unnormalized && $type_a =~ m{\A (?: Ref ) \Z }xms) {
        $type_a = "Ref[Any]";
    }
    elsif (!$unnormalized && $type_a =~ m{\A (?: Array | List ) \Z }xms) {
        $type_a = "Ref[Array[Any]]";
    }
    elsif (!$unnormalized && $type_a eq 'Hash') {
        $type_a = "Ref[Hash[Any]]";
    }
    elsif ($type_a =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z  $FROM_TYPENAME_GRAMMAR }xms) {
        $type_a = "Is[$1]";
    }
    $type_a =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms;  my %type_a_is = %+;

    if (!$unnormalized && $type_b =~ m{\A (?: Ref ) \Z }xms) {
        $type_b = "Ref[Any]";
    }
    elsif (!$unnormalized && $type_b =~ m{\A (?: Array | List ) \Z }xms) {
        $type_b = "Ref[Array[Any]]";
    }
    elsif (!$unnormalized && $type_b eq 'Hash') {
        $type_b = "Ref[Hash[Any]]";
    }
    elsif ($type_b =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z  $FROM_TYPENAME_GRAMMAR }xms) {
        $type_b = "Is[$1]";
    }
    $type_b =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms;  my %type_b_is = %+;

    # If both are basic types, use the standard comparisons...
    if (exists $type_a_is{basic} && exists $type_b_is{basic}) {
        return +1 if $BASIC_NARROWER{$type_b}->{$type_a};
        return -1 if $BASIC_NARROWER{$type_a}->{$type_b};
    }

    # If both are array or hash or reference types, use the standard comparisons on their element-types...
    for my $elem_type (qw< array hash ref >) {
        if (exists $type_a_is{$elem_type} && exists $type_b_is{$elem_type}) {
            return _is_narrower($type_a_is{$elem_type}, $type_b_is{$elem_type}, 'unnormalized');
        }
    }

    # If either type is parameterized, try the generic unparameterized version...
    if ($type_a =~ s{\A(?:List|Array|Hash|Ref|Match|Eq)\K\[.*}{}xms
    ||  $type_b =~ s{\A(?:List|Array|Hash|Ref|Match|Eq)\K\[.*}{}xms) {
        return -1 if $type_a =~ m{\A(?:Match|Eq)\Z} && $BASIC_NARROWER{Class}->{$type_b};
        return +1 if $type_b =~ m{\A(?:Match|Eq)\Z} && $BASIC_NARROWER{Class}->{$type_a};
        return _is_narrower($type_a, $type_b, 'unnormalized');
    }

    # If both are user-defined types, try the standard inheritance hierarchy rules...
    if (exists $type_a_is{user} && exists $type_b_is{user}) {
        return +1 if $type_b->isa($type_a);
        return -1 if $type_a->isa($type_b);
    }

    # Otherwise, unable to compare...
    return 0;
}

# Compare two type signatures (of equal length)...
sub _cmp_signatures {
    my ($sig_a, $sig_b) = @_;

    # Extract named parameters of B...
    state %named_B_for;
    my $named_B =
        $named_B_for{$sig_b} //= { map { $_->{named} ? ($_->{named} => $_) : () } @{$sig_b} };

    # Track relative ordering parameter-by-parameter...
    my $partial_ordering = 0;
    for my $n (0 .. max($#$sig_a, $#$sig_b)) {
        # Unpack the next parameter types...
        my $sig_a_n = $sig_a->[$n] // {};
        my $sig_a_name = $sig_a_n->{named};
        my $sig_b_n = ($sig_a_name ? $named_B->{$sig_a_name} : $sig_b->[$n]) // {};
        my ($type_a, $type_b) = ($sig_a_n->{type} // 'Any', $sig_b_n->{type} // 'Any');

        # Find the ordering of the next parameter pair from the two signatures...
        my $is_narrower = _is_narrower($type_a, $type_b);

        # Tie-break in favour of the type with more constraints...
        if (!$is_narrower && $type_a eq $type_b) {
            my $where_a = $sig_a_n->{where} // 0;
            my $where_b = $sig_b_n->{where} // 0;
            $is_narrower = $where_a > $where_b ? -1
                         : $where_a < $where_b ? +1
                         :                        0;
        }

        # If this pair's ordering contradicts the ordering so far, there is no ordering...
        return 0 if $is_narrower && $is_narrower == -$partial_ordering;

        # Otherwise if there's an ordering, it becomes the "ordering so far"...
        $partial_ordering ||= $is_narrower;
    }

    # If we make it through the entire list, return the resulting ordering...
    return $partial_ordering;
}

# Resolve ambiguous argument lists using Perl6-ish multiple dispatch rules...
use List::Util qw< max first >;
sub _resolve_signatures {
    state %narrowness_for;
    my ($kind, @sigs) = @_;

    # Track narrownesses...
    my %narrower = map { $_ => [] } 0..$#sigs;

    # Compare all signatures, recording definitive differences in narrowness...
    for my $index_1 (0 .. $#sigs) {
        for my $index_2 ($index_1+1 .. $#sigs) {
            my $sig1 = $sigs[$index_1]{sig};
            my $sig2 = $sigs[$index_2]{sig};
            my $narrowness =
                $narrowness_for{$sig1,$sig2} //= _cmp_signatures($sig1, $sig2);

            if    ($narrowness < 0) { push @{$narrower{$index_1}}, $index_2; }
            elsif ($narrowness > 0) { push @{$narrower{$index_2}}, $index_1; }
        }
    }

    # Find the narrowest signature(s)...
    my $max_narrower = max map { scalar @{$_} } values %narrower;

    # If they're not sufficiently narrow, weed out the non-contenders...
    if ($max_narrower < @sigs-1) {
        @sigs = @sigs[ sort grep { @{$narrower{$_}} } keys %narrower ];
    }
    # Otherwise, locate the narrowest...
    else {
        @sigs = @sigs[ first { @{$narrower{$_}} >= $max_narrower } keys %narrower ];
    }

    # Tie-break methods on the class of the variants...
    if ($kind eq 'method' && @sigs > 1) {
        @sigs = sort { $a->{class} eq $b->{class}    ?  0
                     : $a->{class}->isa($b->{class}) ? -1
                     : $b->{class}->isa($a->{class}) ? +1
                     :                                  0
                     } @sigs;
        @sigs = grep { $_->{class} eq $sigs[0]{class} } @sigs;
    }

    return @sigs;
}


sub _describe_constraint {
    my ($value, $value_desc, $constraint, $constraint_desc) = @_;

    # Did the exception provide a constraint description???
    if ($constraint_desc) {
        $constraint_desc =~ s{\b at .* line .*+ \s*+}{}gx;
    }

    # Describe the value that failed...
    $value_desc = _complete_desc($value_desc, $value);

    # Try to describe the constraint by name, if it was a named sub...
    if (!length($constraint_desc//q{}) && eval{ require B }) {
        my $sub_name = B::svref_2object($constraint)->GV->NAME;
        if ($sub_name && $sub_name ne '__ANON__') {
            $sub_name =~ s/[:_]++/ /g;
            $constraint_desc = $sub_name;
        }
    }

    # Deparse the constraint sub (if necessary and possible)...
    if (!length($constraint_desc//q{}) && eval{ require B::Deparse }) {
        state $deparser = B::Deparse->new;
        my ($hint_bits, $warning_bits) = (caller 0)[8,9];
        $deparser->ambient_pragmas(
            hint_bits => $hint_bits, warning_bits => $warning_bits, # '$[' => 0 + $[
        );
        $constraint_desc = $deparser->coderef2text($constraint);
        $constraint_desc =~ s{\s*+ BEGIN \s*+ \{ (?&CODE) \}
                                (?(DEFINE) (? [^{}]*+ (\{ (?&CODE) \} [^{}]*+ )*+ ))}{}gxms;
        $constraint_desc =~ s{(?: (?:use|no) \s*+ (?: feature | warnings | strict ) | die \s*+ sprintf ) [^;]* ;}{}gxms;
        $constraint_desc =~ s{package \s*+ \S+ \s*+ ;}{}gxms;
        $constraint_desc =~ s{\s++}{ }g;
    }
    return $constraint_desc // "$constraint";
}

sub _perl {
    use Data::Dump 'dump';
    dump( map {
            if    (my $tiedclass = tied $_)    { $tiedclass =~ s/=.*//; "<$tiedclass tie>" }
            elsif (my $classname = blessed $_) { "<$classname object>"      }
            else                               { $_ }
          } @_ )
        =~ s{" (< \S++ \s (?:object|tie) >) "}{$1}xgmsr;

}



1; # Magic true value required at end of module
__END__