package IMPL::lang;
use strict;
use warnings;

use parent qw(Exporter);
use IMPL::clone qw(clone);
use Scalar::Util qw(blessed);
use POSIX;
use Carp qw(carp);

our @EXPORT      = qw(&is &isclass &typeof &coarsen &coarsen_dt);
our %EXPORT_TAGS = (
    base => [
        qw(
          &is
          &clone
          &isclass
          &typeof
          &ishash
          &isarray
          &isscalar
          &isglob
          )
    ],

    declare => [
        qw(
          &public
          &protected
          &private
          &property
          &static
          &property
          &_direct
          &ACCESS_PUBLIC
          &ACCESS_PROTECTED
          &ACCESS_PRIVATE
          &PROP_GET
          &PROP_SET
          &PROP_OWNERSET
          &PROP_LIST
          &PROP_ALL
          &PROP_RO
          &PROP_RW
          &PROP_DIRECT
          )
    ],
    compare => [
        qw(
          &equals
          &equals_s
          &hashCompare
          )
    ],
    hash => [
        qw(
          &hashApply
          &hashMerge
          &hashDiff
          &hashCompare
          &hashParse
          &hashSave
          )
    ]
);

our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } };

use IMPL::Const qw(:all);

sub is {
    carp "A typename can't be undefined" unless $_[1];
    blessed($_[0]) and $_[0]->isa( $_[1] );
}

sub isclass {
    carp "A typename can't be undefined" unless $_[1];
    local $@;
    eval {not ref $_[0] and $_[0]->isa( $_[1] ) };
}

sub typeof(*) {
    blessed($_[0]);
}

sub isarray {
	not blessed($_[0]) and ref $_[0] eq 'ARRAY';
}

sub ishash {
	not blessed($_[0]) and ref $_[0] eq 'HASH';
}

sub isscalar {
	not blessed($_[0]) and ref $_[0] eq 'SCALAR';
}

sub isglob {
	not blessed($_[0]) and ref $_[0] eq 'GLOB';
}

sub public($) {
    my $info = shift;
    $info->{access} = ACCESS_PUBLIC;
    my $implementor = delete $info->{implementor};
    $implementor->Implement($info);
}

sub private($) {
    my $info = shift;
    $info->{access} = ACCESS_PRIVATE;
    my $implementor = delete $info->{implementor};
    $implementor->Implement($info);
}

sub protected($) {
    my $info = shift;
    $info->{access} = ACCESS_PROTECTED;
    my $implementor = delete $info->{implementor};
    $implementor->Implement($info);
}

sub _direct ($) {
    my $info = shift;
    $info->{direct} = 1;
    return $info;
}

sub property($$) {
    my ($propName,$attributes) = @_;
    
    $attributes = {
        get => $attributes & PROP_GET,
        set => $attributes & PROP_SET,
        isList => $attributes & PROP_LIST
    } unless ref $attributes;
    
    my $class = caller;
     
    return hashMerge (
        $attributes,
        {
            implementor => $class->ClassPropertyImplementor,
            name => $propName,
            class => scalar(caller),
        }
    );
}

sub static($$) {
    my ( $name, $value ) = @_;
    my $class = caller;
    $class->static_accessor( $name, $value );
}

sub coarsen {
	my ( $value, $resolution ) = @_;
	return $resolution ? ceil( $value / $resolution ) * $resolution : $value;
}

# datetime is DateTime object
# resolution is DateTime::Duration object, the resulting time will be aligned to it
sub coarsen_dt {
    my ( $datetime, $resolution ) = @_;

    return $datetime unless $resolution;

    my $date = $datetime->clone()->truncate( to => "day" );

    return $date->add(
        minutes => coarsen(
            $datetime->subtract_datetime($date)->in_units('minutes'),
            $resolution->in_units('minutes')
        )
    );
}

sub equals {
    if (defined $_[0]) {
        return 0 if (not defined $_[1]);
        
        return $_[0] == $_[1];
    }  else {
        return 0 if defined $_[1];
        
        return 1;
    }
}

sub equals_s {
    if (defined $_[0]) {
        return 0 if (not defined $_[1]);
        
        return $_[0] eq $_[1];
    }  else {
        return 0 if defined $_[1];
        
        return 1;
    }
}

sub hashDiff {
    my ($src,$dst) = @_;
    
    $dst = $dst ? { %$dst } : {} ;
    $src ||= {};
    
    my %result;
    
    foreach my $key ( keys %$src ) {
        if (exists $dst->{$key}) {
            $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key});
            delete $dst->{$key};
        } else {
            $result{"-$key"} = 1;
        }
    }
    
    $result{"+$_"} = $dst->{$_} foreach keys %$dst;
    
    return \%result;
}

sub hashMerge {
    return hashApply( { %{$_[0] || {}} }, $_[1] );
}

sub hashApply {
    my ($target,$diff) = @_;
    
    return $target unless ref $diff eq 'HASH';
    
    while ( my ($key,$value) = each %$diff) {
        $key =~ /^(\+|-)?(.*)$/;
        my $op = $1 || '+';
        $key = $2;
        
        if ($op eq '-') {
            delete $target->{$key};
        } else {
            $target->{$key} = $value;
        }
    }
    
    return $target;
}

sub hashCompare {
    my ($l,$r,$cmp) = @_;
    
    $cmp ||= \&equals_s;
    
    return 0 unless scalar keys %$l == scalar keys %$r;
    &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l;
    
    return 1;
}

sub hashParse {
    my ($s,$p,$d) = @_;
    
    $p = $p ? qr/$p/ : qr/\n+/;
    $d = $d ? qr/$d/ : qr/\s*=\s*/;
    
    return {
        map split($d,$_,2), split($p,$s)
    };
}

sub hashSave {
    my ($hash,$p,$d) = @_;
    
    return "" unless ref $hash eq 'HASH';
    
    $p ||= "\n";
    $d ||= " = ";
    
    return
        join(
            $p,
            map(
                join(
                    $d,
                    $_,
                    $hash->{$_}
                ),
                keys %$hash
            )
        );
}

1;