challenge_debugger.pl6

try_parms.t

use v6;

use Test;

use Terminal::ANSIColor;

class DebugInd {
  subset Nonnegative of Int where * > -1;
  my Nonnegative $debug-indent = 0; # several DebugInd objects would share the indent, hence 'my'

  has Bool $.debugging is rw = True;
  has Str $.color is rw;

  multi method color(Str $colorname) {
    given $colorname {
      when <none> { $!.color = Nil }
      default { $!color = $_ }
    }
  }
  multi method color() {
    return $!color;
  }
  method dbg(*@args) {
    return unless $!debugging;
    if $!color.defined {
      $*ERR.say(colored(@args.join.indent($debug-indent), $!color));
    } else {
      $*ERR.say(@args.join.indent($debug-indent));
    }
  }
  method dbg-up(*@args)   { self.dbg(@args); $debug-indent++ if $!debugging; }
  method dbg-down(*@args) {
    return unless $!debugging;
    die "Unbalanced dbg-down" if $debug-indent <= 0;
    $debug-indent--;
    self.dbg(@args);
  }
  method reset-indent() { $debug-indent = 0 }
  method dbg-left(*@args) { #| force skipping of indentation
    my $save = $debug-indent;
    $debug-indent = 0;
    self.dbg(@args);
    $debug-indent = $save;
  }
  method show-terse(Str $name) {
    my $wrapped = $!debugging ?? "[[$name]]" !! "  $name  ";
    return $!color.defined ?? colored($wrapped, $!color) !! $wrapped;
  }
}


class DebugIndFamily {
  has DebugInd %.debugFamily is rw;
  has Str @.debugName is rw;
  my DebugInd $guest .= new;

  method !add-one(Str $name, Str $color) {
    if $name ∈ @!debugName {
      die "$name already in use for debugger";
    } else {
      @.debugName.push($name);
      %!debugFamily{$name} = DebugInd.new(:$color);
    }
  }
  method add(*@names) {
    for @names -> $name { self!add-one($name, <none>) }
  }
  multi method add-colored(*@name-color) {
    for @name-color -> $name, $color {
      self!add-one($name, $color)
    }
  }
  multi method add-colored(*%name-color) {
    for %name-color.kv -> $name, $color {
      self!add-one($name, $color)
    }
  }
  method list() { %!debugFamily.keys }
  method list-colored() {
    %!debugFamily.keys.map{$_ => %!debugFamily{$_}.color }
  }
  method remove(*@names) {
    for @names -> $name {
      if $name ∈ @!debugName {
        @.debugName{$name}:delete;
      } else {
        die "$name not in use for debugger";
      }
    }
  }
  method configure(*@args) {
    my %save;
    for 0..^@!debugName.elems {
      %save{@!debugName[$_]} = %!debugFamily{@!debugName[$_]}.debugging;
    }
    %!debugFamily{@!debugName[$_]}.debugging = False for 0..^@!debugName.elems;
    unless self.set-on(@args) {
      for 0..^@!debugName.elems {
        %!debugFamily{@!debugName[$_]}.debugging = %save{@!debugName[$_]};
      }
      warn "Configuration undone"
    }
  }
  method set(Bool $onoff, *@args) {
    my $success = True;
    my $max = @!debugName.elems;
    for @args -> $setter {
      given $setter {
        when Int {
          if $setter ∈ 0..^$max {
            %!debugFamily{@!debugName[$_]}.debugging = $onoff for 0..^$setter;
          } else {
            warn "debugging level $setter out of range (0 .. {$max - 1})";
            $success = False;
          }
        }
        when Regex {
          for @!debugName -> $dname {
            if $dname ~~ $setter { %!debugFamily{$dname}.debugging = $onoff }
          }
        }
        when '*'  { %!debugFamily{@!debugName[$_]}.debugging = $onoff for 0..^$max }
        when Str {
          if $setter ∈ @!debugName {
            %!debugFamily{$setter}.debugging = $onoff;
          } else {
            warn "debugger name $setter not defined.";
            $success = False;
          }
        }

        when Positional {
          my @v = @$_;
          for @v -> $name {
            if %!debugFamily{$name}:exists { %!debugFamily{$name}.debugging = $onoff }
            else {
              warn "The name '$name' is not known as a debugging category";
              $success = False;
            }
          }
        }

        default {
          die "Debugging tool cannot be called with this parm: { $setter.perl }";
          $success = False;
        }
      }
    }
    return $success;
  }
  method set-on(*@args) { self.set(True, @args) }
  method set-off(*@args) { self.set(False, @args) }

