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