File Coverage

blib/lib/Auto/Mata.pm

Criterion	Covered	Total	%
statement	121	121	100.0
branch	35	36	97.2
condition	3	5	60.0
subroutine	26	26	100.0
pod	8	12	66.6
total	193	200	96.5

package Auto::Mata;
# ABSTRACT: A simple, reliable finite state machine
$Auto::Mata::VERSION = '0.06';

use strict;
use warnings;
use parent 'Exporter';
use Carp;
use Data::Dumper;
use List::Util qw(first reduce);
use Storable qw(dclone);
use Type::Utils -all;
use Types::Standard -all;
use Type::Params qw(compile);

our @EXPORT = qw(
  machine
  ready
  terminal
  term
  transition
  to
  on
  with
);

our $DEBUG = $ENV{DEBUG_AUTOMATA};

my $Ident = declare 'Ident', as StrMatch[qr/^[A-Z][_0-9A-Z]*$/i];
my $State = declare 'State', as Tuple[$Ident, Any];
my $Type  = declare 'Type',  as InstanceOf['Type::Tiny'];
coerce $Type, from Undef, via { Any };

my $Transition = declare 'Transition', as Dict[initial => $Type, transform => Maybe[CodeRef]];
my $Transform  = declare 'Transform',  as Dict[initial => $Type, transform => CodeRef];

my $Automata = declare 'Automata', as Dict[
  ready => Maybe[$Ident],
  term  => Maybe[$Ident],
  map   => Map[$Ident, Map[$Ident, $Transition]],
];


sub machine (&) {
  my $code = shift;

  #-----------------------------------------------------------------------------
  # Define the machine parameters
  #-----------------------------------------------------------------------------
  my %map;
  my %fsm = (ready => undef, term => undef, map => \%map);

  do {
    local $_ = \%fsm;
    $code->();
    validate();
  };

  my $terminal = declare $fsm{term}, as Tuple[Enum[$fsm{term}], Any];
  my %state    = ($fsm{term} => $terminal);

  foreach my $from (keys %map) {
    my @next = map { $map{$from}{$_}{initial} } keys %{$map{$from}};
    $state{$from} = declare $from, as reduce { $a | $b } @next;
  }

  #-----------------------------------------------------------------------------
  # Build the transition engine
  #-----------------------------------------------------------------------------
  my @match;
  foreach my $from (keys %map) {
    #---------------------------------------------------------------------------
    # Create a type constraint that matches each possible initial "from" state.
    # Use this to build a matching function that calls the appropriate mutator
    # for that transisiton.
    #---------------------------------------------------------------------------
    foreach my $to (keys %{$map{$from}}) {
      my $final   = $state{$to};
      my $initial = $map{$from}{$to}{initial};
      my $with    = $map{$from}{$to}{transform};

      push @match, $initial, sub {
        my ($from, $input) = @$_;
        debug('%s -> %s', $from, $to);

        do { local $_ = $input; $input = $with->() } if $with;
        my $state = [$to, $input];

        if (defined(my $error = $final->validate($state))) {
          if (my $explain = $final->validate_explain($state, 'FINAL_STATE')) {
            debug($_) foreach @$explain;
          }

          croak join "\n",
            sprintf('Transition from %s to %s produced an invalid state.', $from, $to),
            sprintf('Attempted to move from %s to %s', explain($_), explain($state)),
            sprintf($error);
        }

        return @$state;
      };
    }
  }

  my $default = sub { croak 'no transitions match ' . explain($_) };
  my $transform = compile_match_on_type(@match, => $default);

  #-----------------------------------------------------------------------------
  # Return function that builds a transition engine for the given input
  #-----------------------------------------------------------------------------
  return sub {
    my $state = $fsm{ready};
    my $done;

    sub {
      return if $done;
      ($state, $_[0]) = $transform->([$state, $_[0]]);
      $done = $state eq $fsm{term};
      wantarray ? ($state, $_[0]) : $state;
    };
  };
}


sub ready    ($)   { assert_in_the_machine(); $_->{ready} = shift }
sub terminal ($)   { assert_in_the_machine(); $_->{term}  = shift }
sub term     ($)   { goto \&terminal }
sub to       ($;%) { (to   => shift, @_) }
sub on       ($;%) { (on   => shift, @_) }
sub with     (&;%) { (with => shift, @_) }


my $_transition_args;

sub transition ($%) {
  assert_in_the_machine();
  $_transition_args ||= compile($Ident, $Ident, $Type, Maybe[CodeRef]);

  my ($arg, %param) = @_;
  my ($from, $to, $on, $with) = $_transition_args->($arg, @param{qw(to on with)});

  croak "transition from state $from to $to is already defined"
    if exists $_->{map}{$from}{$to};

  my $init = declare "${from}_TO_${to}_INITIAL", as Tuple[Enum[$from], $on];

  $_->{map}{$from} ||= {};

  $_->{map}{$from}{$to} = {
    initial   => $init,
    transform => $with,
  };
}

#-------------------------------------------------------------------------------
# Throws an error when not within a call to `machine`. When debugging, includes
# the full `validate_explain` if the error was due to a type-checking failure.
#-------------------------------------------------------------------------------
sub assert_in_the_machine {
  croak 'cannot be called outside a state machine definition block' unless $_;

  unless (!defined(my $msg = $Automata->validate_explain($_, '$_'))) {
    debug('Invalid machine state detected: %s', join("\n", map {" -$_"} @$msg));
    croak 'invalid machine definition';
  }
}

#-------------------------------------------------------------------------------
# Emits a debug message preceded by 'DEBUG> ' to STDERR when $DEBUG is true.
# Behaves like `warn(sprintf(@_))` in all other respects.
#-------------------------------------------------------------------------------
sub debug {
  return unless $DEBUG;
  my ($msg, @args) = @_;
  warn sprintf("# DEBUG> $msg\n", @args);
}

#-------------------------------------------------------------------------------
# Alias for Data::Dumper::Dumper with no Indent and Terse output.
#-------------------------------------------------------------------------------
sub explain {
  my $state = shift;
  local $Data::Dumper::Indent = 0;
  local $Data::Dumper::Terse  = 1;
  Dumper($state);
}

#-------------------------------------------------------------------------------
# Validate sanity as much as possible without strict types and without
# guarantees on the return type of transitions.
#-------------------------------------------------------------------------------
sub validate {
  assert_in_the_machine();

  croak 'no ready state defined'
    unless $_->{ready};

  croak 'no terminal state defined'
    unless $_->{term};

  croak 'terminal state and ready state are identical'
    if $_->{ready} eq $_->{term};

  croak 'no transitions defined'
    unless keys %{$_->{map}};

  croak 'no transition defined for ready state'
    unless $_->{map}{$_->{ready}};

  my $is_terminated;

  foreach my $from (keys %{$_->{map}}) {
    croak 'invalid transition from terminal state detected'
      if $from eq $_->{term};

    foreach my $to (keys %{$_->{map}{$from}}) {
      if ($to eq $_->{term}) {
        $is_terminated = 1;
        next;
      }

      croak "no subsequent states are reachable from $to"
        unless exists $_->{map}{$to};
    }
  }

  croak 'no transition defined to terminal state'
    unless $is_terminated;
}


1;

__END__