  method dbg(Str $name, *@args)       { %!debugFamily{$name}.dbg(@args) }
  method dbg-up(Str $name, *@args)    { %!debugFamily{$name}.dbg-up(@args) }
  method dbg-down(Str $name, *@args)  { %!debugFamily{$name}.dbg-down(@args) }
  method dbg-left(Str $name, *@args)  { %!debugFamily{$name}.dbg-left(@args) }
  method guest(*@args) { $guest.dbg(@args) }
  method set-guest-color(Str $clr) { $guest.color($clr) }
  # method reset-indent() { $guest.reset-indent() } # all debuggers share indent
  method status-long() {
    "status: names= [{ @!debugName.join(', ') }]".say;
    for @!debugName -> $n {
      if %!debugFamily{$n}:exists {
        #  %!debugFamily{$n}.^type.say;
        "$n has color { %!debugFamily{$n}.color // '-' } and is { %!debugFamily{$n}.debugging ?? 'on' !! 'off' }".say;
      } else {
        "$n not in hash attribute".say
      }
    }
  }
  method status() {
    note @!debugName.map( {%!debugFamily{$_}.show-terse($_)} ).join;
  }
  method save() {
    my @saved;
    for 0..^@!debugName.elems {
      @saved.push($_) if %!debugFamily{@!debugName[$_]}.debugging;
    }
    return [@saved];
  }
  method restore($saved) {
    self.configure($saved.flat);
  }

}

# =====================  HYGIENE ============================
# anti functions
# We pledge that hygienic functions clean up after themselves
# Only diagnostic stuff can alter (e.g. number of hits: $nhits++)
# We use clear symbols to indicate hygiene operators,
#   namely ▼ and ▲. We use them in pairs as follows:
#   ▼▼ starts a new stack
#   ▼▲ to step forward and store an inverse action to undo it later
#   ▲▲ action that sets off undoing the stack.
# In their bare form the above steps are constructed as term and operators.
# There is a list of operators that provide specialized steps.
# NB. None of this gets exported. It's all for internal use.
# NB2. Although there is a single stack. it actually contains several nested stacks (scopes).

my @antilist; # stack(s) of things to be undone
my @act-ix; # list on indices of @antilist that start new scopes. for nested hygiene.

# bookmark local start of anti stack
sub term:<▼▼> { @act-ix.push(@antilist.elems) }
sub infix:<▼▲>(&f, &b) {
  @antilist.unshift(&b);
  &f();
}
sub prefix:<▲▲>(&f) {
  my $last-mark = @act-ix.pop;
  &f();
  my $since = @antilist.elems - $last-mark;
  @antilist.shift.() for (^$since);
}

sub infix:<+▼▲>($v is rw, $incr) { { $v += $incr } ▼▲ { $v -= $incr } }
sub prefix:<shift▼▲>(@l) { my $v; { $v = @l.shift } ▼▲ { @l.unshift($v) } }
sub infix:<unshift▼▲>($v, @l) { { @l.unshift($v) } ▼▲ { @l.shift } }
sub infix:<push▼▲>($v, @l) { { @l.push($v) } ▼▲ { @l.pop } }; # NB $v could not have changed
sub prefix:<pop▼▲>(@l) { my $v; { $v = @l.pop } ▼▲ { @l.push($v) }; return $v; }; # NB $v could not have changed
sub infix:<pend▼▲>(@part, @l) { { prepend(@l, @part) } ▼▲ { splice @l, 0, @part.elems } }
# the following ops require DebugIndFamily
sub infix:<dbg▼▲>($fam, $cat) {
  return sub (Str $s) {
    { $fam.dbg-up($cat, "> ", $s) } ▼▲ { $fam.dbg-down($cat, "< ", $s) }
  }
}
sub infix:<dbgleft▼▲>($fam, $cat) {
  return sub (Str $s) {
    { $fam.dbg-left($cat, "> ", $s) } ▼▲ { $fam.dbg-left($cat, "< ", $s) }
  }
}

