package Image::DS9::PConsts;

# ABSTRACT: Internal Constants

use v5.10;

use strict;
use warnings;
use overload ();

use Data::Visitor::Tiny ();
use Ref::Util qw( is_regexpref is_coderef is_blessed_ref is_ref is_arrayref is_refref is_scalarref);
use Scalar::Util 'reftype';

our $VERSION = 'v1.0.0';

use Types::TypeTiny 'is_StringLike';

use Image::DS9::Util 'is_TODO';

use Image::DS9::Constants::V1
  'COLORS',
  'FRAME_COORD_SYSTEMS',
  'SKY_COORD_SYSTEMS',
  'ANGULAR_UNITS',
  'ANGULAR_FORMATS',
  'WCS';

use parent 'Exporter';
use Safe::Isa;

## no critic (Modules::ProhibitAutomaticExportation)
our @EXPORT = qw(
  %TypeCvt

  T_ANGLE_UNIT
  T_ARRAY
  T_BOOL
  T_COLOR
  T_COORD
  T_COORDSYS
  T_EPHEMERAL
  T_FALSE
  T_FLOAT
  T_HASH
  T_INT
  T_JPEG_FILE
  T_OTHER
  T_PDL
  T_REWRITE
  T_SEXAGESIMAL_DEC
  T_SEXAGESIMAL_RA
  T_SKYFORMAT
  T_SKYFRAME
  T_STRING
  T_STRING_NL
  T_STRING_QUOTE
  T_STRING_STRIP
  T_TIFF_FILE
  T_WCSS
  T_WCS_ARRAY
  T_WCS_HASH
  T_WCS_SCALARREF

  ANGLE_UNIT
  BOOL
  BOOL_FALSE
  COLOR
  COORDSYS
  COORD_DEC
  COORD_RA
  FILENAME
  FLOAT
  HASH
  INT
  JPEG_FILE
  PDL
  QARGS
  QATTR
  QNONE
  QONLY
  QYES
  SCALARREF
  SEXAGESIMAL_DEC
  SEXAGESIMAL_RA
  SKYFORMAT
  SKYFRAME
  STRING
  STRING_NL
  STRING_QUOTE
  STRING_STRIP
  TIFF_FILE
  WCSS
  WCS_ARRAY
  WCS_HASH
  WCS_SCALARREF

  tokenize
  ENUM
  ARRAY
  EPHEMERAL
  REWRITE
);


our $FLOAT;
our $SEXAGESIMAL_RA;
our $SEXAGESIMAL_DEC;
our $TRUE;
our $FALSE;

BEGIN {

    $FLOAT           = qr/[+-]?(?:\d+[.]?\d*|[.]\d+)(?:[eE][+-]?\d+)?/;
    $SEXAGESIMAL_DEC = qr/[+-]?\d{2}:\d{2}:\d{2}(?:.\d+)?/;
    $SEXAGESIMAL_RA  = qr/\d{2}:\d{2}:\d{2}(?:.\d+)?/;

    $TRUE  = qr/1|yes|true/i;
    $FALSE = qr/0|no|false/i;
}


use enum qw( CvtSet CvtGet );

# mustn't be 0
use enum (
    ':T_=1',
    'ANGLE_UNIT',
    'ARRAY',
    'BOOL',
    'COLOR',
    'COORD',
    'COORDSYS',
    'EPHEMERAL',
    'FALSE',
    'FLOAT',
    'HASH',
    'INT',
    'JPEG_FILE',
    'OTHER',
    'PDL',
    'REWRITE',
    'SCALARREF',
    'SEXAGESIMAL_DEC',
    'SEXAGESIMAL_RA',
    'SKYFORMAT',
    'SKYFRAME',
    'STRING',
    'STRING_NL',       # trailing \n added on output if necessary
    'STRING_QUOTE',    # wrap string with quote chars
    'STRING_STRIP',    # strip blanks from string on set
    'TIFF_FILE',
    'WCSARRAY',
    'WCSHASH',
    'WCSS',
    'WCS_SCALARREF',
);

## no critic (Modules::ProhibitMultiplePackages)
## no critic (ClassHierarchies::ProhibitExplicitISA)

# These should be split out, but at the moment they require constants
# from Pconsts, and the tokens are defined in Pconsts, so there's a
# circular import loop.

