File Coverage

blib/lib/Auto/Mata.pm

Criterion	Covered	Total	%
statement	138	139	99.2
branch	37	38	97.3
condition	6	8	75.0
subroutine	26	27	96.3
pod	9	13	69.2
total	216	225	96.0

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

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
  using
);

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[
  to        => $Ident,
  initial   => $Type,
  transform => Maybe[CodeRef],
];

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


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

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

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

  my %map      = %{$fsm{map}};
  my $ready    = $fsm{ready};
  my $term     = $fsm{term};
  my $Terminal = declare 'Terminal', as Tuple[Enum[$term], Any];

  my %final = ($term => $Terminal);

  foreach my $from (keys %map) {
    my @next = map { $_->{initial} } @{$map{$from}};
    $final{$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 $transition (@{$map{$from}}) {
      my $to      = $transition->{to};
      my $initial = $transition->{initial};
      my $with    = $transition->{transform};
      my $final   = $final{$to};

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

        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 $interactive = shift;

    my $state = $ready;
    my $done;

    my $iter = sub (\$) {
      return if $done;
      ($state, $_[0]) = $transform->([$state, $_[0]]);
      $done = $Terminal->check([$state, $_[0]]);
      wantarray ? ($state, $_[0]) : $state;
    };

    return $iter if $interactive;

    return sub (\$) {
      while (my ($state, $acc) = $iter->($_[0])) {
        ;
      }

      return $_[0];
    };
  };
}


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, @_) }
sub using    (&;%) { goto \&with }


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)});

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

  my $name = $on->name;
  my $init = declare "${from}_to_${to}_on_${name}", as Tuple[Enum[$from], $on];
  debug("New state: $init");

  foreach my $next (@{$_->{map}{$from}}) {
    croak "identical transition $next->{initial} already defined"
      if $init == $next->{initial};
  }

  my $transition = {
    to        => $to,
    initial   => $init,
    transform => $with,
  };

  # Add this contraint to the list of matches
  push @{$_->{map}{$from}}, $transition;
}

#-------------------------------------------------------------------------------
# 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}}
        && @{$_->{map}{$_->{ready}}};

  my $is_terminated;

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

    foreach my $next (@{$_->{map}{$from}}) {
      my $to = $next->{to};

      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__