# =====================  EXCEPTIONS =========================
# NB not exported
class ParseExc is Exception { method message() { "Parse exception!" } }
class ParseStop is ParseExc { method message() { "Parse stopped!" } }
class ParseStopFirst is ParseStop { method message() { "Parse stopped on first match!" } }
class ParseAbort is ParseExc { method message() { "Parse aborted!" } }



# =====================  TRANSDUCION ========================
# this class is the heart of the module. It provides non-deterministic parsing
# and associates each node with an action to perform on a successful analysis.
# the analysis is context-free, but allows regular right hand sides,
# free order alternatives and features (aka attributes).
# A special provision is made, experimental and switched off by default,
# to allow ellipsis in coordination.

# requires DebugIndFamily
class Transduction is export {
  # has DebugIndFamily $.debugfam .= new.add-colored(<rest yellow cont green act red>);
  has DebugIndFamily $.debugfam;

  # =====================  HELPER      ========================

  sub stack-name($elt) {
    given $elt {
      when Code { $elt.name }
      when Str { "'$elt'" }
      default { '?' ~ $elt.^name }
    }
  }

  class Action {
    # each node in the Transduction is associated with an action. (There are also actions for
    # the opening and closing of member lists, but these are never elaborated)
    # There are TrueAction's as well as other derivatives. The latter serve as placeholders
    # on the action stack.
  }
  class TrueAction is Action {
    # Action is a wrapper around user defined transduction procs (coming first in alternatives)
    # members:
    #      $!covered holds the string segment (for string or regex)
    #      $!proc holds the sub to be elaborated (if missing: identity)
    #      $!match holds the match info if a regex was matched
    # Actions are put on the action stack while parsing
    # waiting to be evaluated on a cf match
    # method elab applies the action
    has Str $.covered;
    has &.proc;
    has Match $.match;

    method elab(Transduction $t) {
      $t.debugfam.dbg-up(<act>, ':> ', self.show);
      # my $result = $!covered.defined ?? $!covered !! &!proc($t);   # TODO give access to match info
      my $result = &!proc.defined ?? &!proc($t) !! $!covered;   # TODO give access to match info
      $t.debugfam.dbg-down(<act>, ":<  { $result.defined ??  $result.perl !! '(undefined)' }");
      return $result;
    }
    method show() {
      $!covered.defined ?? "'$!covered'" !!
       &!proc.defined ?? (&!proc.name || '(proc)') !! # NB &!proc.name is defined as empty string in unnamed procs
        '(?)';
    }
  }
  # special actions for opening and closing member lists. Only their identity matters.
  class OpenAction is Action { }
  class CloseAction is Action { }
  sub Open(Transduction $t) { $t.step-with-action(OpenAction) }
  sub Close(Transduction $t) { $t.step-with-action(CloseAction) }