{
    package    #
      Image::DS9::Parser::Token;
    use Ref::Util ();
    sub new {
        my ( $class, %fields ) = @_;

        unless ( Ref::Util::is_ref( $fields{check} ) ) {
            my $check = $fields{check};
            $fields{check} = sub { $_[0] eq $check ? \$_[0] : undef };
        }
        return bless \%fields, $class;
    }
    sub check {
        $_[0]{check}->( $_[1] );
    }

    sub extra { $_[0]{extra} }
    sub name  { $_[0]{name} }
    sub tag   { $_[0]{tag} }
    sub value { $_[0]{value} }
    sub desc  { $_[0]{desc} }

    sub to_string {
        my $self = shift;
        die sprintf( q{%s (%s) didn't implement 'to_string'}, Scalar::Util::blessed( $self ), $self->name );
    }

    sub is_ephemeral { $_[0]{tag} eq Image::DS9::PConsts::T_EPHEMERAL }
    sub is_rewrite   { $_[0]{tag} eq Image::DS9::PConsts::T_REWRITE }


    sub cvt_from_get {
        my $self = shift;
        die unless @_;

        my $valref = shift;
        return Image::DS9::PConsts::type_cvt( Image::DS9::PConsts::CvtGet, $self->tag, $valref );
    }

    sub cvt_for_set {
        my $self = shift;
        die unless @_;

        my $valref = shift;
        return Image::DS9::PConsts::type_cvt( Image::DS9::PConsts::CvtSet, $self->tag, $valref );
    }

    sub _arg_names {
        return ( 'name', 'value', 'tag', 'desc' );
    }


    sub _extract_args {
        my ( $class, $args ) = @_;

        my %args = map { $_ => delete $args->{$_} } $class->_arg_names;

        if ( keys %$args ) {
            require Data::Dump;
            die(
                sprintf(
                    q{%s doesn't support extra args: %s\n%s},
                    $class,
                    Data::Dump::pp( [%$args] ),
                    Data::Dump::pp( [ \%args ] ),
                ) );
        }

        my @missing = grep !exists $args{$_}, keys %args;
        die( 'missing args: ' . join( ', ', @missing ) ) if @missing;

        return %args;
    }

}


{
    package    #
      Image::DS9::Parser::Token::Enum;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        $args{name} //= 'ENUM';
        %args = $class->_extract_args( \%args );

        die( 'value must be an arrayref' ) unless Ref::Util::is_arrayref( $args{value} );

        my $check = join( q{|}, q{}, ( map { lc $_ } @{ $args{value} } ), q{} );

        return $class->SUPER::new(
            %args,
            check => sub {
                index( $check, q{|} . lc( $_[0] ) . q{|} ) > -1 ? \$_[0] : undef;
            },
        );
    }

    sub to_string {
        my $self = shift;
        return '( ' . join( ' | ', map { "'$_'" } sort @{ $self->value } ) . ' )';
    }

}

{
    package    #
      Image::DS9::Parser::Token::Regexp;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        %args = $class->_extract_args( \%args );
        my $qr = delete $args{value};

        $qr = qr/^(?:$qr)$/;

        return $class->SUPER::new(
            %args,
            value => $qr,
            check => sub { $_[0] =~ $qr ? \$_[0] : undef },
        );

    }

    sub to_string {
        my $self = shift;
        return q{} . $self->value;
    }

}

{
    package    #
      Image::DS9::Parser::Token::Constant;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        %args = $class->_extract_args( \%args );

        my $constant = $args{value};
        return $class->SUPER::new( %args, check => sub { $_[0] eq $constant ? \$_[0] : undef }, );
    }

    sub to_string {
        my $self = shift;
        return q{'} . $self->value . q{'};
    }

}

{
    package    #
      Image::DS9::Parser::Token::Rewrite;

    our @ISA = ( 'Image::DS9::Parser::Token::Constant' );

    sub _arg_names {
        my $class = shift;
        return ( $class->SUPER::_arg_names, 'extra' );
    }

    sub new {
        my ( $class, %args ) = @_;
        return $class->SUPER::new( %args );
    }

}


{
    package    #
      Image::DS9::Parser::Token::Code;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        %args = $class->_extract_args( \%args );

        my $code = $args{value};
        return $class->SUPER::new( %args, check => sub { $code->( $_[0] ) ? \$_[0] : undef }, );
    }

    sub to_string {
        my $self = shift;
        return $self->desc // $self->name;
    }
}

{
    package    #
      Image::DS9::Parser::Token::Object;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %attr ) = @_;

        %attr = $class->_extract_args( \%attr );
        my $object = $attr{value};

        return $class->SUPER::new(
            %attr,
            check => sub {
                $object->check( $_[0] );
            },
        );
    }

    sub to_string {
        my $self = shift;
        return $self->value->to_string;
    }


}

