#!/usr/bin/perl

=head1 SYNOPSIS

  package My::Class;
  use Moose;

  has stuff => (
    is => 'rw',
    isa => 'Int',
    traits => ['Timed'],
    predicate => 'has_stuff',
    clearer => 'clear_stuff',
  );

Later:

  my $obj = My::Class->new();

  $obj->stuff(3); # sets value for every interval
  $obj->stuff_timed({},3); # sets value the "default" interval
  $obj->stuff_timed({from=>$timestamp,to=>$timestamp2},3); # sets value for the given time interval

  print $obj->stuff(); # value for time();
  print $obj->stuff_timed(); # as above
  print $obj->stuff_timed({when=>$timestamp}); # as above, for given time

  print $obj->has_stuff(); # true if we have a value for time()
  print $obj->has_stuff_timed(); # as above
  print $obj->has_stuff_timed({when=>$timestamp}); # as above, for given time

  $obj->clear_stuff(); # deletes everything
  $obj->clear_stuff_timed({}); # deletes the "default" interval
  $obj->clear_stuff_timed({from=>$timestamp,to=>$timestamp2}); # deletes the given time interval

=cut

use strict;
use warnings all=>'FATAL';

package My::Attribute;{
use Moose::Role;
use MooseX::Types::Moose qw(ArrayRef Int Any);
use MooseX::Types::Structured qw(Dict);
use Moose::Util::TypeConstraints ();
use namespace::autoclean;

before _process_options => sub {
    my ($self, $name, $options) = @_;

    my $value_type;
    $value_type //= $options->{isa} ?
        Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa})
              : undef;
    $value_type //= $options->{does} ?
        Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does})
              : undef;

    $value_type //= Any;

    $options->{isa} = ArrayRef[Dict[
        from => Int,
        to => Int,
        value => $value_type,
    ]];
};

sub accessor_metaclass { 'My::Accessor' }

after install_accessors => sub {
    my ($self) = @_;

    my $class  = $self->associated_class;

    for my $meth (qw(accessor reader writer predicate clearer)) {
        my $check = "has_$meth";
        next unless $self->$check;

        my $type = "timed_$meth";
        my $basename = $self->$meth;
        my $name = "${basename}_timed";

        $class->add_method(
            $self->_process_accessors($type => $name,0)
        );
    }
};

use Data::Printer;

sub _find_interval_for {
    my ($self,$all_values,$when) = @_;

    my $default;

    for my $interval (@$all_values) {
        if ($interval->{from}==0 and $interval->{to}==0) {
            $default = $interval;
            next;
        }
        next if $interval->{from} > $when;
        next if $interval->{to} <= $when;
        return $interval;
    }
    return $default;
}

sub get_timed_value {
    my ($self,$instance,$opts,$for_trigger) = @_;

    print join ', ',caller;
    printf " get_timed_value(%s)\n",p($opts);

    my $when = $opts->{when} // $opts->{from} // time();

    my $all_values = $self->get_value($instance,$for_trigger);

    return unless $all_values && @$all_values;

    my $interval = $self->_find_interval_for($all_values,$when);

    return unless defined $interval;

    return $interval->{value};
}

sub set_timed_value {
    my ($self,$instance,$opts,$value) = @_;

    print join ', ',caller;
    printf " set_timed_value(%s,%s)\n",p($opts),p($value);

    if ($opts->{forever}) {
        $self->set_value($instance,[
            {
                from => 0,
                to => 0,
                value => $value,
            },
        ]);
    }
    else {
        my $interval = {
            from => $opts->{from}//0,
            to => $opts->{to}//0,
            value => $value,
        };

        # XXX this has to take into account interval intersections &c
        my $all_values = $self->get_value($instance);
        push @$all_values,$interval;
        $self->set_value($instance,$all_values);
    }
}

sub has_timed_value {
    my ($self,$instance,$opts) = @_;

    print join ', ',caller;
    printf " has_timed_value(%s)\n",p($opts);

    return unless $self->has_value($instance);

    my $when = $opts->{when} // time();

    my $all_values = $self->get_value($instance);

    return unless $all_values && @$all_values;

    return defined $self->_find_interval_for($all_values,$when);
}

sub clear_timed_value {
    my ($self,$instance,$opts) = @_;

    print join ', ',caller;
    printf " clear_timed_value(%s)\n",p($opts);

    if ($opts->{forever}) {
        $self->clear_value($instance);
    }
    # should do intersections &c
    die "unimplemented";
}
};

package Moose::Meta::Attribute::Custom::Trait::Timed;{
sub register_implementation { 'My::Attribute' }
}

package My::Accessor;{
use base 'Moose::Meta::Method::Accessor';
use Carp 'confess';

sub _instance_is_inlinable { 0 }

sub _generate_accessor_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        if (@_ >= 2) {
            $attr->set_timed_value($_[0], {forever=>1}, $_[1]);
        }
        $attr->get_timed_value($_[0], {when=>time()});
    }
}

sub _generate_reader_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        confess "Cannot assign a value to a read-only accessor"
            if @_ > 1;
        $attr->get_timed_value($_[0], {when=>time()});
    };
}

sub _generate_writer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        $attr->set_timed_value($_[0], {forever=>1}, $_[1]);
    };
}

sub _generate_predicate_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        $attr->has_timed_value($_[0], {when=>time()})
    };
}

sub _generate_clearer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        $attr->clear_timed_value($_[0], {forever=>1})
    };
}

sub _generate_timed_accessor_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        if (@_ >= 3) {
            $attr->set_timed_value($_[0], $_[1], $_[2]);
        }
        $attr->get_timed_value($_[0],$_[1]);
    }
}

sub _generate_timed_reader_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        confess "Cannot assign a value to a read-only accessor"
            if @_ > 2;
        $attr->get_timed_value($_[0],$_[1]);
    };
}

sub _generate_timed_writer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        $attr->set_timed_value($_[0], $_[1], $_[2]);
    };
}

sub _generate_timed_predicate_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        $attr->has_timed_value($_[0],$_[1])
    };
}

sub _generate_timed_clearer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;

    return sub {
        $attr->clear_timed_value($_[0],$_[1])
    };
}
};

package Foo;{
use Moose;
use MooseX::Types::Moose qw(Int);

has stuff => (
    is => 'rw',
    isa => Int,
    traits => ['Timed'],
    predicate => 'has_stuff',
    clearer => 'has_stuff',
);
}

package main;{
use Data::Printer;
use 5.012;

my $obj = Foo->new();

p $obj;

say $obj->stuff(2);
say $obj->stuff_timed({from=>10,to=>20},5);
say $obj->stuff_timed({},3);

p $obj;

say $obj->stuff();
say $obj->stuff_timed({});
say $obj->stuff_timed({when=>12});

}