  has Int $.action-ix = 0;
  has Action @!actions = [];
  method get-action(Int $ix) { @!actions[$ix] }
  method get-actions-status() {
    "act ({@!actions.elems}): { [~] @!actions.map: {
      given $_ {
        when OpenAction { '[' }
        when CloseAction { ']' }
        when TrueAction { $_.show }
        when Action { '@' } # presently only derived classes in use, so this cannot happen.
        default { #`( should not happen ) note "unexpected action: " ~ $_.perl; "XXX" }
      }
    } }";
  }

  has @!continuation = ();
  has @!trail = ();

  method BUILDALL(|) {
    $!debugfam .= new;
    # $!debugfam.add-colored(<rest yellow stacks cyan cont green act red diag magenta>);
    $!debugfam.add-colored( <rest   stacks  cont    act     diag> Z
                            <yellow cyan    green   red     magenta>);
    $!debugfam.configure(0);
    self.reset;
    callsame;
    # nextsame;
  }

  constant $line-size = 78; # 80 - size of indent. get this constant from somewhere if possible
  # to left and right align material on screen
  sub lr-align($left-str, $right-str) {
    $left-str ~ (' ' x (- $left-str.chars - $right-str.chars) % $line-size ) ~ $right-str  # '' Atom confused
  }
  method get-cont-status() {
    lr-align(     "trail: { @!trail.map: { stack-name($_) } }",
                  "cont: { @!continuation.map: { stack-name($_) } }");
  }

  sub show-string-context(Str $full is copy, Int $pos, Int $margin = 100, --> Str) {
    $full ~~ s:g/\s/ /;
    my $left-context = $full.substr(0, $pos).substr(0 max *-$margin);
    my $right-context = $full.substr($pos).substr(0, $margin);
    return "$left-context$right-context\n"
      ~ ' ' x $left-context.chars ~ "^"
  }
  has Int $.error-context-width = 20; # this many characters shown on both sides on error

  has Int $.pos = 0; # parsing position in input
  has Int $.max-pos = 0; # farthest position reached
  has Int $.nhits = 0; # for the current or last transduction
  has Int $.ntrans = 0; # number of transductions performed
  has $.transduced; # type depends on actions applied

  # parameters passed on constructor
  has &.root;
  has $.name;
  has Str $.input;
  # the event handlers (see list below) all take Transduction as first parm
  # usually they have a second part representing a (partial) analysis.
  # NB They are not methods.
  # NB Type of parameters depends on actions applied
  has &.on-success;
  has &.on-failure;
  has &.on-transduction-start;
  has &.on-transduction-end;
  has &.on-run-start;
  has &.on-run-end;
  has &.on-line-end;
  has Bool $.match-once;
  has Bool $.prefix-matching;
  has Bool $.repeat;
  has Bool $.per-line;
  has Bool $.allow-coordination;
  has Bool $.allow-ellipsis; # not currently used. (automatic for coordination)
  has Bool $.silent-mode; # prevents note()s on success and failure
  has Bool $.debug-mode; # set all debugging on

  constant @scalar-opts = <name input
    match-once prefix-matching repeat per-line
    allow-coordination allow-ellipsis
    silent-mode debug-mode>;
  constant @procedural-opts = <root
    on-success on-failure on-line-end
    on-transduction-start on-transduction-end
    on-run-start on-run-end>;
  my @all-opts = flat @scalar-opts, @procedural-opts;
  my %opt-type = flat ((@scalar-opts X=> '$'), (@procedural-opts X=> '&'));

  method reset() { self.reset-list(@all-opts) }
  method reset-list(@list) { for @list { self.reset-one($_) } }
  method reset-one($varname) { # TODO can I simplify this method?
    given $varname {
      when 'name' { $!name = Nil }
      when 'root' { &!root = Nil }
      when 'input' { $!input = Nil }
      when 'on-success' { &!on-success = sub (Transduction $t, $sofar, $new) {
          note "!!!!!!!!!!!! ready: { $new does Stringy ?? ~$new !! '('~ $new.^perl ~ ')' }"
            unless $!silent-mode;
          $new;
        }
      }
      when 'on-failure' { &!on-failure = sub (Transduction $t, $partial) {
          note "!!!!!!!!!!!! failed at:\n" ~ show-string-context($t.input, $t.max-pos, $t.error-context-width)
            unless $!silent-mode;
          $partial; # unchanged
        }
      }
      when 'on-line-end' { &!on-line-end = sub (Transduction $t, $partial) { $partial } }
      when 'on-transduction-start' { &!on-transduction-start = sub (Transduction $t, $partial) { $partial } }
      when 'on-transduction-end' { &!on-transduction-end = sub (Transduction $t, $partial) {
          note "number of hits: { $t.nhits }\tmax pos: { $t.max-pos }"
            unless $!silent-mode;
          $partial;
        }
      }
      when 'on-run-start' { &!on-run-start = sub (Transduction $t) { Nil } }
      when 'on-run-end' { &!on-run-end = sub (Transduction $t, $partial) {
          note "number of transductions: { $t.ntrans }\tmax pos: { $t.max-pos }"
            if $!ntrans > 1 and not $!silent-mode;
          $partial;
        }
      }
      when 'match-once' { $!match-once = False }
      when 'prefix-matching' { $!prefix-matching = False }
      when 'repeat' { $!repeat = False }
      when 'per-line' { $!per-line = False }
      when 'allow-coordination' { $!allow-coordination = False }
      when 'allow-ellipsis' { $!allow-ellipsis = False }
      when 'silent-mode' { $!silent-mode = False }
      when 'debug-mode' { $!debug-mode = False }
      default { die "undefined parameter $varname" }
    }
  }


  method init(*%hash) {
    use MONKEY-SEE-NO-EVAL;
    for %hash.kv -> $prop, $value {
      my $lc-prop = $prop.lc;
      if $lc-prop ∈ @all-opts {
        EVAL "%opt-type{$prop}!$lc-prop = \$value";
      } else {
        die "property '$prop' not valid in Transduction.run"
      }
    }
  }

  method at-line-end() {
    return $!pos < $!input.chars
      ?? $!input.substr($!pos, 1) == "\n"
      !! True;
  }
  # 'run()' runs a whole transduction round
  method run(*%hash) {
    my Bool $go-on = True;
    # $!debugfam.status;
    @!actions = [];
    $!action-ix = 0;
    @!continuation = ();
    @!trail = ();

    self.init(|%hash);
    my $save-dbg = $!debugfam.save;
    self.debug-config(<*>) if $!debug-mode;
    die "No input supplied" unless $!input.defined;
    die "No grammar supplied" unless &!root.defined;
    $!max-pos = $!pos = $!nhits = $!ntrans = 0;

    $!debugfam.dbg(<rest>, "Transducing { $!name // 'nameless' } on input: $!input");
    $!transduced = &!on-run-start(self);

    try {
      CATCH {
        when ParseStopFirst {
          $!debugfam.reset-indent;
          @!continuation = ();
          @!trail = ();
          @!actions = [];
          $!action-ix = 0;
          $!debugfam.dbg(<rest>, "Stacks unwound");
        }
        when ParseExc { note "Exception occurred:\n" ~ .Str }
        default { note "Uncaught exception:\n" ~ .Str;
          .throw;
        }
      }
      while $go-on {
        $!nhits = 0;
        $!transduced = &!on-transduction-start(self, $!transduced);
        $!ntrans++;
        &!root(self); # entry point for the analysis
        unless $!nhits {
           $!transduced = &!on-failure(self, $!transduced);
        }
        $!pos = $!max-pos;
        $!transduced = &!on-transduction-end(self, $!transduced);
        if $!repeat && ! $!per-line {
          $go-on = ! self.end-of-input;
        } elsif $!per-line { # repeat is implicit
          if self.end-of-input {
              $go-on = False;
          } else {
            $!pos++; # to skip the line end
            $go-on = False if self.end-of-input;
            # else goon = true
            with &!on-line-end {
              $!transduced = &!on-line-end(self, $!transduced);
            }
          }
        } else {
          $go-on = False;
        }
      }
    }
    $!transduced = &!on-run-end(self, $!transduced);
    $!debugfam.restore($save-dbg);

    self.reset-one(<debug-mode>); # debug mode should not stick

    return $!transduced;
  }
  method end-of-input() { $!pos == $!input.chars }

  # so here is the pivotal parsing step
  method step-with-action($act) {
    ▼▼;
    ( $!debugfam dbgleft▼▲ <stacks> )( self.get-cont-status );
    $act push▼▲ @!actions;
    if @!continuation.elems {
      my $top = shift▼▲ @!continuation;
      given $top {
        when $top === &Close {
          # there cannot be another Close. Remove up to and including next Open
          my $w = pop▼▲ @!trail until $w === &Open;
        }
        when Code { $top push▼▲ @!trail }
        # default is no-op?
      }
      # $!debugfam.dbg(<cont>, "takes top: ", stack-name($top));
      given $top {
        when List {
          note "--- WARNING: UNTESTED ---";
          dd $top;
          my ($func, *@mem) = $top[];
          dd @mem;
          ( $!debugfam dbg▼▲ <cont> )("[[{$func.name // '(anon)'}({ @mem.join(',') })]]");
          ▲▲ { $func(self, @mem) }
        }
        when Str {
          ( $!debugfam dbg▼▲ <cont> )("trying '$_' as string against { $!input.substr($!pos) }");

          if $!input.substr($!pos).starts-with($top) {
            $!pos +▼▲ $top.chars;
            $!max-pos = $!pos if $!pos > $!max-pos;
            ( $!debugfam dbg▼▲ <cont> )("'$top'");
            ▲▲ {
              my TrueAction $match-act .= new(
                covered => $top);
              self.step-with-action($match-act);
              self.coordinated($match-act) if $!allow-coordination;
            }
          } else {
            ▲▲ { $!debugfam.dbg(<cont>, "! [ { $top.perl } of type { $top.WHAT.perl } failed ]") }
          }
        }
        when Regex {
          my $is-regex if $_ === Regex;
          ( $!debugfam dbg▼▲ <cont> )("trying '{$_.perl}' as a regex against { $!input.substr($!pos) }");
          my Match $match;
          given $!input {
              my $p = $!pos;
              $match = m:pos($p)/<top=$top>/;
          }
          if $match {
            $!pos +▼▲ ~$match.chars;
            $!max-pos = $!pos if $!pos > $!max-pos;
            ( $!debugfam dbg▼▲ <cont> )('/' ~ ~$match ~ '/');
            ▲▲ {
              my TrueAction $match-act .= new(
                covered => ~$match, match => $match);
              self.step-with-action($match-act);
              self.coordinated($match-act) if $!allow-coordination;
            }
          } else {
            ▲▲ { $!debugfam.dbg(<cont>, "! [ { $top.perl } of type { $top.WHAT.perl } failed ]") }
          }
        }
        when Code { # normal nonterminal
          ( $!debugfam dbg▼▲ <cont> )( $top.name || '(anon)' )
            if $top.name.defined && $top.name ne '';
          ▲▲ { $top(self) }
        }
        default {
          ▲▲ { die "Unexpected type " ~ $top.WHAT.perl ~ " for top of continuation stack" }
        }
      }
    } elsif $!per-line && self.at-line-end {
        ▲▲ { self.on-match }
    } elsif $!prefix-matching || $!repeat || $!pos == $!input.chars {
        ▲▲ { self.on-match }
    }
  }
  method coordinated($act) { # only used when $!allow-coordination
    ▼▼;
    # for now
    {
      my ($v, $w);
      { $v = @!trail.pop; $w = @!continuation.shift } ▼▲ { @!continuation.unshift($w); @!trail.push($v) }
    }
    ( $!debugfam dbgleft▼▲ <stacks> )( '& ' ~ self.get-cont-status );
    { @!actions.push($act) } ▼▲ { @!actions.pop };
    { @!actions.push(CloseAction) } ▼▲ { @!actions.pop };
    my Match $match;
    given $!input {
        my $p = $!pos;
        $match = m:pos($p)/ '&' /; #TODO react upon true coordinator
    }
    if $match {
      $!pos +▼▲ ~$match.chars;
      $!max-pos = $!pos if $!pos > $!max-pos;
      ( $!debugfam dbg▼▲ <cont> )(' ~~~ coordinator ~~~');
      sub coord-rhs() { # we need this sub because this step is recursive
        return unless @!continuation.elems and @!trail.elems;
        ▼▼;
        my $elt;
        $elt = pop▼▲ @!trail;
        $elt unshift▼▲ @!continuation;
        ▲▲ {
          ▼▼;
          ( $!debugfam dbg▼▲ <diag> )(' shifting');
          if $elt === &Open {
            CloseAction push▼▲ @!actions;
            ( $!debugfam dbgleft▼▲ <stacks> )( self.get-actions-status );

            #self.actions-status('%%% ');
            $elt = shift▼▲ @!continuation until $elt === &Close;
            if @!continuation.elems {
              $elt = pop▼▲ @!trail;
              $elt unshift▼▲ @!continuation;
            } else {
              ▲▲ { ; } # no-op
              return;
            }

          } # if we get here then try
          ▲▲ {
            self.step-with-action(TrueAction.new(
              covered => '-&-', match => $match));
            coord-rhs;
          }
        }
      }

      ▲▲ { coord-rhs }
    }
  }
  method on-match() {
    ( $!debugfam dbgleft▼▲ <stacks> )( self.get-actions-status );
    #self.actions-status('%%% ');
    $!action-ix = 0;
    my $act = @!actions[$!action-ix++];
    my $result = $act.elab(self);
    # success only if the action succeeds
    if $result {
      $!transduced = &!on-success(self, $!transduced, $result);
      $!nhits++;
      if $!match-once { ParseStopFirst.new.throw; }
    }
  }
  # the '_()' method handles a grammar alternative. We gave it a short name because
  # it features in all grammar rules. It is hygienic.
  method _($action-expr, +@mem) {
    ▼▼;
    my @add-array = &Open, |@mem, &Close;
    @add-array pend▼▲ @!continuation;
    my $actix = @!actions.elems; # get index of first free action stack slot
    ▲▲ { self.step-with-action(TrueAction.new(proc => sub (Transduction $t) {
      my @m = [];
      while True {
        my $next = @!actions[$!action-ix++];
        next if $next ~~ OpenAction;
        last if $next ~~ CloseAction; # i.e. result of Close
        my $elabed = $next.elab($t);
        $!debugfam.dbg(<act>, ":: elab = { $elabed.perl // '(undefined)' }");
        @m.push($elabed);
      }

      return $action-expr($t, $actix, @m);
      # we pass the action element's index for the action's proc to inspect
    })) }
  }
  method debug-config(*@args) { $!debugfam.configure(@args) }
  method debug-on(*@args)     { $!debugfam.set-on(@args) }
  method debug-off(*@args)    { $!debugfam.set-off(@args) }
  #TODO elaborate
  method report() {
    if $!transduced.defined {
      say "reporting on { $!name // &!root.name // 'anonymous' } run, which yielded as last result: $!transduced."
    } else {
      say "reporting on { $!name // &!root.name // 'anonymous' } run, which yielded no result."
    }
  }
  method full-report() { ... }
}