sub ENUM {
    my $name = is_scalarref( $_[0] )  ? ${ shift @_ } : undef;
    my $desc = is_scalarref( $_[-1] ) ? ${ pop @_ }   : undef;

    return Image::DS9::Parser::Token::Enum->new(
        tag   => T_STRING,
        desc  => defined $desc ? "$desc:STRING" : undef,
        name  => $name // 'ENUM',
        value => [@_],
    );
}

sub FILENAME {
    my $name = is_scalarref( $_[0] )  ? ${ shift @_ } : undef;
    my $desc = is_scalarref( $_[-1] ) ? ${ pop @_ }   : undef;

    return Image::DS9::Parser::Token::Code->new(
        tag   => T_STRING,
        desc  => defined $desc ? "<$desc>:STRING" : '<filename>:STRING',
        name  => $name // 'FILENAME',
        value => \&is_StringLike,
    );
}


sub token {
    my ( $name, $tag, $value, $desc ) = @_;

    my $class
      = is_regexpref( $value )   ? 'Image::DS9::Parser::Token::Regexp'
      : is_coderef( $value )     ? 'Image::DS9::Parser::Token::Code'
      : is_blessed_ref( $value ) ? 'Image::DS9::Parser::Token::Object'
      : is_arrayref( $value )    ? 'Image::DS9::Parser::Token::Enum'
      :                            'Image::DS9::Parser::Token::Constant';

    ## no critic( TestingAndDebugging::ProhibitNoStrict )
    no strict 'refs';
    *{$name} = sub {

        my $ndesc = shift;

        my $type = $desc // $name;

        $class->new(
            name  => $name,
            tag   => $tag,
            value => $value,
            desc  => defined $ndesc ? "$ndesc:$type" : $desc,
        );
    };
}

sub _visit {
    my ( $key, $vref, $context ) = @_;

    # don't touch scalars which don't hold types
    return if index( '|query|bufarg|cvt|chomp|retref|', "|$key|" ) != -1;

    my $attrs = $context->{attrs} //= [];
    pop @{$attrs} while @{$attrs} && $attrs->[-1]{depth} > $context->{_depth};

    # top 'attrs' arrayref or a sub-array in an attrs arrayref.
    if ( is_arrayref( $_ ) && ( $_[0] eq 'attrs' || @{$attrs} ) ) {
        push @{$attrs}, { depth => $context->{_depth} + 1 };
        return;
    }

    # in all arrays below an attrs key, the arrays elements
    # are ordered as (key, value), pairs
    return if @{$attrs} && !( $key % 2 );
    return if is_ref( $_ );

    ${$vref} = Image::DS9::Parser::Token::Constant->new(
        name  => 'STRING',
        tag   => T_STRING,
        value => $_
    );
}


sub tokenize {
    my ( %hash ) = @_;

    Data::Visitor::Tiny::visit( $_, \&_visit ) for grep { !is_TODO( $_ ) } values %hash;

    return %hash;
}


token ANGLE_UNIT => ( T_ANGLE_UNIT, ENUM( ANGULAR_UNITS ) );

token BOOL => ( T_BOOL, sub { $_[0] =~ /$TRUE|$FALSE/ or $_[0] == !!0 or $_[0] == !!1 }, 'BOOL' );
token COLOR => ( T_COLOR, ENUM( COLORS ) );

token COORD_RA  => ( T_COORD, qr/$FLOAT|$SEXAGESIMAL_RA/,  'DECIMAL_OR_SEXAGESIMAL' );
token COORD_DEC => ( T_COORD, qr/$FLOAT|$SEXAGESIMAL_DEC/, 'DECIMAL_OR_SEXAGESIMAL' );

token COORDSYS => ( T_COORDSYS, ENUM( FRAME_COORD_SYSTEMS ), 'FRAME_COORD_SYSTEMS' );

token FLOAT => ( T_FLOAT, $FLOAT, 'FLOAT' );
token HASH  => ( T_HASH,  sub { 'HASH' eq ref $_[0] } );
token INT   => ( T_INT,   qr/[+-]?\d+/, 'INTEGER' );

token JPEG_FILE => ( T_JPEG_FILE, qr/[.]jpe?g$/, '*.jpeg|*.jpg' );


token STRING       => ( T_STRING,       \&is_StringLike );
token STRING_STRIP => ( T_STRING_STRIP, \&is_StringLike, 'STRING' );
token STRING_QUOTE => ( T_STRING_QUOTE, \&is_StringLike, 'STRING' );
token STRING_NL    => ( T_STRING_NL,    \&is_StringLike, 'STRING' );

