lib/LaTeX/TikZ/Functor.pm

   1 package LaTeX::TikZ::Functor;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Functor - Build functor methods that recursively visit nodes of a LaTeX::TikZ::Set tree.
   9
  10 =head1 VERSION
  11
  12 Version 0.03
  13
  14 =cut
  15
  16 our $VERSION = '0.03';
  17
  18 =head1 DESCRIPTION
  19
  20 A functor takes a L<LaTeX::TikZ::Set> tree and returns a new, transmuted version of it according to certain rules.
  21 It recursively visits all the nodes of the tree, building a new set out of the result of the functor on the child sets.
  22
  23 Rules are stored as L<LaTeX::TikZ::Functor::Rule> objects.
  24 They can apply not only to L<LaTeX::TikZ::Set> consumer objects, but also to the L<LaTeX::TikZ::Mod> consumer objects they contain.
  25 When the functor is called against a set object and that the returned set is different from the original (as told by C<==>, which defaults to object identity), then the functor is also applied to all the mods of the set, and their transformed counterparts are added to the new set.
  26
  27 When the functor is called onto a set or mod object, all its associated rules are tried successively, and the handler of the first matching rule is executed with :
  28
  29 =over 4
  30
  31 =item *
  32
  33 the functor object as its first argument ;
  34
  35 =item *
  36
  37 the current set or mod object as its second argument ;
  38
  39 =item *
  40
  41 the arguments passed to the functor itself starting at the third argument.
  42
  43 =back
  44
  45 The handler is expected to return the new set or mod that will replace the old one in the resulting set tree.
  46
  47 If no matching rule is found, the object is returned as-is.
  48
  49 =cut
  50
  51 use Carp ();
  52
  53 use Sub::Name ();
  54
  55 use LaTeX::TikZ::Functor::Rule;
  56
  57 use LaTeX::TikZ::Interface;
  58
  59 use LaTeX::TikZ::Tools;
  60
  61 my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set');
  62
  63 my $validate_spec;
  64 BEGIN {
  65  $validate_spec = Sub::Name::subname('validate_spec' => sub {
  66   my ($spec) = @_;
  67
  68   my ($replace, $target);
  69   if (defined $spec and ref $spec eq ''
  70     and $spec =~ /^(\+?)([A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*)$/) {
  71    $replace = defined($1) && $1 eq '+';
  72    $target  = $2;
  73   } else {
  74    Carp::confess("Invalid rule spec $spec");
  75   }
  76
  77   return $target, $replace;
  78  });
  79 }
  80
  81 =head1 METHODS
  82
  83 =head2 C<new>
  84
  85     my $functor = LaTeX::TikZ::Functor->new(
  86      rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ],
  87     );
  88
  89 Creates a new functor object that will use both the default and the user-specified rules.
  90 The functor is also a code reference that expects to be called against L<LaTeX::TikZ::Set> objects.
  91
  92 The default set and mod rules clone their relevant objects, so you get a clone functor (for the default set types) if you don't specify any user rule.
  93
  94     # The default is a clone method
  95     my $clone = Tikz->functor;
  96     my $dup = $set->$clone;
  97
  98 If there is already a default rule for one of the C<$spec>s, it is replaced by the new one ; otherwise, the user rule is inserted into the list of default rules after all its descendants' rules and before all its ancestors' rules.
  99
 100     # A translator
 101     my $translate = Tikz->functor(
 102      # Only replace the way point sets are cloned
 103      'LaTeX::TikZ::Set::Point' => sub {
 104       my ($functor, $set, $x, $y) = @_;
 105
 106       $set->new(
 107        point => [
 108         $set->x + $x,
 109         $set->y + $y,
 110        ],
 111        label => $set->label,
 112        pos   => $set->pos,
 113       );
 114      },
 115     );
 116     my $shifted = $set->$translate(1, 1);
 117
 118 But if one of the C<$spec>s begins with C<'+'>, the rule will replace I<all> default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself).
 119
 120     # A mod stripper
 121     my $strip = Tikz->functor(
 122      # Replace all existent mod rules by this simple one
 123      '+LaTeX::TikZ::Mod' => sub { return },
 124     );
 125     my $naked = $set->$strip;
 126
 127 The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it.
 128 Thus, if you define your own L<LaTeX::TikZ::Set> or L<LaTeX::TikZ::Mod> object, be sure to register a default rule for it with the L</default_rule> method.
 129
 130 =cut
 131
 132 my @default_set_rules;
 133 my @default_mod_rules;
 134
 135 sub new {
 136  my ($class, %args) = @_;
 137
 138  my @set_rules = @default_set_rules;
 139  my @mod_rules = @default_mod_rules;
 140
 141  my @user_rules = @{$args{rules} || []};
 142  while (@user_rules) {
 143   my ($spec, $handler) = splice @user_rules, 0, 2;
 144
 145   my ($target, $replace) = $validate_spec->($spec);
 146
 147   my $rule = LaTeX::TikZ::Functor::Rule->new(
 148    target  => $target,
 149    handler => $handler,
 150   );
 151
 152   $rule->insert(
 153    into      => $rule->is_set ? \@set_rules : \@mod_rules,
 154    overwrite => 1,
 155    replace   => $replace,
 156   );
 157  }
 158
 159  my %dispatch = map { $_->target => $_ } @set_rules, @mod_rules;
 160
 161  my $self;
 162
 163  $self = bless sub {
 164   my $set = shift;
 165
 166   $lts_tc->assert_valid($set);
 167
 168   my $rule = $dispatch{ref($set)};
 169   unless ($rule) {
 170    for (@set_rules) {
 171     if ($_->handles($set)) {
 172      $rule = $_;
 173      last;
 174     }
 175    }
 176   }
 177   return $set unless $rule;
 178
 179   my $new_set = $rule->handler->($self, $set, @_);
 180   return $set if $new_set == $set;
 181
 182   my @new_mods;
 183 MOD:
 184   for my $mod ($set->mods) {
 185    my $rule = $dispatch{ref($mod)};
 186    unless ($rule) {
 187     for (@mod_rules) {
 188      if ($_->handles($mod)) {
 189       $rule = $_;
 190       last;
 191      }
 192     }
 193    }
 194    push @new_mods, $rule ? $rule->handler->($self, $mod, @_)
 195                          : $mod;
 196   }
 197   $new_set->mod(@new_mods);
 198
 199   return $new_set;
 200  }, $class;
 201 }
 202
 203 LaTeX::TikZ::Interface->register(
 204  functor => sub {
 205   shift;
 206
 207   __PACKAGE__->new(rules => \@_);
 208  },
 209 );
 210
 211 =head2 C<default_rule>
 212
 213     LaTeX::TikZ::Functor->default_rule($spec => $handler)
 214
 215 Adds to all subsequently created functors a default rule for the class or role C<$spec>.
 216
 217 An exception is thrown if there is already a default rule for C<$spec> ; otherwise, the new rule is inserted into the current list of default rules after all its descendants' rules and before all its ancestors' rules.
 218 But if C<$spec> begins with C<'+'>, the rule will replace I<all> default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself).
 219
 220 Returns true if and only if an existent rule was replaced.
 221
 222 =cut
 223
 224 sub default_rule {
 225  shift;
 226  my ($spec, $handler) = @_;
 227
 228  my ($target, $replace) = $validate_spec->($spec);
 229
 230  my $rule = LaTeX::TikZ::Functor::Rule->new(
 231   target  => $target,
 232   handler => $handler,
 233  );
 234
 235  $rule->insert(
 236   into      => $rule->is_set ? \@default_set_rules : \@default_mod_rules,
 237   overwrite => 0,
 238   replace   => $replace,
 239  );
 240 }
 241
 242 =head1 SEE ALSO
 243
 244 L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor::Rule>.
 245
 246 =head1 AUTHOR
 247
 248 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 249
 250 You can contact me by mail or on C<irc.perl.org> (vincent).
 251
 252 =head1 BUGS
 253
 254 Please report any bugs or feature requests to C<bug-latex-tikz at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LaTeX-TikZ>.
 255 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 256
 257 =head1 SUPPORT
 258
 259 You can find documentation for this module with the perldoc command.
 260
 261     perldoc LaTeX::TikZ
 262
 263 =head1 COPYRIGHT & LICENSE
 264
 265 Copyright 2010,2011,2012,2013,2014,2015 Vincent Pit, all rights reserved.
 266
 267 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 268
 269 =cut
 270
 271 1; # End of LaTeX::TikZ::Functor