# TODO: find a way to pass information on the context of the call
# so that we could say something like "this is the third alternative of the Abc rule"

sub _opt($action, *@mem) is export { # mems on arg list
    return sub ($tt) {
        $tt._($action, @mem);
        $tt._($action);
    }
}
sub _seq($action, *@mem) is export { # mems on arg list
    my $sq = sub ($tt) {
        $tt._($action, @mem, $sq);  # NB recursion on $sq
        $tt._($action);
    };
    return $sq;
}
sub _stir($action, *@mem) is export { # mems on arg list
    if !@mem {
      return sub ($tt) {
        $tt._($action)
      }
    }
    # else
    # to avoid counting spurious ambiguity all empty elements must
    # occur in order and preceed all non-empty ones
    return sub ($tt) {
      for (0..^+@mem) -> $i { # TODO make it non-optional on a move
        my @copy = @mem;
        my $m = splice(@copy, $i, 1)[0];
        $tt._($action, $m, _stir($action, @copy));
      }
    }
}
sub __($action, *@mem) is export {
    return sub ($tt) {
        $tt._($action, @mem);
    }
}

=begin comment

// package rules;
// =========== no packages hence confusion may arise between nont names and functions listed above.
// =========== sadly we have to use sub() and return in every action

// we present some readymade functions for action expressions
// you can make similar functions in your application

