File Coverage

blib/lib/Dios.pm

Criterion	Covered	Total	%
statement	635	869	73.0
branch	254	362	70.1
condition	100	156	64.1
subroutine	57	58	98.2
pod			n/a
total	1046	1445	72.3

package Dios;
our $VERSION = '0.002012';

use 5.014; use warnings;
use Dios::Types;
use Keyword::Declare;

my $PARAMETER_SYNTAX = qr{
    (?&WS)?+
    (?
        (?
            (?    (?&PerlNumber)     )
        |
            (?    (?&PerlQuotelikeQ) )
        |
            (?  (?&PerlMatch)      )
        )
    |
        # TYPE...
        (? (?&TYPE_SPEC) )?+

        # NAME...
        (?&WS)?+
        (?
            : (? (?&IDENT) ) \( (?&WS)?+
                (? (? [\$\@%]) (?&IDENT) ) (?&WS)?+
            \)
        |
            : (? (? [\$\@%])  (? (?&IDENT) ) )
        |
            \* (?)
            (?:
                (? (? [\@%]) (?&IDENT) )
            |
                : (? (?&IDENT) ) \( (?&WS)?
                    (? (? \@) (?&IDENT) ) (?&WS)?
                \)
            |
                : (? (? \@)  (? (?&IDENT) ) )
            |
                (? (? [\@%]) )
            )
        |
            (? (? [\$\@%]) (?&IDENT) )
        |
            (? (? [\$\@%]?+) )
        )

        # OPTIONAL OR REQUIRED...
        (?: (?  \? ) (?    )
        |   (?      \! )
        )?+

        # CONSTRAINT...
        (?&WS)?+
        (?: where (?&WS)?+ (? (?&PerlBlock) ) )?+

        # READONLY OR ALIAS...
        (?: (?&WS)?+ is (?&WS)?+  (? ro | alias ) )?+

        # DEFAULT VALUE...
        (?: (?&WS)?+ (? (?> // | \|\| )?+ = )
            (?&WS)?+ (? (?&PerlConditionalExpression) ))?+

        (?&WS)?+
    )
    (? , | : | (?= --> ) | \z )

    (?(DEFINE)
        (?  (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
        (?  (?&QUAL_IDENT)  (?&TYPE_PARAM)?+         )
        (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \]   )
        (? (?&IDENT) (?: :: (?&IDENT) )*+           )
        (?      [^\W\d] \w*+                             )
        (?         (\s++ | \# [^\n]*+ \n )++                )
        $PPR::GRAMMAR
    )
}xms;

my $EMPTY_PARAM_LIST = qr{
    \A
    (?&OWS)
    (?:
        \(  (?&OWS)  (\*\@_)?+  (?&OWS)  \)
    )?+
    (?&OWS)
    \z

    (?(DEFINE)
        (? \s*+ (?: \# .* \n \s*+ )*+ )
    )
}xm;

sub _translate_parameters {
    my $params   = shift;
    my $kind     = shift;
    my $sub_name = shift;
    my $sub_name_tidy = $sub_name;
    $sub_name_tidy =~ s{\A \s*+ (?: \# .*+ \n \s*+ )*+ }{}x;

    my @param_names;
    my $sub_desc = $sub_name ? "$kind $sub_name_tidy" : "anonymous $kind";
    my $invocant_name = $^H{'Dios invocant_name'} // '$self';

    # Empty and "standard" parameter lists are easy...
    if (!defined $params || $params =~ $EMPTY_PARAM_LIST) {
        my $std_slurpy = defined $1;
        my $code
            = ($kind eq 'method'
                ? _generate_invocant("method $sub_name_tidy", {var=>$invocant_name, sigil=>'$'})
                : q{}
              )
              . ($std_slurpy ? q{} : qq{Dios::_error(ucfirst(q{$sub_desc takes no arguments})) if \@_;});

        my $spec = ( $kind eq 'method' ? q{ {type=>'Any',    where=[]}, } : q{} )
                 . ( $std_slurpy       ? q{ {optional => 1, type=>'Slurpy', where=>[]} } : q{} );

        return { code => $code, spec => $spec, names=>\@param_names };
    }

    $params =~ s{\A \s*+ \(}{}x;
    $params =~ s{\) \s*+ \z}{}x;

    my $return_type       = undef;
    my $return_constraint = undef;
    my $invocant          = $kind eq 'method' ? $invocant_name : undef;
    my $first_param       = 1;
    my @params;

    while (length($params) && $params =~ s{\A \s*+ $PARAMETER_SYNTAX }{}x) {
        my %param = %+;
        last if $param{raw_param} !~ /\S/;

        # Special case of literal numeric constant as parameter (e.g. multi func fib(0) { 0 } )...
        if (defined $param{is_num_constant}) {
            $param{type} = 'Num';
            $param{constraint} = "{ \$_ == $param{is_num_constant} }";
        }

        # Special case of literal string constant as parameter (e.g. multi func handle_event('add') {...} )...
        elsif (defined $param{is_str_constant}) {
            $param{type} = 'Str';
            $param{constraint} = "{ \$_ eq $param{is_str_constant} }";
        }

        # Special case of literal regex match as parameter (e.g. multi func # handle_event(/a|b/) {...} )...
        elsif (defined $param{is_regex_constant}) {
            $param{type} = 'Str';
            $param{constraint} = "{ \$_ =~ $param{is_regex_constant} }";
        }

        push @params, \%param;

    }

    # Make an implicit invocant explicit...
    if (!@params && $kind eq 'method') {
        "$invocant:" =~ m{\A \s*+ $PARAMETER_SYNTAX }x;
        push @params, {%+};
    }

    # Extract trailing return type specification...
    if ($params =~ s{ (?&WS) --> (?&WS) (.*+) (?(DEFINE) (? \s*+ (\# [^\n]*+ \n \s*+ )*+)) }{}xms ) {
        ($return_type, $return_constraint) = split /\bwhere\b/, $1, 2;
    }

    # Anything else in the parameter list is a mistake...
    _error( qq{Invalid parameter specification: $params\n in $kind declaration} )
        if $params =~ /\S/;

    # Convert the parameters into checking code...
    my $code         = q{};
    my $spec         = q{};
    my $nameless_pos = 0;
    my (%param_named, @positional, @named, $slurpy);

    for my $param (@params) {
        $nameless_pos++;

        # Constraints imply an Any type...
        if (defined $param->{constraint} && (!defined $param->{type} || $param->{type} !~ /\S/)) {
            $param->{type} = 'Any';
        }

        # Rectify nameless params...
        if (exists $param->{nameless}) {
            $param->{sigil} ||= '$';
            my $nth = $nameless_pos
                    . ( $nameless_pos =~ /(?
                      : $nameless_pos =~ /(?
                      : $nameless_pos =~ /(?
                      :                               'th'
                      );
            $param->{var}      = $param->{sigil} . '__nameless_'.$nth.'_parameter__';
            $param->{namedvar} = $param->{sigil} . ' (unnamed $nth parameter)';
        }

        # "There ken be onla one!" (...parameter of any given name)...
        _error( qq{Can't declare two parameters named $param->{var}\n in specification of $sub_desc})
            if exists $param_named{ $param->{var} };
        $param_named{ $param->{var} }++;
        push @param_names, $param->{name} if $param->{name};

        # Parameters are lexical, so can't be named @_ or $_ or %_...
        _error(
            qq{Can't declare a },
            (exists $param->{name} ? 'named' : exists $param->{slurpy} ? 'slurpy' : 'positional'),
            qq{ parameter named $param->{var}\nin specification of $sub_desc},
        ) if substr($param->{var},1) eq '_' && $param->{namedvar} ne '*@_';

        # Handle implicit invocant specially...
        if ($first_param && $kind eq 'method' && $param->{terminator} ne ':') {
            $code .= _generate_invocant( "$sub_desc", {var=>$invocant_name, sigil=>'$'} );
            $first_param = 0;
        }

        # Handle explicit invocant...
        if ($first_param && $param->{terminator} && $param->{terminator} eq ':') {
            _error( qq{Can't specify invocant ($param->{raw_param}:) for $sub_desc} ) if $kind ne 'method';
            $code .= _generate_invocant( "$sub_desc", $param );
            my $type  = $param->{type} // 'Any';
            my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{};
            $spec .= qq{{type => '$type', $constraint },};
            $first_param = 0;
        }

        # Save a scalar (named or positional) paramater...
        elsif (!exists $param->{slurpy}) {
            if (exists $param->{name}) { push @named,      $param }
            else                       { push @positional, $param }
        }

        # Save the final slurpy array or hash...
        else {
            _error( qq{Can't specify more than one slurpy parameter },
                    qq{($slurpy->{namedvar}, $param->{namedvar})\n},
                    qq{ in specification of $sub_desc}
            ) if defined $slurpy;

            if (exists $param->{name}) {
                _error( qq{Can't specify non-array named slurpy parameter ($param->{namedvar})\n},
                        qq{ in specification of $sub_desc}
                ) if exists $param->{name} && $param->{sigil} ne '@';

                push @named, $param;
            }
            else {
                $slurpy = $param;
            }
        }
    }

    if (@positional) {
        $code .= _generate_positionals( "$sub_desc", @positional );
        for my $param (@positional) {
            my $type  = $param->{type}  // 'Any';

            if    ($param->{sigil} eq '@') { $type = "Array[$type]"; }
            elsif ($param->{sigil} eq '%') { $type = "Hash[$type]";  }

            my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{};

            my $is_optional = exists $param->{default_type} ? 1 : 0;

            $spec .= qq{{optional => $is_optional, type => '$type', $constraint},};
        }
    }
    if (@named) {
        $code .= _generate_nameds( "$sub_desc", @named );
        for my $param (@named) {
            my $type  = $param->{type}  // 'Any';

            if    ($param->{sigil} eq '@') { $type = "Array[$type]"; }
            elsif ($param->{sigil} eq '%') { $type = "Hash[$type]";  }

            my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{};

            my $is_optional = exists $param->{default_type} ? 1 : 0;

            $spec .= qq{{named => '$param->{name}', optional => $is_optional, type => '$type', $constraint},};
        }
    }

    if (defined $slurpy) {
        if ($slurpy->{var} ne '@_') {
            my $constraint = $slurpy->{constraint} ? "where => sub $slurpy->{constraint}" : q{};
            $code .= _generate_slurpies( "$sub_desc", $slurpy );
            $spec .= qq{ {optional => 1, type=>'Slurpy', $constraint} };
        }
    }
    else {
        $code .= qq[Dios::_error q{Unexpected extra argument}.(\@_==1?q{}:q{s}).' ('.join(', ', map { Dios::_perl \$_ } \@_).q{) in call to $sub_desc} if \@_;];
    }

    $return_type = defined $return_type ? qq{q{$return_type}} : "";
    if (defined $return_constraint) {
        $return_type .= qq{, sub $return_constraint };
    }
    return { code => $code, return_type => $return_type, spec => $spec, names => \@param_names };
}

sub _verify_required_named {
    my ($context, @params) = @_;
    my $code = q{};
    for my $param (@params) {
        next if !$param->{required};
        my $vardesc = quotemeta $param->{namedvar};
        my $argdesc = qq{'$param->{name}' => <} . lc($param->{type}//'value'). q{>};
        $code .= qq[Dios::_error(qq{No argument ($argdesc) found for required named parameter $vardesc\\n]
              .  qq[in call to $context}) if !\$seen{$param->{name}}; ];
    }
    return $code;
}

sub _generate_invocant {
    my ($context, $param) = @_;
    my $code;
    my $vardesc = qq{invocant $param->{var}};

    # Create and unpack corresponding argument...
    $code .= qq{my $param->{var}; };
    $code .= _unpack_code( @{$param}{'sigil','var','name','default','special'}, $vardesc, $context );

    # Install a type check, if necessary...
    if (exists $param->{type}) {
        $code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context);
    }

    return $code;
}

sub _generate_positionals {
    my ($context, @positionals) = @_;
    my $code;

    for my $param (@positionals) {
        # Create and unpack corresponding argument...
        my $var = $param->{var};
        my $vardesc = $var =~ /^(.)__nameless_(\d++[^\W_]++)_parameter__$/
                        ? "unnamed $2 positional parameter"
                        : "positional parameter $var";
        $code .= qq{my $var; };
        $code .= _unpack_code(
                    @{$param}{'sigil','var','name','default','special'},
                    $vardesc,
                    $context
                 );
        if (exists $param->{name} && exists $param->{default_type}) {
            if ($param->{default_type} eq '//=' && $param->{sigil} eq '$') {
                my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{});
                $code .= qq{ do {$assign_code} if !defined $var; };
            }
            elsif ($param->{default_type} eq '||=') {
                my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{});
                $code .= qq{ do {$assign_code} if !$var; };
            }
        }

        # Install a type check, if necessary...
        next if !exists $param->{type};
        $code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context);
    }

    return $code;
}

sub _generate_nameds {
    my ($context, @nameds) = @_;
    my $code;

    # Declare all named args...
    $code .= 'my (' . join(',', map { $_->{var} } @nameds) . '); ';

    # Walk the arg list, unpacking them...
    $code .= qq[{ my %seen; while (\@_) { my \$next_key = shift;];

    my $defaults = q{};
    for my $param (@nameds) {
        $code .= qq[ if (\$next_key eq q{$param->{name}}) {];
        my $unpack_code =
            exists $param->{slurpy} ? _unpack_named_slurpy_code(
                                        @{$param}{qw< var sigil name special >},
                                        "slurpy named parameter $param->{namedvar}", $context
                                      )
                                    : _unpack_code(
                                        @{$param}{'sigil','var','name'}, undef, $param->{special},
                                        "named parameter $param->{namedvar}", $context
                                      );
        $code .= qq[$unpack_code next}];

        if (exists $param->{name} && exists $param->{default}) {
            my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{});
            $defaults .= qq{ do {$assign_code} if }
                      .  ( $param->{default_type} eq '//=' ? qq{!defined $param->{var}; }
                         : $param->{default_type} eq '||=' ? qq{!$param->{var}; }
                         :                                   qq{!\$seen{$param->{'name'}}; }
                         );
        }
    }

    my $requireds = _verify_required_named($context, @nameds);

    $code .= qq[unshift \@_, \$next_key; last} $defaults $requireds}];

    for my $param (@nameds) {
        next if !exists $param->{type};

        my $slurpy = exists $param->{slurpy} ? q{slurpy } : q{};
        $code .= _typecheck_code(
                @{$param}{'sigil','var','type','constraint'}, "${slurpy}named parameter $param->{namedvar}", $context
        );
    }

    return $code;
}

my $REFALIASING = q{use experimental 'refaliasing'};

sub _generate_slurpies {
    my ($context, $param) = @_;

    # No slurpy by default...
    return q{} if !defined $param;
    my $special = $param->{special};
    my $code = q{};

    my $vardesc = $param->{var} =~ /^(.)__nameless_.*_parameter__$/
                    ? "nameless slurpy parameter (*$1)"
                    : "slurpy parameter *$param->{var}";

    # Check named slurpies...
    if ($param->{sigil} eq '%') {
        $code .= qq{Dios::_error('Final key ('.Dios::dump(\$_[-1]).qq{) for $vardesc is missing its value\\nin call to $context}) if \@_ % 2;}
    }

    # Create and unpack corresponding argument...
    $code .= !$special                         ? qq{                    my $param->{var} =   }
           : $special eq 'ro'                  ? qq{ Const::Fast::const my $param->{var} =>  }
           : $special eq 'alias' && $] < 5.022 ? qq{ Data::Alias::alias my $param->{var} =   }
           : $special eq 'alias'               ? qq{ $REFALIASING;    \\my $param->{var} =\\ }
           : die "Internal error: unknown special trait: is $special";

    $code .= exists $param->{default} ? qq{ (\@_ ? \@_ : $param->{default}); }
           :                            qq{ \@_; };

    # Install a type check, if necessary...
    if (exists $param->{type}) {
        $code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context, 'slurpy');
    }

    # Install existence check, if necessary...
    if (exists $param->{required}) {
        my $vardesc = quotemeta $vardesc;
        $code .= qq[Dios::_error qq{Missing argument for required $vardesc\\nin $context} if !\@_;];
    }

    return $code;
}

sub _assign_value_code {
    my ($sigil, $var, $special, $value_source, $check_type) = @_;
    $special //= q{};

    if ($sigil eq '$') {
        return $special eq 'ro'                  ? qq[ Const::Fast::const($var =>   $value_source); ]
             : $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var =    $value_source ; ]
             : $special eq 'alias'               ? qq[ $REFALIASING;    \\$var = \\($value_source); ]
             :                                     qq[                    $var =    $value_source ; ]
    }

    # Arrays and hashes, need more type-checking...
    if ($sigil eq '@') {
        return qq[ { my \$next_value = $value_source; ]
             . $check_type
             . ( $special eq 'ro'                  ? qq[ Const::Fast::const($var => \@{\$next_value}); ]
               : $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var =  \@{\$next_value} ; ]
               : $special eq 'alias'               ? qq[ $REFALIASING;    \\$var =  \@{\$next_value} ; ]
               :                                     qq[                    $var =  \@{\$next_value} ; ]
               )
             . qq[} ];
    }
    if ($sigil eq '%') {
        return qq[ { my \$next_value = $value_source; ]
             . $check_type
             . ( $special eq 'ro'                  ? qq[ Const::Fast::const($var => \%{\$next_value}); ]
               : $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var =  \%{\$next_value} ; ]
               : $special eq 'alias'               ? qq[ $REFALIASING;    \\$var =  \%{\$next_value} ; ]
               :                                     qq[                    $var =  \%{\$next_value} ; ]
               )
             . qq[} ];
    }
}

sub _unpack_code {
    my ($sigil, $var, $name, $default, $special, $vardesc, $context) = @_;
    state $type_of = { '$' => q{}, '@' => 'ARRAY', '%' => 'HASH' };

    # Set up for readonly or aliasing, if specified...
    if ($special) {
        if ($special eq 'ro') {
            _error(q{'is ro' requires the Const::Fast module (which could not be loaded)})
                if !eval { require Const::Fast; 1 };
        }
        elsif ($special eq 'alias' && $] < 5.022) {
            _error(q{'is alias' requires the Data::Alias module (which could not be loaded)})
                if !eval { require Data::Alias; 1 };
        }
    }

    # Set up for default handling, if specified...
    my $value_source = qq{ ( !\@_ ? Dios::_error(q{No argument found for $vardesc in call to $context}) : shift) };
    my $type_check   = qq[ Dios::_error q{Argument for $vardesc is not \L$type_of->{$sigil}\E ref in call to $context} ]
                     . qq[     if ref(\$next_value) ne '$type_of->{$sigil}';];

    if (defined($default)) {
        $default ||= $sigil eq '$' ? 'undef'
                   : $sigil eq '@' ? '[]'
                   :                 '{}';
        my $and_type_test = $sigil eq '$' ? '' : "&& ref(\$_[0]) eq '$type_of->{$sigil}'";
        $value_source = qq{ \@_ $and_type_test ? shift() : $default };
        $type_check   = q{};
    }

    # Named params have to be tracked, if they have defaults...
    my $note_seen
        = $name ? qq{ Dios::_error(q{Unexpected second value (}.Dios::_perl($var).q{) for named '$name' parameter in call to $context}) if \$seen{$name}; \$seen{$name} = 1; }
                : q{};

    # Return the code...
    return _assign_value_code($sigil, $var, $special, $value_source, $type_check)
         . $note_seen;
}

sub _unpack_named_slurpy_code {
    my ($var, $sigil, $name, $special, $vardesc, $context) = @_;
    $special //= q{};

    # Must be able to use the module, if it's required
    if ($special eq 'alias' && $] < 5.022) {
        _error(q{'is alias' requires the Data::Alias module (which could not be loaded)})
            if !eval { require Data::Alias; 1 };
    }

    # Work out how at unpack the arg
    my $unpack_code
        = $special eq 'alias' && $] >= 5.022 ? qq{use experimental 'refaliasing';\\\$${name}[\@$name]=\\shift;}
        : $special eq 'alias'                ? qq{ Data::Alias::alias( \$${name}[\@$name] = shift); }
        :                                      qq{ push $var, shift; };

    return qq{ Dios::_error q{No argument found for $vardesc in call to $context} if !\@_; }
         . $unpack_code;
}

sub _typecheck_code {
    my ($sigil, $var, $type, $constraint, $vardesc, $context, $is_slurpy) = @_;
    $constraint = $constraint ? "sub $constraint" : q{};

    # Provide a human-readble description for any error message...
    $vardesc = qq{q{Value (%s) for $vardesc}};

    if ($sigil eq '$') {
        return qq[{package Dios::Types; validate(q{$type},         $var,$vardesc,$constraint)}];
    }
    if ($sigil eq '@') {
        return qq[{package Dios::Types; validate(q{List[$type]}, \\$var,$vardesc,$constraint)}] if $is_slurpy;
        return qq[{package Dios::Types; validate(q{Array[$type]},\\$var,$vardesc,$constraint)}];
    }
    if ($sigil eq '%') {
        return qq[{package Dios::Types; validate(q{Hash[$type]}, \\$var,$vardesc,$constraint)}];
    }
    die 'Internal error: unable to generate type checking code';
}

sub _perl {
    use Data::Dump 'dump';
    return dump(@_);
}

our @CARP_NOT = 'Keyword::Declare';
sub _error {
    use Carp;
    croak @_;
}

use re 'eval';
my $FIELD_DEFN = qr{
    (?
        (?&TYPE_SPEC)
    )? \s*+
    (?
        [\$\@%]
    )
    (?
        [.!]?
    )
    (?
        [^\W\d] \w*             # Simple identifier
    )
    (?
        \s+ is \s+ req(?:uired)?
    )?
    (?:
        \s+ is \s+
        (? r[wo] )
    )?
    (?         # repeat to allow 'is' options in either order
        \s+ is \s+ req(?:uired)?
    )?
    (?
        \s*+ : \s*+ (?&ATTR)
        (?:
            (?: \s*+ : \s*+ | \s++) (?&ATTR)
        )*+
    )?
    (?
        .*+
    )

    (?(DEFINE)
        (?  (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
        (?  (?&QUAL_IDENT)  (?&TYPE_PARAM)?+         )
        (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \]   )
        (? (?&IDENT) (?: :: (?&IDENT) )*+ )
        (?      [^\W\d] \w*+                   )
        (?       [^\W\d]\w*+  (?! [(] )         )
    )

}xms;

my $SHARED_DEFN = qr{
    (?
        (?&TYPE_SPEC)
    )?
    \s*+
    (?
        \$ | \@ | \%
    )
    (?
        [.!]?
    )
    (?
        [^\W\d] \w*             # Simple identifier
    )
    (?:
        \s+ is \s+
        (? r[wo] )
    )?
    (?
        .*
    )

    (?(DEFINE)
        (?  (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
        (?  (?&QUAL_IDENT)  (?&TYPE_PARAM)?+         )
        (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \]   )
        (? (?&IDENT) (?: :: (?&IDENT) )*+ )
        (?      [^\W\d] \w*+                   )
    )

}xms;

my $LEXICAL_DEFN = qr{
    (?
        (?&TYPE_SPEC)
    )?
    \s*+
    (?
        \$ | \@ | \%
    )
    (?
        [^\W\d] \w*             # Simple identifier
    )
    (?
        .*
    )

    (?(DEFINE)
        (?  (?&TYPE_NAME) (?: (?: [&|] | => ) (?&TYPE_NAME) )*+ )
        (?  (?&QUAL_IDENT)  (?&TYPE_PARAM)?+         )
        (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \]   )
        (? (?&IDENT) (?: :: (?&IDENT) )*+ )
        (?      [^\W\d] \w*+                   )
    )

}xms;


# These options can be passed in when importing, to change how accessors are generated...
my %OIO_accessor_keyword = (
    'standard' => { rw => 'Std',    ro => 'StdRO' },
    'unified'  => { rw => 'Acc',    ro => 'Get'   },
    'lvalue'   => { rw => 'Lvalue', ro => 'Get'   },
);
  @OIO_accessor_keyword{qw< std       uni      lval   >}
= @OIO_accessor_keyword{qw< standard  unified  lvalue >};

my %OIO_accessor_generate = (
    'standard' => {
        rw => sub { my ($name, $sigil) = @_;
                    my $var = $sigil.$name;
                    my $unpack = $sigil eq '$' ? 'shift' : '@_';
                    return qq{ sub get_$name { shift; $var }
                               sub set_$name { local \$Carp::CarpLevel = 1;
                                               shift;
                                               $var = $unpack;
                                             };
                             };
              },
        ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name;
                    return qq{ sub get_$name { shift; $var } };
              },
    },

    'unified' => {
        rw => sub { my ($name, $sigil) = @_;
                    my $var = $sigil.$name;
                    my $unpack = $sigil eq '$' ? 'shift' : '@_';
                    return qq{ sub $name { local \$Carp::CarpLevel = 1;
                                           shift;
                                           if (\@_) {
                                               $var = $unpack;
                                           }
                                           $var
                                         }; };
              },
        ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name;
                    return qq{ sub $name { shift; $var } };
              },
    },

    'lvalue' => {
        rw => sub { my ($name, $sigil) = @_;
                    my $var = $sigil.$name;
                    return qq{ sub $name :lvalue {
                                    local \$Carp::CarpLevel = 1;
                                    $var
                             }
                           };
              },
        ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name;
                    return qq{ sub $name         { $var } };
                  },
    },
);
  @OIO_accessor_generate{qw< std       uni      lval   >}
= @OIO_accessor_generate{qw< standard  unified  lvalue >};

# Convert a 'has' to an OIO variable declaration with attributes...
sub _compose_field {
    my ($type, $var, $traits, $handles, $initializer, $constraint) = @_;

    # Normalize constraint...
    $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
    if ($constraint && !defined $type) {
        $type = 'Any';
    }

    # Read-only or readwrite???
    my $rw       = $traits =~ /\brw\b/ ? 'rw' : 'ro';
    my $required = $traits =~ /\breq(?:uired)?\b/;

    # Did the user specify a particular kind of accessor generation???
    my $accessor_type = $^H{'Dios accessor_type'};

    # Unpack the parsed components of the field declaration...
    my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms;

    # Adapt type to sigil...
    my $container_type = ($sigil eq '@') ? "Array[".($type//'Any')."]"
                       : ($sigil eq '%') ?  "Hash[".($type//'Any')."]"
                       :                    $type;

    # Is it type-checked???
    my $TYPE_SETUP = q{};
    my $TYPE_VALIDATOR = q{};
    if ($type) {
        state $validator_num = 0; $validator_num++;
        $TYPE_VALIDATOR = qq[ { no warnings; \$Dios::_internal::attr_validator_$validator_num = Dios::Types::validator_for(q{$container_type}, 'Value (%s) for $sigil$name attribute', $constraint ); } ];
        $TYPE_SETUP = qq[ :Type( sub{ \$Dios::_internal::attr_validator_$validator_num->(shift) }) ];
    }

    # Define accessors...
    my $access = $twigil ne '.' ? q{} : $OIO_accessor_keyword{$accessor_type}{$rw}."(Name=>q{$name}) $TYPE_SETUP";

    # Is it a delegated handler???
    my $delegators = '';
    for my $delegation (split /(?&WS) handles (?&WS) (?(DEFINE) (? \s*+ (?: \# [^\n]*+ \n \s*+ )*+ ))/x, $handles) {
        next unless $delegation;
        if ($delegation =~ m{^:(.*)<(.*)>$}xms) {
            $delegators .= " :Handles($1-->$2)";
        }
        else {
            $delegators .= " :Handles($delegation)";
        }
    }

    # Is it initialized???
    my $init = qq{:Arg(Name=>q{$name} } . ($required ? q{, Mandatory=>1)} : q{)} );
    my $INIT_FUNC = q{};

    # Ensure array and hash attrs are initialized...
    if ($sigil =~ /[\@%]/ && (!$initializer || $initializer =~ m{\A \s*+ \z}xms)) {
        $initializer = '//=()';
    }

    # Install the initialization code...
    if ($initializer =~ m{\A \s*+ (? // \s*+ )? = (? .*+ ) }xms) {
        my %init_field = %+;
        my $init_val = $init_field{INIT_VAL};

        # Adapt initializer value to sigil...
           if ($sigil eq '@') { $init_val = "[$init_val]"; }
        elsif ($sigil eq '%') { $init_val = "+{$init_val}";  }

        $init = qq{:DEFAULT(___i_n_i_t__${name}___(\$self)) } . ($init_field{DEFAULT_INIT} ? $init : q{});
        $INIT_FUNC = qq{sub ___i_n_i_t__${name}___ { my (\$self) = \@_; $init_val }};
    }
    else {
        $init .= $initializer;
    }

    # Update the attribute setting code...
    $^H{'Dios attrnames'} .= "$name,";
    if ($sigil eq '$') {
        $^H{'Dios attrs'} .= $] < 5.022 ? qq{alias my \$$name =    \$_Dios__attr_${name}[\${\$_[0]}];}
                                        : qq{   \\ my \$$name = \\ \$_Dios__attr_${name}[\${\$_[0]}];};
    }
    else {
        $^H{'Dios attrs'}
            .= $] < 5.022 ? qq{alias my $sigil$name = $sigil}.qq{{\$_Dios__attr_${name}[\${\$_[0]}]};}
                          : qq{   \\ my $sigil$name =             \$_Dios__attr_${name}[\${\$_[0]}]; };
    }
    # Add type-checking code to alias...
    if ($type) {
        $^H{'Dios attrs'} .= qq{ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for $sigil$name attribute', $constraint ); };
    }

    # Return the converted syntax...
    return qq{ $TYPE_VALIDATOR my \@_Dios__attr_$name : Field $access $delegators $init $TYPE_SETUP; $INIT_FUNC; };
}

# Convert a typed lexical variable...
sub _compose_lexical {
    my ($type, $variable, $constraint) = @_;

    # Normalize constraint...
    $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
    if ($constraint && !defined $type) {
        $type = 'Any';
    }

    # Is it type-checked???
    my $TYPE_SETUP = q{};
    if (defined $type) {
        $TYPE_SETUP  = qq[ Dios::Types::_set_var_type(q{$type}, \\$variable, 'Value (%s) assigned to $variable', $constraint ); ];
    }

    # Return the converted syntax...
    return qq{my $variable; $TYPE_SETUP; $variable = $variable};
}


# Convert a 'shared' to a class attribute...
sub _compose_shared {
    my ($type, $var, $traits, $initializer, $constraint) = @_;

    # Normalize constraint...
    $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
    if ($constraint && !defined $type) {
        $type = 'Any';
    }

    # Did the user specify a particular kind of accessor generation???
    my $accessor_type = $^H{'Dios accessor_type'};

    # Unpack the parsed components of the shared declaration...
    my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms;
    my $rw     = $traits =~ /\brw\b/ ? 'rw' : 'ro';

    # Generate accessor subs...
    my $accessors = $twigil ne '.' ? q{}
                  : $OIO_accessor_generate{$accessor_type}{$rw}->($name, $sigil);

    # Build type checking sub...
    my $type_func = q{};
    if ($type) {
        $type_func = qq[ sub ___t_y_p_e__${name}___ { state \$check = Dios::Types::validator_for(q{$type}, 'Value (%s) for \$$name attribute' ); \$check->($_[0]) } ___t_y_p_e__${name}___($sigil$name); ];
    }
    else {
        $type_func = q{};
    }
    # Is it type-checked???
    my $TYPE_SETUP = q{};
    if ($type) {
        $TYPE_SETUP  = qq[ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for shared $sigil$name attribute', '$sigil', $constraint ); ];
    }

    # Return the converted syntax...
    return qq{my $sigil$name $initializer; $TYPE_SETUP; $accessors};
}



sub _multi_dispatch {
    use Data::Dump 'dump';

    my $subname  = shift;
    my $kind     = shift;
    my @arg_list = @_;

    # Find all possible variants for this call...
    our %multis;
    my @variants = @{ $Dios::multis{$subname} //= [] };

    # But only those in the right hierarchy, if it's a method call
    if ($kind eq 'method') {
        @variants = grep { $arg_list[0]->isa($_->{class}) } @variants;
    }

    # And only those in the right namespace, if it's a function call...
    else {
        my $caller = caller;
        @variants = grep { $_->{class} eq $caller } @variants;
    }

    # Eliminate variants that doen't match the argument list...
    for my $variant (@variants) {
        my $match = eval{ $variant->{validator}(@arg_list) };
        if (defined $match) {
            @{$variant}{ keys %{$match} } = values %{$match};
        }
        else {
            $variant = undef;
        }
    }
    @variants = grep { defined } @variants;

    # If there's only one left, we're done...
    return $variants[0] if @variants == 1;

    # If there isn't one left, we're also done (but not in a good way)...
    return {
        impl => sub { my $args = dump(@arg_list);
                    croak "No suitable '$subname' variant found for call to multi $subname",
                        (($args =~ m{\A \( .* \) \Z}xms) ? $args : qq{($args)});
        },
    } if @variants == 0;

    # There were 2+ left, so pick the one with the most specific signature...
    @variants = Dios::Types::_resolve_signatures($kind, @variants);

    # If there isn't one left, we're also done (but in an even worse way than before)...
    return {
        impl => sub { my $args = dump(@arg_list);
                    croak "Dios: Internal error in dispatch resolution of multi $subname",
                        (($args =~ m{\A \( .* \) \Z}xms) ? $args : qq{($args)});
        },
    } if @variants == 0;

    # Otherwise, return the most specific/earliest...
    return $variants[0];

#====[ NOTE: I still prefer an ambiguity warning, but Perl 6 no longer does that :-( ]=====
#
#    # Otherwise, the call is ambiguous, so report that...
#    return {
#        impl => sub {
#            croak "Ambiguous call to multi '$subname'. Could invoke any of:\n",
#                  map({ my $sig = $_->{sig}; "\t$subname(". join(',',map({$_->{type}} @$sig)) .")\n" } @variants),
#                  "to handle:\n\t$subname(", dump(@arg_list)=~s/^\(|\)$//gr, ")\ncalled";
#        },
#    };
}

keytype ParamList is m{
    \(
        (?:
            (?&Parameter)
            (?:
                (?: (?&PerlOWS) [:,]
                    (?: (?&Parameter) (?&PerlOWS) , )*+
                        (?&Parameter)?+
                )?+
            )?+
        )?+
        (?: (?&PerlOWS) --> [^)]*+ )?+
        (?&PerlOWS)
    \)

    (?(DEFINE)
        (?
            (?&PerlOWS)
            (?:
                # Nameless literal constraint
                (?&PerlNumber) | (?&PerlQuotelikeQ) | (?&PerlMatch)
            |
                (?! , | --> | \) )  # Every component is optional, but there must be at least one

                # TYPE...
                (?: (?&TYPE_SPEC) (?&PerlOWS) )?+

                # NAME...
                (?>
                    : (?&IDENT) \( (?&PerlOWS) [\$\@%] (?&IDENT) (?&PerlOWS) \)
                |
                    :                          [\$\@%] (?&IDENT)
                |
                    \*
                    (?:
                        [\@%] (?&IDENT)?+
                    |
                        : (?&IDENT) \( (?&PerlOWS) \@ (?&IDENT) (?&PerlOWS) \)
                    |
                        :                          \@ (?&IDENT)
                    )
                |
                    [\$\@%] (?&IDENT)?+
                )?+

                # OPTIONAL OR REQUIRED...
                [?!]?+

                # CONSTRAINT...
                (?: (?&PerlOWS) where (?&PerlOWS) (?&PerlBlock) )?+

                # READONLY OR ALIAS...
                (?: (?&PerlOWS) is (?&PerlOWS) (?: ro | alias ) )?+

                # DEFAULT VALUE...
                (?: (?&PerlOWS) (?://|\|\|)? = (?&PerlOWS) (?&PerlConditionalExpression) )?+
            )
        )

        (?  (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
        (?  (?&QUAL_IDENT)  (?&TYPE_PARAM)?+         )
        (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \]   )
        (? (?&IDENT) (?: :: (?&IDENT) )*+           )
        (?      [^\W\d] \w*+                             )
    )
}xms;

sub import {
    my (undef, $opt) = @_;

    # What kind of accessors were requested in this scope???
    $^H{'Dios accessor_type'}
        = $opt->{accessor} // $opt->{accessors} // $opt->{acc} // q{standard};

    # How should the invocants be named in this scope???
    my $invocant_name = $opt->{invocant} // $opt->{inv} // q{$self};
    if ($invocant_name =~ m{\A (\$?+) ([^\W\d]\w*+) \Z}xms) {
        $^H{'Dios invocant_name'} = ($1||'$').$2;
    }
    else {
        _error "Invalid invocant specification: '$invocant_name'\nin 'use Dios' statement";
    }

    # Class definitions are translated to encapsulated packages using OIO...
    keytype Bases is /is (?&PerlNWS) (?&PerlQualifiedIdentifier)/x;
    keyword class (
        QualIdent   $class_name,
        Bases*      @bases,
        Block       $block
    )
    {{{ { package <{$class_name}>; use Object::InsideOut <{ s{^ is (?&WS) (?(DEFINE) (? \s*+ (?: \# .*+ \n \s*+ )*+ ))}{}x for @bases; (@bases ? qq{qw{@bases}} : q{}) }>; do <{ $block }> } }}}

    # Function definitions are translated to subroutines with extra argument-unpacking code...
    keyword func (
        QualIdent   $sub_name       = '',
        ParamList   $parameter_list = '',
        Attributes  $attrs          = '',
        Block       $block
    )
    {
        # Generate code that unpacks and tests arguments...
        $parameter_list = _translate_parameters($parameter_list, func => "$sub_name");

        # Assemble and return the sub definition...
        if (my $return_type = $parameter_list->{return_type}) {
            qq{sub $sub_name $attrs { $parameter_list->{code} Dios::Types::_validate_return_type [q{$sub_name}, $return_type], \@_, sub $block } };
        }
        else {
            ($sub_name ? "sub $sub_name;" : q{} )
            . qq{sub $sub_name $attrs { $parameter_list->{code} do $block } };
        }
    }

    # Multi definitions are translated to subroutines with extra argument-unpacking code...
    keyword multi (
        /method|func/  $type           = 'func',
        QualIdent      $sub_name       = '',
        ParamList      $parameter_list = '',
        Attributes     $attrs          = '',
        Block          $block
    )
    {
        # Generate code that unpacks and tests arguments...
        $parameter_list = _translate_parameters($parameter_list, $type => "$sub_name");
        my $parameter_types = $parameter_list->{spec};

        # Assemble and return the method definition...
        my $code = qq{ BEGIN { *$sub_name = sub { my \$best_variant = Dios::_multi_dispatch('$sub_name', '$type', \@_); \@_ = \@{\$best_variant->{args}//[]}; goto &{\$best_variant->{impl}}; } if ! *${sub_name}{CODE}; } };

        my $multiname = sprintf 'DIOS_multi_%010d', ++$Dios::multinum;

        # Assemble and return the sub definition...
        if (my $return_type = $parameter_list->{return_type}) {
            $code .= qq{sub $multiname; sub $multiname $attrs { local *$multiname = '$sub_name'; $parameter_list->{code}; return { args => \\\@_, impl => sub { local *__ANON__ = '$sub_name'; Dios::Types::_validate_return_type [q{$sub_name}, $return_type], \@_, sub $block } } } };
        }
        else {
            $block = substr($block,1,-1);
            $code .= qq{sub $multiname; sub $multiname $attrs { local *$multiname = '$sub_name'; $parameter_list->{code}; return { args => \\\@_, impl => sub { local *__ANON__ = '$sub_name'; $block } } } };
        }
        $code .= qq{BEGIN{ push \@{ \$Dios::multis{q{$sub_name}} }, { sig => [$parameter_types], class => __PACKAGE__, validator => \\&$multiname }; }};

        return $code;
    }

    # Method definitions are translated to subroutines with extra invocant-and-argument-unpacking code...
    keyword method (
        QualIdent   $sub_name       = '',
        ParamList   $parameter_list = '',
        Attributes  $attrs          = '',
        Block       $block
    )
    {
        # Which kind of aliasing do we need (to create local vars bound to the object's fields)???
        my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'};
        my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{};

        # Generate code that unpacks and tests arguments...
        $parameter_list = _translate_parameters($parameter_list, method => "$sub_name");

        # Assemble and return the method definition...
        ($sub_name ? "sub $sub_name;" : q{} )
        . qq{sub $sub_name $attrs { $attr_binding { $parameter_list->{code}; do $block } } };
    }

    # Submethod definitions are translated like methods, but with special re-routing...
    keyword submethod (
        QualIdent  $sub_name       = '',
        ParamList  $parameter_list = '',
        Attributes $attrs          = '',
        Block      $block
    )
    {
        # Which kind of aliasing do we need (to create local vars bound to the object's fields)???
        my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'};
        my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{};

        # Extract attribute names...
        my %attr_name = map { $_ => 1 } split ',', ($^H{'Dios attrnames'}//q{});

        # Generate the code to unpack and test arguments...
        my $parameter_spec = _translate_parameters($parameter_list, method => "$sub_name");

        # Handle any special submethod names...
        my $init_args = q{};
        if ($sub_name eq 'BUILD') {
            # Extract named args for :InitArgs hash (TODO: this should pull out type/required info too)...

            my $invalid_names
                = join ', ', map { $attr_name{$_} ? ":$_" : () } @{$parameter_spec->{names}};
            if (my $invalid_names = join ', ', map { $attr_name{$_} ? ":$_" : () } @{$parameter_spec->{names}} ) {
                _error("Can't use an attribute name as a parameter name ($invalid_names)\nin submethod BUILD()");
            }

            # Tell OIO about this constructor args...
            $init_args = qq{ BEGIN{ my %$sub_name :InitArgs = map { \$_ => {} } qw{@{$parameter_spec->{names}}}; } };

            # Mark the sub as an initializer
            $attrs .= ' :Private :Init';

            # Repack the arguments from ($self, {attr=>val, et=>cetera}) to ($self, attr=>val, et=>cetera)...
            $attr_binding = q{@_ = ($_[0], %{$_[1]});} . $attr_binding;
        }
        elsif ($sub_name eq 'DESTROY') {
            # Parameter list will never be satisfied (which breaks cleanup), so don't allow it at all...
            return q{die 'submethod DESTROY cannot have a parameter list';}
                if $parameter_list && $parameter_list !~ /^\(\s*+\)$/;

            # Mark it as a destructor...
            $attrs .= ' :Private :Destroy';

            # Rename it so as not to clash with OIO's DESTROY...
            $sub_name = '___DESTROY___';
        }
        else {
            $attr_binding = qq{ if ((ref(\$_[0])||\$_[0]) ne __PACKAGE__) { return \$_[0]->SUPER::$sub_name(\@_[1..\$#_]); } } . $attr_binding;
        }

        # Assemble and return the method definition...
        ($sub_name ? "sub $sub_name;" : q{} )
        . qq{$init_args sub $sub_name $attrs { $attr_binding { $parameter_spec->{code}; do $block } } };
    }

    # Components of variable declaration...
    keytype TypeSpec   is m{ (?&TypeSpec)
                             (?(DEFINE)
                                 (?
                                     (?&TypeName) (?: (?: [&|] | => ) (?&TypeName) )*+
                                 )
                                 (?
                                     \s* (?&TypeName) (?: \s* (?: [&|] | => ) \s* (?&TypeName) )*+ \s*
                                 )
                                 (?
                                     Match \[ [^]]*+ \]
                                 |
                                     (?&PerlIdentifier) \[ (?&TypeSpecSpacey) \]
                                 |
                                     (?&PerlQualifiedIdentifier)
                                 )
                             )
                          }x;
    keytype Var        is / [\$\@%] [.!]?+ (?&PerlIdentifier) /x;
    keytype Traits     is / (?: (?&PerlOWS) is (?&PerlOWS) (?: ro | rw | req(?:uired)? ) )++ /x;
    keytype Handles    is / (?: (?&PerlOWS) handles (?&PerlOWS)
                                (?: (?&PerlIdentifier) | :(?&PerlIdentifier)<(?&PerlIdentifier)> )
                            )++ /x;
    keytype Init       is m{ (?: // )?+ = (?&PerlOWS) (?&PerlExpression) }x;
    keytype Constraint is m{ where (?&PerlOWS) (?&PerlBlock) }x;

    # An attribute definition is translated into an array with a :Field attribute...
    keyword has (
        TypeSpec    $type       = '',
        Var         $variable,
        Constraint  $constraint = '',
        Traits      $traits     = '',
        Handles     $handles    = '',
        Init        $init       = '',
    ) {
        _compose_field($type, $variable, $traits, $handles, $init, $constraint)
    }

    keytype ReadTraits   is / (?&PerlOWS) is (?&PerlOWS) (?: ro | rw ) /x;

    # An attribute definition is translated into an my var with extra code for accessors...
    keyword shared (
        TypeSpec    $type       = '',
        Var         $variable,
        Constraint  $constraint = '',
        ReadTraits  $traits     = '',
        Init        $init       = '',
    ) {
        _compose_shared($type, $variable, $traits, $init, $constraint)
    }

    # An lexical variable definition is translated into a typed lexical...
    keyword lex (TypeSpec? $type, Var $variable, Constraint? $constraint) {
        _compose_lexical($type, $variable, $constraint)
    }


    # Subtypes are handled by Dios::Types...
    keyword subtype {{{ use Dios::Types; subtype }}}

    # Tail recursion is handled as in Perl 6...
    keyword callwith () {{{ goto &{+do{no strict 'refs'; \&{(caller 0)[3]} }} for 1, @_ = grep 1, }}}
    keyword callsame () {{{ goto &{+do{no strict 'refs'; \&{(caller 0)[3]} }}                     }}}

}

1; # Magic true value required at end of module

__END__