File Coverage

blib/lib/Types/PDL.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	17	18	94.4
condition	4	4	100.0
subroutine	10	10	100.0
pod			n/a
total	82	83	98.8

package Types::PDL;

# ABSTRACT: PDL types using Type::Tiny

use v5.10;

use strict;
use warnings;

our $VERSION = '0.04';

use Type::Library -base,
  -declare => qw[
    NDArray
    NDArray0D
    NDArray1D
    NDArray2D
    NDArray3D
    NDArrayFromAny
    ],

    # eventually will be deprecated
  qw[
    Piddle
    Piddle0D
    Piddle1D
    Piddle2D
    Piddle3D
    PiddleFromAny
  ];


use Types::Standard -types, 'is_Int';
use Type::Utils;
use Type::TinyX::Facets;
use B qw(perlstring);

sub _croak {
    require Carp;
    goto \&Carp::croak;
}


facet 'empty', sub {
    my ( $o, $var ) = @_;
    return unless exists $o->{empty};
    sprintf( '%s%s->isempty', !!delete( $o->{empty} ) ? '' : '!', $var );
};

facet 'null', sub {
    my ( $o, $var ) = @_;
    return unless exists $o->{null};
    sprintf( '%s%s->isnull', !!delete( $o->{null} ) ? '' : '!', $var );
};

facet ndims => sub {
    my ( $o, $var ) = @_;

    my %o = map { ( $_ => delete $o->{$_} ) }
      grep { exists $o->{$_} } qw[ ndims ndims_min ndims_max ];

    return unless keys %o;

    _croak( "'$_' must be an integer\n" )
      for grep { !is_Int( $o{$_} ) } keys %o;


    if ( exists $o{ndims_max} and exists $o{ndims_min} ) {

        if ( $o{ndims_max} < $o{ndims_min} ) {
            _croak( "'ndims_min' must be <= 'ndims_max'\n" );
        }

        elsif ( $o{ndims_min} == $o{ndims_max} ) {

            _croak(
                "cannot mix 'ndims' facet with either 'ndims_min' or 'ndims_max'\n"
            ) if exists $o{ndims};

            $o{ndims} = delete $o{ndims_min};
            delete $o{ndims_max};
        }
    }

    my @code;

    if ( exists $o{ndims_max} or exists $o{ndims_min} ) {

        if ( exists $o{ndims_min} ) {
            push @code, sprintf( '%s->ndims >= %d', $var, delete $o{ndims_min} );
        }

        if ( exists $o{ndims_max} ) {
            push @code, sprintf ( '%s->ndims <= %d', $var, delete $o{ndims_max} );
        }
    }

    elsif ( exists $o{ndims} ) {
        push @code, sprintf( '%s->ndims == %d', $var, delete $o{ndims} );
    }

    else {
        return;
    }

    _croak( "cannot mix 'ndims' facet with either 'ndims_min' or 'ndims_max'\n" )
      if keys %o;

    return join( ' and ', @code );
};


facet 'type', sub {
    my ( $o, $var ) = @_;
    return unless exists $o->{type};
    my $type = eval { PDL::Type->new( delete $o->{type} )->ioname };
    _croak( "type must be a valid type name or a PDL::Type object: $@\n" )
      if $@;

    sprintf ( '%s->type->ioname eq q[%s]', $var, $type );
};

facet 'shape', sub {
    my ( $o, $var ) = @_;
    return unless exists $o->{shape};

    my $shape = delete $o->{shape};

    _croak( "shape must be a string or an arrayref of specifications" )
      unless 'ARRAY' eq ref $shape or ! ref $shape;

    sprintf( q|join( ',', %s->dims) =~ qr/%s/x|, $var, _mk_shape_regexp( $shape ) );
};

# --------------------------------------------------------------------------#
# eventually will be deprecated

facetize qw[ empty null ndims type shape ], class_type Piddle, { class => 'PDL' };

facetize qw[ null type ], declare Piddle0D, as Piddle [ ndims => 0 ];

facetize qw[ empty null type shape ], declare Piddle1D, as Piddle [ ndims => 1 ];

facetize qw[ empty null type shape ], declare Piddle2D, as Piddle [ ndims => 2 ];

facetize qw[ empty null type shape ], declare Piddle3D, as Piddle [ ndims => 3 ];

declare_coercion PiddleFromAny, to_type Piddle, from Any, q[ do { local $@;
          require PDL::Core;
          my $new = eval { PDL::Core::topdl( $_ )  };
          $@ ? $_ : $new
     }
  ];


# --------------------------------------------------------------------------#

facetize qw[ empty null ndims type shape ], class_type NDArray, { class => 'PDL' };

facetize qw[ null type ], declare NDArray0D, as NDArray [ ndims => 0 ];

facetize qw[ empty null type shape ], declare NDArray1D, as NDArray [ ndims => 1 ];

facetize qw[ empty null type shape ], declare NDArray2D, as NDArray [ ndims => 2 ];

facetize qw[ empty null type shape ], declare NDArray3D, as NDArray [ ndims => 3 ];

declare_coercion NDArrayFromAny, to_type NDArray, from Any, q[ do { local $@;
          require PDL::Core;
          my $new = eval { PDL::Core::topdl( $_ )  };
          $@ ? $_ : $new
     }
  ];


# --------------------------------------------------------------------------#


sub _mk_shape_regexp {

    my $spec = shift;

    # positive integer
    my $int = q/(?:[0123456789]+)/;

    my $re = qr/
               \s*(?:
                   (?:
                       (? $int )
                       |
                       (? X | : ) )
                   (?:
                        (?[*+?])
                    | (?:\{
                                (?$int)
                                (?:(?,) (?$int)? )?
                         \}
                        )
                   )?
               )
               \s*
               /x;

    my @spec;

    if ( !ref $spec ) {
        push @spec, { %+ }  while $spec =~ /\G$re,?/gc;
        _croak( "error in spec starting HERE ==>",
            substr( $spec, pos( $spec ) || 0 ), "<\n" )
          if ( pos( $spec ) || 0 ) != length( $spec );
    }
    else {

        @spec = map {
            _croak( "error parsing spec: >$_<\n" )
              unless /^$re$/;
            +{ %+ }
        } @$spec;
    }


    my @shape;

    for my $spec ( @spec ) {

        my $extent;

        if ( defined $spec->{int} ) {
            $extent = $spec->{int};
            _croak( "extent cannot be zero"  )
              if ( $extent += 0 ) == 0;
        }
        else {
            $extent = $int;
        }

        my $res = "(?:${extent},?)";


        if ( defined $spec->{quant} ) {
            $res .= $spec->{quant};
        }
        elsif ( defined $spec->{min} ) {

                $res .= '{' . $spec->{min};

                $res .= ',' if defined $spec->{comma};
                $res .= $spec->{max} if defined $spec->{max};
                $res .= '}';
            }

        push @shape, $res;
    }

    #  this must be a string!
    return '^' . join( '', @shape ) . '$';
}



1;

#
# This file is part of Types-PDL
#
# This software is Copyright (c) 2017 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__