token PDL => ( T_PDL, sub { $_[0]->$_isa( 'PDL' ) } );

token SCALARREF => ( T_SCALARREF, sub { !ref $_[0] || 'SCALAR' eq ref $_[0] } );

token SEXAGESIMAL_RA  => ( T_SEXAGESIMAL_RA,  $SEXAGESIMAL_RA,  'SEXAGESIMAL' );
token SEXAGESIMAL_DEC => ( T_SEXAGESIMAL_DEC, $SEXAGESIMAL_DEC, 'SEXAGESIMAL' );

token SKYFORMAT => ( T_SKYFORMAT, ENUM( ANGULAR_FORMATS ) );
token SKYFRAME  => ( T_SKYFRAME,  ENUM( SKY_COORD_SYSTEMS ) );

token TIFF_FILE => ( T_TIFF_FILE, qr/[.]tiff$/, '*.tiff' );

token BOOL_FALSE    => ( T_FALSE,         sub { $_[0] =~ /$FALSE/ or $_[0] == !!0 } );
token WCS_HASH      => ( T_WCSHASH,       sub { 'HASH' eq ref $_[0] } );
token WCS_ARRAY     => ( T_WCSARRAY,      sub { 'ARRAY' eq ref $_[0] } );
token WCS_SCALARREF => ( T_WCS_SCALARREF, sub { !ref $_[0] || 'SCALAR' eq ref $_[0] } );

token WCSS => ( T_WCSS, ENUM( WCS ), 'WCS system' );

use enum (
    'ENUM:',       # set to zero
    'QNONE',       # no query
    'BITMASK:',    # start creating bitmasks
    'QARGS',       # only query, must have the specified args
    'QATTR',       # query may have attributes
    'QONLY',       # only query, no args
    'QYES',        # can query, no arguments
);

sub _croak {
    require Carp;
    my $fmt = shift;
    @_ = sprintf( $fmt, @_ );
    goto \&Carp::croak;
}


# it's an array type, with the passed number of elements
sub ARRAY {
    my ( $min, $max ) = @_;

    ## no critic (ControlStructures::ProhibitCascadingIfElse)

    my $sub = do {

        # no args, don't care about size
        if ( 0 == @_ ) {
            sub { 'ARRAY' eq ref $_[0] };
        }

        # ($fixed_size)
        elsif ( 1 == @_ ) {
            sub {
                'ARRAY' eq ref $_[0]
                  && $min == @{ $_[0] };
            };
        }

        # (0,$max)
        elsif ( 0 == $min ) {
            sub {
                'ARRAY' eq ref $_[0]
                  && @{ $_[0] } <= $max;
            };
        }


        # ($min, -1) => lower limit only
        elsif ( -1 == $max ) {
            sub {
                'ARRAY' eq ref $_[0]
                  && $min <= @{ $_[0] };
            };
        }

        # ($min,$max) lower and upper
        else {
            sub {
                'ARRAY' eq ref $_[0]
                  && $min <= @{ $_[0] }
                  && @{ $_[0] } <= $max;
            };
        }
    };

    return Image::DS9::Parser::Token::Code->new(
        name  => 'ARRAY',
        tag   => T_ARRAY,
        value => $sub,
    );
}

sub EPHEMERAL {
    return Image::DS9::Parser::Token::Constant->new(
        name  => 'EPHEMERAL',
        tag   => T_EPHEMERAL,
        value => $_[0],
    );
}

sub REWRITE {
    return Image::DS9::Parser::Token::Rewrite->new(
        name  => 'REWRITE',
        tag   => T_REWRITE,
        value => $_[0],
        extra => \( $_[1] ),
    );
}

sub _to_string {
    my $mth = overload::Method( ${ $_[0] }, q{""} );
    defined $mth ? \( ${ $_[0] }->$mth ) : $_[0];
}