=end comment

sub aempty(Transduction $t, $ix, *@mem) is export { '' }
sub acopy(Transduction $t, $ix, *@mem) is export { @mem.join }
sub ashow(Transduction $t, $ix, *@mem) is export { @mem.join(',') }
sub afirst(Transduction $t, $ix, *@mem) is export { @mem[0] }
sub atoarray(Transduction $t, $ix, *@mem) is export {
  my @ret;
  if @mem.elems > 0 {
    @ret.push(@mem[0]) if @mem[0].defined;
    if @mem.elems > 1  {
      @ret.push(|@mem[1]);
    }
  }
  # note "atoarray: just took @mem[] and created @ret[]";
  return @ret;
}

#NB this is the only reason for passing the action index: to get at the match object following
#NB it does not (yet) work, because .match is notaccessible through Action
sub am1(Transduction $t, $ix, *@mem) is export { # get first parenthesized construct from following regex
  # next action (but also skip over OpenAction)
  $t.get-action($ix + 2).match<top>[0];
}

sub awrap(Transduction $t, $ix, *@mem) is export { '[' ~ @mem.join ~ ']' }
sub areverse(Transduction $t, $ix, *@mem) is export { @mem.reverse.join }

multi sub pipe(Transduction $t, $sofar, $new) is export { $new }
multi sub pipe(Transduction $t, $part) is export { $part }
multi sub pipe(Transduction $t) is export { Nil }