# these must return references!  $_[0] is always a reference;
# return $_[0] if no change
my %TypeCvt = (
    T_BOOL() => [
        # outgoing
        sub {
            \(
                  ${ $_[0] } == !!1 || ${ $_[0] } =~ $TRUE  ? 'yes'
                : ${ $_[0] } == !!0 || ${ $_[0] } =~ $FALSE ? 'no'
                :                                             _croak( 'untranslatable boolean: %s', ${ $_[0] } ),
            );
        },
        # incoming
        sub { \( ${ $_[0] } =~ $TRUE ? !!1 : !!0 ) },
    ],

    T_WCSHASH() => [
        # outgoing
        sub {
            my $wcs  = q{};
            my $href = ${ $_[0] };
            for my $key ( keys %{$href} ) {
                my $val = $href->{$key};

                # remove blank lines
                next if $key eq q{};

                # aggressively remove surrounding apostrophes
                $val =~ s/^'+//;
                $val =~ s/'+$//;

                # remove unnecessary blanks
                $val =~ s/^\s+//;
                $val =~ s/\s+$//;

                # surround all values with apostrophes
                $wcs .= uc( $key ) . ( $val ne q{} ? " = '$val'\n" : "\n" );
            }
            $wcs;
        },

    ],

    T_WCSARRAY() => [
        # outgoing
        sub {
            my $aref = ${ $_[0] };
            my $ret  = join( "\n", @{$aref} ) . "\n";
            $ret =~ s/^\s+//gm;
            $ret =~ s/^\s*\n//gm;
            \$ret;
        },
    ],

    T_WCS_SCALARREF() => [
        sub {
            $_[0] = ${ $_[0] } if is_refref( $_[0] );

            ${ $_[0] } =~ s/^\s+//gm;
            ${ $_[0] } =~ s/^\s*\n//gm;
            $_[0] = \( ${ $_[0] } . "\n" )
              unless substr( ${ $_[0] }, -1, 1 ) eq '\n';
            $_[0];
        },
    ],


    T_ARRAY() => [
        # outgoing; convert from reference to arrayref to arrayref
        sub {
            _croak( 'Expected ref to arrayref, got something else' ) unless reftype( ${ $_[0] } ) eq 'ARRAY';
            ${ $_[0] };
        },

        # incoming
        sub {
            ( my $s = ${ $_[0] } ) =~ s/^\s+//;

            $s =~ s/\s+$//;
            $_[0] = [ split( / /, $s ) ];
            $_[0];
        },
    ],

    # turn it into a number
    T_FLOAT() => [ sub { \( 0+ ${ $_[0] } ) }, sub { \( 0+ ${ $_[0] } ) }, ],
    T_INT()   => [ sub { \( 0+ ${ $_[0] } ) }, sub { \( 0+ ${ $_[0] } ) }, ],

    T_SCALARREF() => [
        # outgoing; convert from reference to scalarref to scalarref
        sub { ${ $_[0] } },
    ],

    T_STRING() => [ \&_to_string, ],

    T_STRING_NL() => [
        sub {
            # this stringifies it if it's an object
            $_[0] = _to_string( $_[0] );
            $_[0] = \( ${ $_[0] } . "\n" )
              unless substr( ${ $_[0] }, -1, 1 ) eq '\n';
            $_[0];
        },
    ],

    T_PDL() => [
        # outgoing; convert from reference to PDL to PDL
        sub { ${ $_[0] } },
    ],

    T_STRING_STRIP() => [
        sub {
            # this stringifies it if it's an object
            ${ $_[0] } =~ s/\s+//g;
            $_[0];
        },
    ],

    # quote string.
    T_STRING_QUOTE() => [
        sub {
            # this stringifies it if it's an object
            my $quote = ${ $_[0] } =~ /[']/ ? q{"} : q{'};
            ${ $_[0] } = $quote . ${ $_[0] } . $quote;
            $_[0];
        },
    ],

);


sub type_cvt {
    my $dir  = shift;
    my $type = shift;

    defined $TypeCvt{$type}[$dir] ? $TypeCvt{$type}[$dir]->( $_[0] )
      : ref( $_[0] )              ? $_[0]
      :                             \( $_[0] );
}

#
# This file is part of Image-DS9
#
# 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
#
1;

__END__

=pod

=for :stopwords Diab Jerius Smithsonian Astrophysical Observatory

=head1 NAME

Image::DS9::PConsts - Internal Constants

=head1 VERSION

version v1.0.0

=head1 SUPPORT

=head2 Bugs

Please report any bugs or feature requests to bug-image-ds9@rt.cpan.org  or through the web interface at: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Image-DS9>

=head2 Source

Source is available at

  https://gitlab.com/djerius/image-ds9

and may be cloned from

  https://gitlab.com/djerius/image-ds9.git

=head1 SEE ALSO

Please see those modules/websites for more information related to this module.

=over 4

=item *

L<Image::DS9|Image::DS9>

=back

=head1 AUTHOR

Diab Jerius <djerius@cpan.org>

=head1 COPYRIGHT AND LICENSE

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

=cut