# =====================  FEATURES ============================

#= TODO make this a private class within Transduction
#class Feat {
  #= tree
  #= a feature instance refers to nodes in this tree
  #= grammar contains string denotations for features;
  #= convert to features using string2feats
  #my FeatureSemantics $fsem;
  my %fdom;
  sub string2feats(Str $str) {
    my @seg = $str.split( / ';' \s* / );
    for @seg -> $seg {
      my @f = $seg.split( '.' );
      my $fpointer = $%fdom;
      while @f.elems {
        my $f = @f.shift;
        $fpointer{$f} = { name => $f,  parent => $fpointer, kids => {} } unless $fpointer{$f}:exists;
        $fpointer = $fpointer{$f}<kids>;
      }
    }
  }

  # string2feats("aap.noot.mies");
  # string2feats("aap.hut.juf");
  # string2feats("aap.hut.gijs");

  # say %fdom.perl;
  sub report-feature-tree() {
    say "\nfeature semantics tree";
    for %fdom.keys.sort -> $k {
      sub recshow($p, $pref, $ind) {
        say ' ' x $ind, $pref, $p<name>;
        for $p<kids>.keys { recshow( $p<kids>{$_}, '.', $ind + $pref.chars + $p<name>.chars)}
      }
      recshow( %fdom{$k}, '', 0);
    }
  }

#}

#= feature publishing per nonterminal
sub φp(+@frame) is export {
  for @frame -> $frame-denot { string2feats($frame-denot) }
  return sub (Transduction $t, $ix, *@mem) { '[' ~ @frame[0] ~ ']' ~ @mem.join }
}

#= feature instance per member of an alternative
# sub φi($frame-denot) {
#   string2feats($frame-denot);
#   return ''; # no-op
# }
# =====================  TESTING ============================

sub testhits(Transduction $transducer, &top, Str $inp, Int $nhits,
#  Bool $debugging = False,
  *%opts
# Bool $allow-coordination = False
  ) is export {
  $transducer.reset;
  #$transducer.debug-config(<*>) if $debugging;
  $transducer.init(:silent-mode); # default for testhits: silent-mode on
  $transducer.init(|%opts);
  $transducer.run(root => &top, input => $inp);
  # on-success => &pipe,
  #  on-failure => &pipe, on-transduction-end => &pipe, :$allow-coordination);
  my $expected = $nhits == $transducer.nhits ;
  # if $expected {
  #   say "OK: $inp";
  # } else {
  #   say "Failed on $inp: { $transducer.nhits } hits instead of expected $nhits";
  # }
  return $expected;
}

sub S( Transduction $t ) {
  $t._(&acopy, $(&A, 'xyzzy'));
}
sub A( Transduction $t, $parm ) { $t._(&acopy, '<', $parm, '>') }


my Transduction $transducer .= new;

plan 1;

ok testhits($transducer, &S, '<xyzzy>', 1, :debug-mode), 'valid parm';